Este algoritmo me lo pasó anotado en un papel, un empleado de una delegación de AFIP Mar del Plata allá por 1997. Con algunas optimizaciones, hoy en día lo sigo utilizando.

Este es el TDA en Pascal.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» 
 º ERRCUIL - Algoritmo de Validacion º 
 º de CUIL - CUIT                    º 
 º Desarrollado por: H. Vivani.      º 
 º 14/07/2001                        º 
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ 
}
program errcuil;
uses 
   crt; 
type 
   tcuil=array[1..11] of char; 
var 
   c:tcuil; 
   i:byte; 
   vc1,vc2,vc3,vc4,vc5:byte; 
   vc6,vc7,vc8,vc9,vc10,vc11:byte; 
   vtotal,vcoci,vres:real; 
   err:integer;
begin 
   clrscr; 
   writeln('**CONTROL DEL CUIL**'); 
   writeln; 
   writeln; 
   i:=0; 
   write('Ingrese el CUIL: '); 
   repeat 
      i:=i+1; 
      read(c[i]); 
   until eoln(input); 
   val(c[1],vc1,err); 
   val(c[2],vc2,err); 
   val(c[3],vc3,err); 
   val(c[4],vc4,err); 
   val(c[5],vc5,err); 
   val(c[6],vc6,err); 
   val(c[7],vc7,err); 
   val(c[8],vc8,err); 
   val(c[9],vc9,err); 
   val(c[10],vc10,err); 
   val(c[11],vc11,err); 
   vtotal:=(vc1*5 + vc2*4 + vc3*3 + vc4*2 + vc5*7 + vc6*6 + vc7*5 + vc8*4 + vc9*3 + vc10*2)*10; 
   vcoci:=vtotal/11; 
   vres:=vtotal-(INT(vcoci)*11); 
   if (vres vc11) or (vcoci = 0) then 
   begin 
        writeln('VTOTAL: ', vtotal:10:2); 
        writeln('VCOCI: ', vcoci:10:2); 
        writeln('Vres: ', vres:10:2); 
        writeln; 
        writeln('CUIT ERRONEO'); 
   end 
   else 
   begin 
        writeln('VTOTAL: ', vtotal:10:2); 
        writeln('VCOCI: ', vcoci:10:2); 
        writeln('Vres: ', vres:10:2); 
        writeln; 
        writeln('CUIT OK'); 
   end; 
   readln; 
   readln; 
end.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
 º TDA LISTA – en memoria dinamica   º
 º Desarrollado por: H. Vivani.      º
 º Universidad CAECE – Mar del Plata º
 º 31/10/2000                        º
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
}

unit listad;

INTERFACE

type
   TElemL=integer;
   pnodo=^nodo;
   nodo=record
      dato:TElemL;
      sig:pnodo;
   end;
   tlista=record
      pri,act:pnodo;
   end;

Procedure IniciaL(var l:tlista);
Function VaciaL (l:tlista):boolean;
Procedure PrimeroL (var l:tlista);
Procedure SiguienteL(var l:tlista);
Function FinL(l:tlista):boolean;
Procedure InsertaL(var l:tlista;e:TElemL);      {inserta al medio o al final}
Procedure InsertaPpioL(var l:tlista;e:TElemL);
Procedure InsertaFinL(var l:tlista;e:TElemL);
Procedure InsertaNL(var l:tlista; e:TElemL; n:integer);
Procedure EliminaPpioL(var l:tlista);
Procedure ELiminaL(var l:tlista);

Procedure EliminaNL(var l:tlista;var e:TElemL; n:integer);
Procedure InfoL(l:tlista; var e:TElemL);
Procedure ModificaL(var l:tlista; e:TElemL);

IMPLEMENTATION

procedure IniciaL;
begin
   l.pri:=nil;
   l.act:=nil;
end;

function VaciaL;
begin
   vacial:=l.pri=nil;
end;

procedure PrimeroL;
begin
   l.act:=l.pri;
end;

procedure SiguienteL;
begin
   l.act:=l.act^.sig;
end;

function FinL;
begin
   finl:=l.act=nil;
end;

procedure InsertaL;                     {inserta al medio o al final}
var
   aux,act,ant:pnodo;
begin
   new(aux);
   aux^.dato:=e;
   if vacial(l) or (e <= l.pri^.dato) then {si vacia o < que el primero}
   begin
      aux^.sig:=l.pri;          {insertappio}
      l.pri:=aux;
   end
   else
   begin
      ant:=l.pri;
      act:=ant;
      while (act nil) and (e > act^.dato) do
      begin
         ant:=act;
         act:=act^.sig;
      end;
      ant^.sig:=aux;
      aux^.sig:=act;
   end;
end;

procedure InsertaPpioL;
var
   aux:pnodo;
begin
   new(aux);
   aux^.dato:=e;
   aux^.sig:=l.pri;
   l.pri:=aux;
end;

Procedure InsertaFinL;
var
   ant,act,aux:pnodo;
begin
   new(aux);
   aux^.dato:=e;
   ant:=l.pri;
   act:=ant;
   while act nil do
   begin
      ant:=act;
      act:=act^.sig;
   end;
   ant^.sig:=aux;
   aux^.sig:=act;
end;

procedure InsertaNL;
var
   aux,ant,act:pnodo;
   cont:integer;
begin
   new(aux);
   aux^.dato:=e;
   if n=1 then                          {si es el nodo 1}
   begin
      aux^.sig:=l.pri;
      l.pri:=aux;
   end
   else
   begin
      ant:=l.pri;
      act:=ant;
      cont:=1;
      while (act nil) and (cont < n) do
      begin
         cont:=cont+1;
         ant:=act;
         act:=act^.sig;
      end;
      ant^.sig:=aux;
      aux^.sig:=act;
   end;
end;

Procedure EliminaPpioL;
var
   aux:pnodo;
begin
   if l.prinil then
   begin
      aux:=l.pri;
      l.pri:=l.pri^.sig;
      dispose(aux);
   end;
end;

Procedure EliminaL;
var
   aux,ant:pnodo;
begin
   if l.prinil then
   begin
      if l.act=l.pri then       {si es el primer nodo}
      begin
         aux:=l.pri;
         l.pri:=l.pri^.sig;
         dispose(aux);
      end
      else
      begin
         ant:=l.pri;
         aux:=ant;
         while (aux nil) and (aux l.act) do
         begin
            ant:=aux;
            aux:=aux^.sig;
         end;
         ant^.sig:=aux^.sig;
         dispose(aux);
      end;
   end;
end;

procedure EliminaNL;
var
   aux,ant:pnodo;
   cont:integer;

begin
   if l.prinil then
   begin
      if n=1 then               {si es el primer nodo}
      begin
         e:=l.pri^.dato;
         aux:=l.pri;
         l.pri:=l.pri^.sig;
         dispose(aux);
      end
      else
      begin
         ant:=l.pri;
         aux:=ant;
         cont:=1;
         while (cont < n) and (aux nil) do
         begin
            cont:=cont+1;
            ant:=aux;
            aux:=aux^.sig;
         end;
         if aux nil then
         begin
            e:=aux^.dato;
            ant^.sig:=aux^.sig;
            dispose(aux);
         end;
      end;
   end;
end;

procedure InfoL;
begin
   e:=l.act^.dato;
end;

procedure ModificaL;
begin
   l.act^.dato:=e;
end;

end.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
 º TDA PILA – en memoria dinamica    º
 º Desarrollado por: H. Vivani.      º
 º Universidad CAECE – Mar del Plata º
 º 30/10/2000                        º
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
}

unit pilad;

INTERFACE

type
   TElemP=string[10];      {o cualquier tipo}
   tpila=^nodo;             {el tipo pila es un puntero a un nodo}
   nodo=record
      item:telemp;
      sig:tpila;
   end;

procedure IniciaP(var p:tpila);
procedure SacaP(var p:tpila;var e:telemp);
procedure PoneP(var p:tpila; e:telemp);
function VaciaP(p:tpila):boolean;
procedure ConsultaP(p:tpila; var e:telemp);

IMPLEMENTATION

procedure IniciaP;
begin
   p:=nil;
end;

procedure SacaP;
var
   aux:tpila;
begin
   if not vaciap(p) then
   begin
      aux:=p;                   {aux apunta a p}
      e:=p^.item;               {obtengo en e el elemento}
      p:=aux^.sig;              {p apunta al siguiente de aux}
      dispose(aux);             {devuelvo la memoria}
   end;
end;

procedure PoneP;
var
   nuevo:tpila;
begin
   new(nuevo);                  {pido memoria}
   nuevo^.item:=e;              {asigno el elemento}
   nuevo^.sig:=p;               {el siguiente del nuevo apunta a p}
   p:=nuevo;                    {p apunta al nuevo}
end;

function VaciaP;
begin
   VaciaP:=p=nil;
end;

procedure ConsultaP;
begin
   e:=p^.item;
end;

end.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
 º TDA COLA – en memoria dinamica    º
 º Desarrollado por: H. Vivani.      º
 º Universidad CAECE – Mar del Plata º
 º 30/10/2000                        º
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
}

unit colad;

INTERFACE

type
   TElemC=string[10];      {o cualquier tipo}
   pnodo=^nodo;
   nodo=record
      item:telemC;
      sig:pnodo;
   end;
   tcola=record
      pri,ult:pnodo;
   end;

procedure IniciaC(var c:tcola);
procedure SacaC(var c:tcola;var e:telemc);
procedure PoneC(var c:tcola; e:telemc);
function VaciaC(c:tcola):boolean;
procedure ConsultaC(c:tcola; var e:telemc);

IMPLEMENTATION

procedure IniciaC;
begin
   c.pri:=nil;
   c.ult:=nil;
end;

procedure SacaC;
var
   aux:pnodo;
begin
   if not vaciac(c) then
   begin
      e:=c.pri^.item;
      aux:=c.pri;
      if aux^.sig=nil then   {para cuando queda un elemento}
         c.ult:=nil;
      c.pri:=aux^.sig;
      dispose(aux);
   end;
end;

procedure PoneC;
var
   nuevo:pnodo;
begin
   new(nuevo);                  {pido memoria}
   nuevo^.item:=e;
   nuevo^.sig:=nil;
   if vaciac(c) then
      c.pri:=nuevo
   else
      c.ult^.sig:=nuevo;
   c.ult:=nuevo;
end;

function VaciaC;
begin
   VaciaC:=c.pri=nil;
end;

procedure ConsultaC;
begin
   e:=c.pri^.item;
end;

end.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
 º TDA COLA – SIMPLE Y CIRCULAR      º
 º Desarrollado por: H. Vivani.      º
 º Universidad CAECE – Mar del Plata º
 º 16/10/2000                        º
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
}
unit cola;

INTERFACE
const
   maxcola=50;
type
   telemento=char;
   tcola=record
      pri,ult:0..maxcola;
      items:array[1..maxcola] of telemento;
   end;

procedure IniciaC(var c:tcola);
function VaciaC(c:tcola):boolean;
function LlenaC(c:tcola):boolean;
procedure SacaC(var c:tcola;var elemc:telemento);
procedure PoneC(var c:tcola;elemc:telemento);
procedure ConsultaC(c:tcola; var elemc:telemento);

IMPLEMENTATION

procedure IniciaC;
begin
   c.pri:=0;
   c.ult:=0;
end;

function VaciaC;
begin
   VaciaC:=c.pri=0;
end;

{function LlenaC;
begin
   Llenac:=c.ult=maxcola;
end;}

function LlenaC;                        {CIRCULAR}
begin
   LlenaC:=((c.ult=maxcola) and (c.pri=1)) or (c.ult+1=c.pri);
end;

{procedure SacaC;
begin
   if not VaciaC(c) then
   begin
      elemc:=c.items[c.pri];
      if c.pri=c.ult then       {cuando la cola tiene un £nico elemento}
{         iniciac(c)
      else
         c.pri:=c.pri+1;
   end;
end;}

procedure SacaC;                        {CIRCULAR}
begin
   if not VaciaC(c) then
   begin
      elemc:=c.items[c.pri];
      if c.pri=c.ult then       {cuando la cola tiene un £nico elemento}
         iniciac(c)
      else
         if c.pri=maxcola then
            c.pri:=1
         else
            c.pri:=c.pri+1;
   end;
end;

{procedure PoneC;
begin
   if not LlenaC(c) then
   begin
      c.ult:=c.ult+1;
      c.items[c.ult]:=elemc;
      if c.pri=0 then           {si es el primer elemento}
{         c.pri:=1;
   end;
end;}

procedure PoneC;                        {CIRCULAR}
begin
   if not LlenaC(c) then
   begin
      if c.ult=maxcola then
         c.ult:=1               {continuo en el principio}
      else
         c.ult:=c.ult+1;
      c.items[c.ult]:=elemc;
      if c.pri=0 then           {si es el primer elemento}
         c.pri:=1;
   end;
end;

procedure ConsultaC;
begin
   if not VaciaC(c) then
      elemc:=c.items[c.pri];
end;

end.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
 º TDA PILA – en memoria estatica    º
 º Desarrollado por: H. Vivani.      º
 º Universidad CAECE – Mar del Plata º
 º 11/10/2000                        º
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
}
unit pila;

INTERFACE
const
   maxpila=50;
type
   telemento=char;
   tpila=record
      items:array [1..maxpila] of telemento;
      tope:0..maxpila;                        {0 para vacia}
   end;

procedure IniciaP(var p:tpila);
function VaciaP(p:tpila):boolean;
function LlenaP(p:tpila):boolean;
procedure SacaP(var p:tpila; var elemp:telemento);
procedure PoneP(var p:tpila; elemp:telemento);
procedure ConsultaP(p:tpila; var elemp:telemento);

IMPLEMENTATION

procedure IniciaP;
begin
   p.tope:=0;
end;

function VaciaP;
begin
   VaciaP:=p.tope=0;
end;

function LlenaP;
begin
   LlenaP:=p.tope=maxpila;
end;

procedure SacaP;
begin
   if not VaciaP(p) then
   begin
      elemp:=p.items[p.tope];
      p.tope:=p.tope-1;
   end;
end;

procedure PoneP;
begin
   if not LlenaP(p) then
   begin
      p.tope:=p.tope+1;
      p.items[p.tope]:=elemp;
   end;
end;

procedure ConsultaP;
begin
   if not vaciaP(p) then
      elemp:=p.items[p.tope];
end;

end.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
 º TDA LISTA – en memoria estatica   º
 º Desarrollado por: H. Vivani.      º
 º Universidad CAECE – Mar del Plata º
 º 11/10/2000                        º
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
}

unit lista;

INTERFACE
const
   maxlista=50;
type
   telemento=string;
   tlista=record
      items:array[1..maxlista] of telemento;
      cant,act:0..maxlista;
   end;

procedure IniciaL(var l:tlista);{prepara la lista para comenzar a operar}
function VaciaL(l:tlista):boolean;{verifica si est  vac¡a}
function LlenaL(l:tlista):boolean;{verifica si est  llena}
procedure PrimeroL(var l:tlista);{se posiciona al comienzo de la lista}
procedure SiguienteL(var l:tlista);{avanza al siguiente nodo de la lista}
function FinL(l:tlista):boolean;{verifica si se alcanz¢ el final de la lista}
procedure InsertaL(var l:tlista;eleml:telemento);{inserta en orden ascendente}
{procedure IncertaPpioL(var l:tlista;eleml:telemento);{inserta al principio}
{procedure InsertaFinL(var l:tlista;eleml:telemento);{inserta al final}
{procedure InsertaNL(var l:tlista;eleml:telemento;N:byte);{inserta en la N-‚sima posici¢n}
{procedure EliminaPpioL(var l:tlista);{elimia el primer noo de la lista}
{procedure EliminaL(var l:tlista);{elimina el nodo actual y avanza al siguiente}

procedure InfoL(l:tlista; var eleml:telemento);
procedure ModificaL(var l:tlista; eleml:telemento);

IMPLEMENTATION

procedure IniciaL;
begin
   l.cant:=0;
   l.act:=0;
end;

function VaciaL;
begin
   VaciaL:=l.cant=0;
end;

function LlenaL;
begin
   LlenaL:=l.cant=maxlista;
end;

procedure PrimeroL;
begin
   l.act:=1;
end;

procedure SiguienteL;
begin
   if not LlenaL(l) then
      l.act:=l.act+1;
end;

function FinL;  {detecta el fin despues de haber pasado el £ltimo (EOF)}
begin
   FinL:=l.act=l.cant+1;
end;

procedure InsertaL;     {inserta ordenado}
var
   j:0..maxlista;
begin
   if not LlenaL(l) then
   begin
      j:=l.cant;{corro los elementos desde el final h/encontrar la posicion}
      while (j>0) and (l.items[j]>eleml) do
      begin
         l.items[j+1]:=l.items[j];
         j:=j-1;
      end;
      l.items[j+1]:=eleml;      {inserto}
      l.cant:=l.cant+1;         {incremento la cantidad de elmentos}
   end;
end;

procedure InfoL;
begin
   if l.act>0 then
      eleml:=l.items[l.act];
end;

procedure ModificaL;
begin
   if l.act0 then
      l.items[l.act]:=eleml;
end;

end.

Algoritmos de ordenación clásicos. Métodos Burbuja, Inserción y Selección.

TDA en Pascal

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» 
 º TDA ORDENA - Algoritmos de        º 
 º ordenacion                        º 
 º Desarrollado por: H. Vivani.      º 
 º Universidad CAECE - Mar del Plata º 
 º 25/08/2000                        º 
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ 
}
unit ordena;
interface                       {PARTE PUBLICA}
const 
   max=100; 
type 
   tipo=integer; 
   tvector=array [1..max] of tipo;

procedure burbuja (var vector:tvector;n:byte); 
procedure insercion(var vector:tvector;n:byte); 
procedure seleccion(var vector:tvector;n:byte);

implementation                  {PARTE PRIVADA}

procedure burbuja; 
var 
   i,final,intercambio:byte; 
   aux:tipo; 
begin 
   final:=n; 
   intercambio:=1; 
   while intercambio 0 do 
   begin 
      intercambio:=0; 
      for i:=1 to final-1 do 
      begin 
         if (vector[i]>vector[i+1]) then 
         begin 
            aux:=vector[i]; 
            vector[i]:=vector[i+1]; 
            vector[i+1]:=aux; 
            intercambio:=i; 
         end; 
      end; 
      final:=intercambio; 
   end; 
end;

procedure insercion; 
var 
   i,j:byte; 
   aux:tipo; 
begin 
   for i:= 2 to n do 
   begin 
      aux:=vector[i]; 
      j:=i-1; 
      while (j>0) and (aux<vector[j]) do 
      begin 
         vector[j+1]:=vector[j]; 
         j:=j-1; 
      end; 
      vector[j+1]:=aux; 
   end; 
end;

procedure seleccion; 
var 
   i,j,minimo:byte; 
   aux:tipo; 
begin 
   for i:=1 to n-1 do 
   begin 
      minimo:=i; 
      for j:=i+1 to n do 
         if vector[j]<vector[minimo] then 
            minimo:=j; 
      aux:=vector[i]; 
      vector[i]:=vector[minimo]; 
      vector[minimo]:=aux; 
   end; 
end;

end.

{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
 º TDA FECHAS – Unit para el manejo  º
 º de fechas.                        º
 º Desarrollado por: H. Vivani.      º
 º Universidad CAECE – Mar del Plata º
 º 11/09/2000                        º
 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
}

unit fechas;

INTERFACE
uses
   dos;
type
   str10=string[10];
   tfecha=record
      anio:word;
      mes:byte;
      dia:byte;
   end;
   mes=array[0..1,1..12] of word;
   semana=array[0..6] of str10;

const
   dias:mes=((0,31,59,90,120,151,181,212,243,273,304,334),(0,31,60,91,121,152,182,213,244,274,305,335));
   diasem:semana=(‘Domingo’,’Lunes’,’Martes’,’Miercoles’,’Jueves’,’Viernes’,’Sabado’);

procedure LeeFecha(var f:tfecha);        {Ingresa una fecha desde el teclado}
procedure EscribeFecha(f:tfecha);        {Escribe la fecha}
function ObtMes(f:tfecha):byte;          {Obtengo el mes}
function ObtAnio(f:tfecha):word;         {Obtengo el a€o}
function ObtDia(f:tfecha):byte;          {Obtengo el d¡a}
function Bisiesto(f:tfecha):boolean;     {Analizo si es bisiesto}
function FechaValida(f:tfecha):boolean;  {Verifico si es valida la fecha}
function CantDias(f1,f2:tfecha):word;    {Obtengo cantidad de dias e/fechas}
function CantAnios(f1,f2:tfecha):word;   {Obtengo cantidad de anios e/fechas}
procedure FechaFinal(f1:tfecha; dd:word;var f2:tfecha); {Obtengo fecha a dd dias}
function DiaSemana(f:tfecha):str10;      {Obtengo el dia de la semana}
function FechaMayor(f1,f2:tfecha):boolean;{Determino si la 1er fecha es > que la 2da}
procedure Obtfsys(var f:tfecha);         {Obtengo la fecha del sistema}

IMPLEMENTATION

procedure leefecha;
begin
   write(‘A€o? ‘);readln(f.anio);
   write(‘Mes? ‘);readln(f.mes);
   write(‘D¡a? ‘);readln(f.dia);
end;

procedure escribefecha;
begin
   writeln(‘A€o? ‘,f.anio);
   writeln(‘Mes? ‘,f.mes);
   writeln(‘D¡a? ‘,f.dia);
end;

function obtmes;
begin
   obtmes:=f.mes;
end;

function obtanio;
begin
   obtanio:=f.anio;
end;

function obtdia;
begin
   obtdia:=f.dia;
end;

function Bisiesto;
begin
   if (f.anio mod 4=0) and ((f.anio mod 1000) or (f.anio mod 400=0)) then
      Bisiesto:=true
   else
      Bisiesto:=false;
end;

function ObtIndBis(f:tfecha):byte;       {Obtengo el indice del arreglo}
begin
   if bisiesto(f) then
      obtindbis:=1
   else
      obtindbis:=0;
end;

function ObtDiasMes(f:tfecha):byte;      {Obtengo cantidad de dias del mes}
var
   ind:byte;
begin
   ind:=obtindbis(f);
   if f.mes=12 then
      obtdiasmes:=365+ind-dias[ind,f.mes]        {verifico si es valido el dia}
   else
      if f.mes=1 then
         obtdiasmes:=31
      else
         obtdiasmes:=dias[ind,f.mes+1]-dias[ind,f.mes];
end;

function fechavalida;
var
   d,ind:byte;
   dd,mm:boolean;
begin
   ind:=obtindbis(f);
   if (f.mes>=1) and (f.mes<=12) then       {verifico si es valido el mes}
   begin
      mm:=true;
      if f.dia<=obtdiasmes(f) then
         dd:=true
      else
         dd:=false;
   end
   else
   begin
      mm:=false;
   end;

   if (f.anio>1900) and (dd=true) and (mm=true) then
      fechavalida:=true
   else
      fechavalida:=false;
end;

function BisiestoW(anio:word):boolean;{comprueba si el anio(word) es bisiesto}
begin
   if (anio mod 4=0) and ((anio mod 1000) or (anio mod 400=0)) then
      BisiestoW:=true
   else
      BisiestoW:=false;
end;

function cantdias;
var
   i1,i2:byte;
   d1,d2:word;
   i,acu:word;
begin
   acu:=0;
   i1:=obtindbis(f1);
   i2:=obtindbis(f2);
   d1:=dias[i1,f1.mes]+f1.dia;
   d2:=dias[i2,f2.mes]+f2.dia;
   if f1.anio=f2.anio then
   begin
      if d1<d2 then
         cantdias:=d2-d1
      else
         cantdias:=d1-d2;
   end
   else
   begin
      if f1.anio<f2.anio then
      begin
         for i:=f1.anio to f2.anio-1 do       {acumulo los dias de los anios}
         begin
            if bisiestow(i)=true then
               acu:=acu+366
            else
               acu:=acu+365;
         end;
         cantdias:=(acu)-d1+d2;
      end
      else
      begin
         for i:=f1.anio-1 downto f2.anio do   {acumulo los dias de los anios}
         begin
            if bisiestow(i)=true then
               acu:=acu+366
            else
               acu:=acu+365;
         end;
         cantdias:=(acu)+d1-d2;
      end
   end
end;

function Cantanios;
begin
   cantanios:=cantdias(f1,f2) div 365;
end;

procedure FechaFinal;        {VALIDA PARA +365 dias}
var
   ind,i,dia:byte;
   d1,d2,anio:word;
begin
   ind:=obtindbis(f1);                  {obtengo el indice del arreglo}
   d1:=dias[ind,f1.mes]+f1.dia+dd;      {acumulo el total de dias}
   writeln(‘acumulado de dias: ‘,d1);
   if d1<(365+ind) then                 {si no supero el anio actual}
   begin
      i:=f1.mes;
      while d1 > dias[ind,i] do         {busco el mes en el arreglo}
         i:=i+1;
      dia:=d1-dias[ind,i-1];
      f2.anio:=f1.anio;
      f2.mes:=i-1;
      f2.dia:=dia;
   end
   else
   begin
      d2:=d1-(365+ind);
      writeln(‘acumulado de dias 2: ‘,d2);
      i:=1;
      while d2 > dias[ind,i] do         {busco el mes en el arreglo}
         i:=i+1;
      dia:=d2-dias[ind,i-1];
      f2.anio:=f1.anio+1;
      f2.mes:=i-1;
      f2.dia:=dia;
   end
end;

function diasemana;
var
   fbase:tfecha;
begin
   fbase.dia:=06;
   fbase.mes:=01;
   fbase.anio:=1980;
   diasemana:=diasem[cantdias(fbase,f) mod 7];
end;

function fechamayor;
var
   ind1,ind2:byte;
   d1,d2:word;
begin
   ind1:=obtindbis(f1);
   ind2:=obtindbis(f2);
   d1:=dias[ind1,f1.mes]+f1.dia;
   d2:=dias[ind2,f2.mes]+f2.dia;
   if obtanio(f1)>obtanio(f2) then
      fechamayor:=true
   else
      if obtanio(f1)<obtanio(f2) then
         fechamayor:=false
      else
      begin
         if d1>d2 then
            fechamayor:=true
         else
            fechamayor:=false;
      end;
end;

procedure obtfsys;
var
   y,m,d,dow:word;     {en dow tengo el dia de la semana 0..6}
begin
   GetDate(y,m,d,dow);
   f.anio:=y;
   f.mes:=m;
   f.dia:=d
end;

end.