Pascal/Turbo Pascal - programa en pascal clínica la mejor

{Esto podía Ayudar}

program clinica;

uses

crt, dos;

const

patoA = 550;

patoB = 430;

patoC = 620;

ingres = 500;

archi = 'Datospac.dat';

type

string12 = string[12];

paciente = record

activo : boolean;

nombre : string[80];

apells : string;

numpac : longint;

edad : integer;

sexo : char;

patolg : char;

ingreso : real;

tiempo : integer;

fechent : string[12];

fechalt : string[12];

total : real;

end;

var

f : file of paciente;

datos : paciente;

ayo, mes, dia, sem : word;

function guardardatos(dd : paciente) : boolean;

var

tt : longint;

dt : paciente;

err : boolean;

begin

guardardatos := false;

assign(f,archi);

{$I-} reset(f); {$I+}

if ioresult <> 0 then

begin

rewrite(f);

seek(f,0);

write(f,dd);

close(f);

guardardatos := true;

end

else

begin

seek(f,filesize(f));

write(f,dd);

close(f);

guardardatos := true;

end;

end;

function diaingreso : string12;

var

comm, comd : string[2];

coma : string[4];

begin

getdate(ayo,mes,dia,sem);

str(ayo,coma);

str(mes,comm);

str(dia,comd);

if length(comd) = 1 then

insert('0',comd,1);

if length(comm) = 1 then

insert('0',comm,1);

diaingreso := comd + '/' + comm + '/' + coma;

end;

procedure entradapaciente;

var

tec : char;

begin

clrscr;

writeln('***** Ingreso Paciente *****');

writeln;

with datos do

begin

activo := true;

write(' Entre Nombre : ');

readln(nombre);

write(' Entre Apellidos : ');

readln(apells);

write(' Entre Num. Pacit. : ');

readln(numpac);

write(' Entre Edad : ');

readln(edad);

write(' Entre Sexo [F/M] : ');

readln(sexo);

write(' Entre Patol. [A/B/C] : ');

readln(patolg);

ingreso := ingres;

fechent := diaingreso;

writeln;

writeln(' >>> Acectar Datos [S/N] <<<');

repeat

tec := upcase(readkey);

until tec in['S','N'];

if tec = 'S' then

begin

if guardardatos(datos) = true then

writeln(' Datos De Paciente Guardados ')

else

writeln(' Error El Numero Paciente Existe No Guardado ');

writeln(' Pulse Una Tecla ');

end;

end;

end;

procedure consultar(num : longint);

var

tt : longint;

dto : paciente;

si : boolean;

begin

si := false;

tt := 0;

assign(f,archi);

{$I-} reset(f); {$I+}

if ioresult <> 0 then

begin

writeln(' Error Archivo No Encontrado Pulse Una Tecla');

readkey;

end

else

begin

for tt := 0 to filesize(f) - 1 do

begin

seek(f,tt);

read(f,dto);

if dto.numpac = num then

begin

si := true;

break;

end;

end;

if si = true then

begin

if dto.activo = true then

begin

with dto do

begin

writeln(' Nombre = ',nombre);

writeln(' Apellidos = ',apells);

writeln(' Numero Paciente = ',numpac);

case edad of

0..18 : writeln(' Categoria = Menor De Edad');

19..64 : writeln(' Categoria = Adulto');

65..107 : writeln(' Categoria = Mayor');

end;

writeln(' Patologia = ',patolg);

writeln(' Importe Ingreso = ',ingreso:0:2);

writeln(' Fecha Ingreso = ',fechent);

if fechalt <> ' ' then

writeln(' Fecha Actual = ',fechalt)

else

writeln(' Fecha Actual = ',diaingreso);

writeln(' Total Importe = ',total:0:2);

writeln;

end;

end

else

writeln(' El Paciente No Esta En Lista ');

end

else

writeln(' Numero Paciente No Encontrado ');

writeln(' Pulse Una Tecla');

close(f);

readkey;

end;

end;

procedure modificadatos(num : longint);

var

mo, mdi : paciente;

kk, jh : longint;

term : boolean;

deci : char;

begin

term := false;

assign(f,archi);

{$I-} reset(f); {$I+}

if ioresult <> 0 then

begin

writeln(' Error Archivo No Encontrado Pulse Una Tecla');

readkey;

end

else

begin

for jh := 0 to filesize(f) - 1 do

begin

seek(f,jh);

read(f,mdi);

if mdi.numpac = num then

begin

term := true;

kk := jh;

mo := mdi;

break;

end;

end;

if term = true then

begin

if mdi.activo = true then

begin

term := false;

repeat

clrscr;

writeln(' ***** Menu Modificaciones *****');

writeln;

writeln(' N = Nombre');

writeln(' A = Apellidos');

writeln(' P = Num. Paciente');

writeln(' E = Edad');

writeln(' G = Patologia');

writeln(' F = Fecha Ingreso');

writeln(' S = Salir Y Guardar Cambios');

writeln;

writeln(' <<< Elija Opcion >>>');

repeat

deci := upcase(readkey);

until deci in['N','A','P','E','G','F','S'];

clrscr;

case deci of

'N' : begin

write(' Nombre : ');

readln(mo.nombre);

end;

'A' : begin

write(' Apellidos : ');

readln(mo.apells);

end;

'P' : begin

write(' Num. Paciente : ');

readln(mo.numpac);

end;

'E' : begin

write(' Edad : ');

readln(mo.edad);

end;

'G' : begin

write(' Patologia: ');

readln(mo.patolg);

end;

'F' : begin

write(' Fecha Ingreso : ');

readln(mo.fechent);

end;

'S' : begin

term := true;

end;

end;

until term = true;

mdi := mo;

seek(f,kk);

write(f,mdi);

end;

end;

close(f);

end;

end;

procedure eliminapaciente(num : longint);

var

bn, hh : longint;

begin

assign(f,archi);

{$I-} reset(f); {$I+}

if ioresult <> 0 then

begin

writeln(' Error Archivo No Encontrado Pulse Una Tecla');

readkey;

end

else

begin

bn := 0;

for hh := 0 to filesize(f) - 1 do

begin

seek(f,hh);

read(f,datos);

if datos.numpac <> num then

begin

end

else

begin

datos.activo := false;

seek(f,hh);

write(f,datos);

end;

end;

close(f);

end;

end;

procedure reportefinal(num : longint);

var

totl : real;

pul : char;

pos, tt : longint;

sil : boolean;

d, m, an : word;

d1, m1, an1 : word;

d3, m3, an3 : word;

dar : string[2];

ay : string[4];

totaldias, error : integer;

begin

assign(f,archi);

{$I-} reset(f); {$I+}

if ioresult <> 0 then

begin

writeln(' Error Archivo No Encontrado Pulse Una Tecla');

readkey;

end

else

begin

sil := false;

for tt := 0 to filesize(f) - 1 do

begin

seek(f,tt);

read(f,datos);

if datos.numpac = num then

begin

sil := true;

pos := tt;

break;

end;

end;

if sil = true then

begin

if datos.activo = true then

begin

writeln(' Entrada Fecha Alta Como [A]=Automatico O [M]=Manual');

repeat

pul := upcase(readkey);

until pul in['A','M'];

if pul = 'A' then

datos.fechalt := diaingreso;

if pul = 'M' then

begin

writeln(' Entre Fecha De Alta d/m/a¤o ');

writeln;

write(' Fecha : ');

readln(datos.fechalt);

if datos.fechalt[2] = '/' then

insert('0',datos.fechalt,1);

if datos.fechalt[5] = '/' then

insert('0',datos.fechalt,4);

end;

dar := copy(datos.fechent,1,2);

val(dar,d,error);

dar := copy(datos.fechent,4,2);

val(dar,m,error);

ay := copy(datos.fechent,7,4);

val(ay,an,error);

dar := copy(datos.fechalt,1,2);

val(dar,d1,error);

dar := copy(datos.fechalt,4,2);

val(dar,m1,error);

ay := copy(datos.fechalt,7,4);

val(ay,an1,error);

d3 := 0;

m3 := 0;

an3 := 0;

d3 := d1 - d;

m3 := m1 - m;

an3 := an1 - an;

totaldias := (m3 * 30) + d3;

if (datos.patolg = 'A') or (datos.patolg = 'a') then

begin

datos.total := (patoA * totaldias);

end;

if (datos.patolg = 'B') or (datos.patolg = 'b') then

begin

datos.total := (patoB * totaldias);

end;

if (datos.patolg = 'C') or (datos.patolg = 'c') then

begin

datos.total := (patoC * totaldias);

end;

datos.activo := false;

clrscr;

writeln(' ***** Reporte De Alta *****');

writeln;

writeln(' Fecha De Ingreso = ',datos.fechent);

writeln(' Fecha De Alta = ',datos.fechalt);

writeln(' Dias De Ingreso = ',totaldias);

writeln(' Patologia = ',datos.patolg);

writeln(' Total Importe = ',datos.total:0:2);

writeln;

writeln(' <<< Pulse Una Tecla >>>');

readkey;

seek(f,pos);

write(f,datos);

close(f);

end

else

begin

writeln(' El Paciente No Esta Actovo ');

writeln(' <<< Pulse Una Tecla >>>');

readkey;

close(f);

end;

end;

end;

end;

procedure menu;

var

tecla : char;

sal : boolean;

nnm : longint;

begin

sal := false;

repeat

clrscr;

writeln(' ***** Menu Jeneral *****');

writeln;

writeln(' I = Incluir');

writeln(' C = Consultar');

writeln(' M = Modificar');

writeln(' E = Eliminar');

writeln(' R = Reporte Alta');

writeln(' S = Salir');

writeln;

writeln(' <<< Elija Opcion >>>');

repeat

tecla := upcase(readkey);

until tecla in['I','C','M','E','R','S'];

clrscr;

case tecla of

'I' : entradapaciente;

'C' : begin

write(' Entre Num. Paciente : ');

readln(nnm);

consultar(nnm);

end;

'M' : begin

write(' Entre Num. Paciente : ');

readln(nnm);

modificadatos(nnm);

end;

'E' : begin

write(' Entre Num. Paciente : ');

readln(nnm);

eliminapaciente(nnm);

end;

'R' : begin

write(' Entre Num. Paciente : ');

readln(nnm);

reportefinal(nnm);

end;

'S' : sal := true;

end;

until sal = true;

end;

begin

clrscr;

menu;

end.