Пример 1. Больница ведет учет пациентов

Больница ведет учет пациентов. Для каждого пациента имеется информация: Ф.И.О., год рождения, диагноз, дата поступления (день: месяц: год), курс лечения. Процедуры описать в модуле. Данные хранить в виде записей в файле. Организовать поиск пациентов с заданной фамилией.

Unit WorkLabRab7;

Interface

 

Type Pacient = Record

FIO: string[30];

year: 1900..2005;

diag: string[20];

date: record

den: 1..31;

mes: 1..12;

god: 1900..2005;

end;

kurs: integer;

end;

 

procedure Create(var x: mas; var l:integer); {регистрация пациентов}

procedure Open(var Name_File: string); {создание базы информации о пациентах}

procedure Add_Record(Name_File: string); {добавление информации о пациента}

procedure View(Name_File: string); {просмотр информации о пациентах}

procedure Del(Name_File: string); {удаление информации о пациентах}

procedure Search(Name_File: string); {поиск информации о пациентах}

 

Implementation

procedure Create(var Name_File: string);

var

f: file of Pacient;

A: Pacient;

i,n: integer;

begin

ClrScr;

Write('Введите имя файла:');

ReadLn(Name_File);

Assign(f,Name_File);

Rewrite(f);

Write('Введите количество записей:');

ReadLn(n);

if n>0 then

begin

For i:=1 to n do

begin

with A do

begin

Writeln('Введите данные ',i,'-го пациента');

write('Введите фамилию:');

Readln(FIO);

write('Введите год рождения:');

Readln(year);

write('Введите диагноз:');

Readln(diag);

writeln('Введите дату поступления:');

write('день:');

Readln(date.den);

write('месяц:');

Readln(date.mes);

write('год:');

Readln(date.god);

write('Введите курс лечения:');

Readln(kurs);

end;

write(f,A)

end;;

Writeln('Создан файл из ',n,' записей');

end

else Writeln('Создан пустой файл');

Close(f);

ReadKey;

end;

procedure Open(var Name_File: string);

var

f: file of Pacient;

begin

ClrScr;

Write('Введите имя файла:');

ReadLn(Name_File);

Assign(f,Name_File);

{$I-}

Reset(f);

{$I+}

If IOResult <> 0 then

begin

writeln ('Нет файла с именем ', Name_File);

Name_File:='';

end

else

begin

writeln ('Файла с именем ', Name_File, ' открыт');

Close(f);

end;

ReadKey;

end;

procedure Add_Record(Name_File: string);

var

f: file of Pacient;

A: Pacient;

begin

ClrScr;

Assign(f,Name_File);

{$I-}

Reset(f);

{$I+}

If IOResult <> 0 then

writeln ('Нет файла с именем ', Name_File)

else

begin

Seek(f,FileSize(f));

with A do

begin

Writeln('Введите данные ',FileSize(f)+1,'-го пациента');

write('Введите фамилию:');

Readln(FIO);

write('Введите год рождения:');

Readln(year);

write('Введите диагноз:');

Readln(diag);

writeln('Введите дату поступления:');

write('день:');

Readln(date.den);

write('месяц:');

Readln(date.mes);

write('год:');

Readln(date.god);

write('Введите курс лечения:');

Readln(kurs);

end;

write(f,A);

Writeln('Запись добавлена');

Close(f);

end;

ReadKey;

end;

procedure View(Name_File: string);

var

f: file of Pacient;

A: Pacient;

begin

ClrScr;

Assign(f,Name_File);

{$I-}

Reset(f);

{$I+}

If IOResult <> 0 then writeln ('Нет файла с именем ', Name_File)

else

begin

Writeln('Содержимое файла: ', Name_File);

Writeln('Содержимое файла: ', Name_File);

Writeln('| Ф.И.О. |Год рожд.| Диагноз |Дата поступления | Курс лечения |');

Writeln('___________________________________________________

while not Eof(f) do

begin

Read(f,A);

with A do

writeln(FIO: 10, Year: 10,Diag:10, Date.den: 8,

Date.mes:3, date.god:5, kurs:13);

end;

Close(f);

end;

ReadKey;

end;

procedure Del(Name_File: string);

var

f,Temp: file of Pacient;

A: Pacient;

k,i: integer;

begin

ClrScr;

Assign(f,Name_File);

{$I-}

Reset(f);

{$I+}

If IOResult <> 0 then writeln ('Нет файла с именем ', Name_File)

else

begin

Writeln('Файл ',Name_File, ' имеет ',FileSize(f), ' записей');

Write('Введите номер удаляемой записи №=');

ReadLn(k);

if (k<1) or (k>FileSize(f)) then Writeln('нет записи с №=',k)

else

begin

Assign(temp,'1.tmp');

Rewrite(temp);

For i:=1 to FileSize(f) do

begin

Read(f,A);

if i<>k then write(temp,A);

end;

Close(f); Close(temp);

Erase(f);

ReName(temp,Name_File);

Writeln('Запись удалена')

end;

end;

ReadKey;

end;

procedure Search(Name_File: string);

var

f: file of Pacient;

A: Pacient;

Fam: String[30];

Poisk: boolean;

begin

ClrScr;

Assign(f,Name_File);

{$I-}

Reset(f);

{$I+}

If IOResult <> 0 then writeln ('Нет файла с именем ', Name_File)

else

begin

Write('Введите фамилию пациента: ');

ReadLn(Fam);

Writeln('| Ф.И.О. |Год рожд.| Диагноз |Дата поступления| Курс лечения |’);

Writeln('___________________________________________________

Poisk:= False;

while not Eof(f) do

begin

Read(f,A);

with A do

if Fio = Fam then

begin

writeln(FIO: 10, Year: 10,Diag:10, Date.den: 8,

Date.mes:3, date.god:5, kurs:13);

Poisk:= true

end;

end;

Close(f);

If not Poisk then writeln('Нет пациентов с фамилией ',Fam);

end;

ReadKey;

end;

 

End.

 

 

Program Lab_Rab_7;

Uses Crt, WorkLabRab7;

var

Name_file: string;

Ch: char;

Begin

Name_File:='';

repeat

ClrScr;

Writeln('1-Создать файл');

Writeln('2-Открыть файл');

Writeln('3-Просмотр данных');

Writeln('4-Добавить данные');

Writeln('5-Удалить данные');

Writeln('6-Поиск данных ');

Writeln('7-Выход ');

Writeln;

Write('Выберите пункт меню ');

ReadLn(Ch);

Case Ch of

'1': Create(Name_File);

'2': Open(Name_File);

'3': if Name_File <> '' then View(Name_File)

else

begin

Writeln('Не задано имя файла (выберите пункт 1 или 2)');

Readkey;

end;

'4': if Name_File <> '' then Add_Record(Name_File)

else

begin

Writeln('Не задано имя файла (выберите пункт 1 или 2)');

Readkey;

end;

'5': if Name_File <> '' then Del(Name_File)

else

begin

Writeln('Не задано имя файла (выберите пункт 1 или 2)');

Readkey;

end;

'6': if Name_File <> '' then Search(Name_File)

else

begin

Writeln('Не задано имя файла (выберите пункт 1 или 2)');

Readkey;

end;

end;

until Ch = '7';

End.

Задание 5.1 (6 баллов)

Задание 5.2 (15 баллов)