CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol071/data.pas

Pascal/Delphi Source File | 1984-04-29 | 26.8 KB | 1,294 lines

program xdata;{$P+}
{$c-,m-,f-}
label 1;
const
defaultpad = '                                                           ';
male = true;
female = false;

type
id = array[1..6] of char;
calendar = array [1..2] of char;
date_of_test = record
        month:calendar;
        day:calendar;
        year:calendar
        end;
lab_data = record
    name: array [1..30] of char;
    chart_number:id;
    date: date_of_test;
    sex:boolean;
    weight: real;
    height: real;
    surface_area: real;
    chronological_age: real;
    bone_age: real;
    height_age:real;
    percent_overweight_for_height:real;
    total_body_water: real;
    values:array[1..18,1..14] of real;
    pad:array[1..59] of char;
    end;

byte = 0..255;
$string0 = string 0;
$string255 = string 255;
$string80 = string 80;
$string14 = string 14;
$string4 = string 4;
f = file of lab_data;
axis_label = array[1..4] of char;

var
filename:$string14;
norms,data:lab_data;
num_values, peak_time,time,results,x,y,i:byte;
fin:f;
average,max,min,sum:real;
normal_value_flag, error, terminate, continue,escape:boolean;
rec:integer;
strvalue:$string80;
x_axis_label,y_axis_label: array[1..14] of axis_label;


{************************* init labels for axis *************************}
procedure initialize;
var
i:byte;
begin
x_axis_label[1]:= '-30 ';
x_axis_label[2]:= '-1  ';
x_axis_label[3]:= '15  ';
x_axis_label[4]:= '30  ';
x_axis_label[5]:= '45  ';
x_axis_label[6]:= '60  ';
x_axis_label[7]:= '90  ';
x_axis_label[8]:= '120 ';
x_axis_label[9]:= '150 ';
x_axis_label[10]:= '180 ';
x_axis_label[11]:= '210 ';
x_axis_label[12]:= '240 ';
x_axis_label[13]:= '300 ';
x_axis_label[14]:= '360 ';

y_axis_label[1]:= 'BS  ';
y_axis_label[2]:= 'IRI ';
y_axis_label[3]:= 'GH  ';
y_axis_label[4]:= 'LH  ';
y_axis_label[5]:= 'FSH ';
y_axis_label[6]:= 'F   ';
y_axis_label[7]:= 'PRL ';
y_axis_label[8]:= 'TSH ';
y_axis_label[9]:= 'T   ';
y_axis_label[10]:= 'DS  ';
y_axis_label[11]:= 'ACTH';
y_axis_label[12]:= 'T4  ';
y_axis_label[13]:= 'TBG ';
y_axis_label[14]:= 'TT3 ';

end;


procedure setlength (var x:$string0; y:integer);external;
function length (x:$string255):integer; external;
procedure keyin(var cix:char);external;


procedure clear_screen;
begin
write (chr(27),'*',chr(0),chr(0),chr(0),chr(0));
end;

procedure erase_lines(starting_line,number_of_lines:byte);
const
blanks = '                                        ';
var
i:byte;

begin
for i:= 1 to number_of_lines do
    begin
    write(chr(27),'=',chr(starting_line + 31),chr(32),blanks,blanks);
    starting_line:= starting_line + 1;
    end;
end;

procedure move_cursor(x,y:byte);
begin
write(chr(27),'=',chr(y+31),chr(x+31));
end;

procedure prompt (x,y,length:byte; p:$string80;
              protected_field_desired:boolean);

var
underline:string 80;
i:byte;
begin
setlength(underline,0);
for i:= 1 to length do append (underline,'_');
if protected_field_desired = false then
    write(chr(27),'=',chr(y+31),chr(x+31),p,underline)
    else
    write(chr(27),'=',chr(y+31),chr(x+31),chr(27),')',p,
        underline,chr(27),'(');
end;

function query(x,y:byte; message:$string80):boolean;  {ask y/n question}
var
answer:char;
begin
repeat
move_cursor(x,y);
write(message);
keyin(answer);
until answer in ['y','n','Y','N'];
query:= ((answer = 'y') or (answer = 'Y'));
erase_lines(y,1);
end;

function strtoreal (str:$string80):real;
label 1;

var
decval,sign,val:real;
decimal,error:boolean;
l,i,len:integer;

begin
val:=0.0;
decval:=0.0;
len:=length(str);
l:=len;
error:=false;
decimal:=false;
i:=1;
sign:= 1.0;

if len = 0 then
    begin
    error:= true;
    goto 1;
    end;

while (decimal = false) and (i < len + 1 ) do
begin
    case str[i] of
    '-': sign:= -1.0;
    '.': decimal:= true;
    '0','1','2','3','4','5','6','7','8','9':
        val:=(val*10) + (ord(str[i]) - 48);
    end;
i:= i+ 1;
end;

while (decimal) and (l > i-1) do
    begin
        if str[l] in ['0'..'9'] then
        decval:= (decval*0.1) + ((ord(str[l])-48)*0.1);
        l:=l-1;
    end;
1:
strtoreal:=sign*(decval+val);
end;

function input_data (x,y,len:byte; alphanumeric:boolean;
                 maximum_value,minimum_value:real):$string80;

label 1;
var
data:$string80;
realdata:real;
i:byte;

procedure correct(x,y:byte);
var
i,a,b:byte;
begin
    erase_lines(1,1);
    write(chr(7));
    move_cursor(1,1);

    if (length(data)> len) then write ('TERM TOO LONG');

    if (alphanumeric = false) and
    ((realdata > maximum_value) or (realdata < minimum_value)) then
    write ('VALUE OUT OF RANGE');

    move_cursor(x,y);
    write(' ');
    a:=x;
    b:=y;

    for i:= 1 to length(data) do
    begin
        move_cursor(a,b);
        write (' ');
        a:= a + 1;
    end;

    move_cursor(x,y);
    write('_');
    a:=x;
    b:=y;
    for i:= 1 to (len-1) do
        begin
        move_cursor(a,b);
        write('_');
        a:= a+ 1;
        end;
    move_cursor(x,y);
    read(data);
    realdata:=strtoreal(data);
    erase_lines(1,1);

end;


begin
move_cursor(x,y);
read(data);
if (length(data) > 0) and (ord(data[1]) <> 27) then
        realdata:=strtoreal(data) else goto 1;

while (length(data) > len) or ((alphanumeric = false) and
    ((realdata > maximum_value) or (realdata < minimum_value)))
                do correct(x,y);

1:  if length(data) = 0 then data:= '-999';

if length(data) < len then for i:= length(data) to len do append(data,' ');
input_data:=data;
end;


function ucase (x:$string80):$string80;
label 1;
var
i,len,ascii:integer;
ucasex:$string80;

begin
setlength(ucasex,0);
len:=length(x);
if (len = 0) or (len > 4) then goto 1;
for i:= 1 to len do
    if (ord(x[i]) > 96) and (ord(x[i]) < 123) then
    append(ucasex,chr(ord(x[i])-32)) else
    append(ucasex,x[i]);
ucase:=ucasex;
1:
  end;


procedure calculate(current_number_of_records:integer);
var
i,thm,hm,o,t,h,th:byte;
begin
o:=0;
t:=0;
h:=0;
thm:=0;
hm:=0;
th:=current_number_of_records div 1000;
thm:= current_number_of_records mod 1000;
h:= thm div 100;
hm:= thm mod 100;
t:= hm div 10;
o:= hm mod 10;

with  data do
begin
chart_number[1]:= '0';
chart_number[2]:= '0';
chart_number[3]:= chr(th + 48);
chart_number[4]:= chr(h + 48);
chart_number[5]:= chr(t + 48);
chart_number[6]:= chr(o + 48);

end;
end;


procedure create_first_record;
var
j,i:byte;
number:integer;

begin
rewrite(filename,fin);
with data do
    begin
    name:='                              ';
    chart_number:='000001';
    date.month:='00';
    date.day:='00';
    date.year:='00';
    sex:=true;
    weight:= 0.0;
    height:= 0.0;
    surface_area:=0.0;
    chronological_age:=0.0;
    bone_age:= 0.0;
    height_age:=0.0;
    percent_overweight_for_height:=0.0;
    total_body_water:= 0.0;
    pad:=defaultpad;
    for i:= 1 to 18 do
        for j:= 1 to 14 do values[i,j]:= -999.0;
    write(fin:1,data);
    end;
end;


function number_records(filenam:$string14):integer;
label 1;
var
num:integer;
i:byte;

begin
num:= 0;
reset (filename,fin);
if eof(fin) then
    begin
    create_first_record;
    num:= 1;
    goto 1;
    end;
with data do
begin
read(fin:1,data);
for i:= 1 to 6 do num:= num*10 + ord(chart_number[i])-48;
end;
1: number_records:= num;
end;



procedure axis(pass:byte);
var
i:byte;

begin
writeln('     ');{DEBUG delay...terminal does not seem to respond fast enough}
for i:= 6 to 19 do
    begin
    move_cursor(1,i);
    write(x_axis_label[i-5]:4);
    end;
if pass <> 2 then
    begin
    prompt(1,21,0,'max',false);
    prompt(1,22,0,'min',false);
    prompt(1,23,0,'ave',false);
    prompt(1,24,0,'peak',false);
    end;

move_cursor(3,3);
write('chart number: ',data.chart_number:6,'Name: ':10,data.name:30);

case pass of
1:        move_cursor(9,5);
3:    move_cursor(1,5);
else:   move_cursor(6,5);
end;

if pass = 3 then write ('TIME     PATIENT   NORMAL (AVE)   DEVIATION') else
for i:= 1 to 14 do
    write(y_axis_label[i]:5);
end;


procedure get_chart_number;
label 1;
var
xchart_number:id;
xname:array[1..30] of char;
numrecs,i:integer;
number:$string80;
cno,found:boolean;
ch:char;

begin
cno:=false;
clear_screen;
move_cursor(1,8);
write('Enter ''NORMAL'' if you wish to display or alter normal values.');
prompt(1,10,6,'Enter either the patient''s name or chart number: ',false);
number:= input_data(50,10,30,true,0.0,0.0);
writeln;
writeln('One moment, please.');
if (ord(number[1]) > 47) and (ord(number[1]) < 58) then
    begin
    cno:= true;
    for i:= 1 to 6 do xchart_number[i]:= number[i];
    end;
if cno = false then
    begin
    for i:= 1 to 30 do
    xname[i]:=number[i];
    end;

reset(filename,fin);
numrecs:=number_records(filename);
i:=0;
normal_value_flag:= false;
error:= false;
with data do
begin
if (xname = 'NORMAL                        ')
or (xname = 'normal                        ') then
    begin
    normal_value_flag:= true;
    read(fin:1,data);
    norms.values:=data.values;
    rec:=1;
    goto 1;
    end;

repeat
i:= i+1;
read(fin:i,data);
case cno of
true:if xchart_number = data.chart_number then found:= true else found:= false;
false:if xname = data.name then found:=true else found:= false;
end; {of case}
until (found) or (i = numrecs);
if found then rec:= i else error:= true;

1:end;
if error then
    begin
    clear_screen;
    move_cursor(1,10);
    if cno then writeln('Chart number not found !') else
                writeln('Name not found !');
    writeln;
    writeln('Enter any character to continue.');
    keyin(ch);
    end;
clear_screen;
end;



procedure display_values(normal_value_flag, displayed_for_correction:boolean);
var
x,y,i:byte;
continue:char;

begin
clear_screen;
escape:=false;
writeln('      '); {DEBUG for terminal delay}
axis(1);
if normal_value_flag then
    begin
    move_cursor(3,3);
    write('NORMAL VALUES');
    end;
x:= 7;
y:= 6;
for time:= 1 to 18 do
    begin
    for results:= 1 to 14 do
        begin
        move_cursor(x,y);
        if abs(data.values[time,results]) <> 999.0 then
            write(data.values[time,results]:4:1)  else
            write('    '); {4 spaces}
        x:= x + 5;
        end;
    y:= y + 1;
    if y = 20 then y:= 21;
    x:= 7;
    end;
if displayed_for_correction = false then
    begin
    move_cursor(1,1);
    write('Enter any character to continue or ''ESC'' to return to menu.');
    keyin(continue);
    if ord(continue) = 27 then escape:= true;
    end;
end;



procedure print(desire_hardcopy:boolean);

label 1,2;
var
i:integer;
continue:char;
recursive,all,more:boolean;

procedure hardcopy(normal_value_flag:boolean);
var
counter,j:byte;
output:text;

begin
rewrite('lst:',output);

if recursive = false then
begin
write('Prepare printer, then enter any character to initiate listing. ');
keyin(continue);
clear_screen;
writeln('Now printing results.');
end;

write(output,chr(12));
for counter:= 1 to 3 do writeln(output);
with data do
begin

if normal_value_flag then chart_number:= 'NORMAL';
writeln(output,'chart_number: ',chart_number, ' Name: ',name);
writeln(output);
write(output,'    '); {4 spaces}
for counter:= 1 to 14 do write(output,y_axis_label[counter]:8);
writeln(output);

for counter:= 1 to 18 do
    begin
    if counter < 15 then write(output,x_axis_label[counter]:4,' ') else
        case counter of
        15: write(output,'max  ');
        16: write(output,'min  ');
        17: write(output,'ave  ');
        18: write(output,'peak ');
        end;

for j:= 1 to 14 do
    if abs(values[counter,j]) = 999.0 then
        write(output,' ':8) else
        write(output,values[counter,j]:8:1);

    writeln(output);
    writeln(output);
    end;

end;
end;

begin   {of procedure print}
reset(filename,fin);
if eof(fin) then
    begin
    writeln('NO FILE PRESENT!');
    writeln;
    write('Enter any character to continue. ');
    keyin(continue);
    goto 1;
    end;

clear_screen;
all:= query(1,10,'Do you wish to display all results for ALL patients? y/n ');

case all of
false:    begin
    repeat
    get_chart_number;

    case desire_hardcopy of
    true:    if error = false then hardcopy(normal_value_flag) else
                      erase_lines(10,3);
    false:  if error = false then display_values(false,false) else
                          erase_lines(10,3);
    end;
if (error) or (escape) then goto 1;  {goto menu if record not found or done}

error:=false;
erase_lines(1,1);
more:=query(1,1,'Do you wish to display data for another patient? y/n  ');
    until more  = false;
    end;

true:    begin
    rec:= number_records(filename);
    recursive:=false;
    for i:= 1 to rec do
        begin
        escape:= false;
        read(fin:i,data);
            case desire_hardcopy of
            true: if i= 1 then hardcopy(true) else hardcopy(false);
            false: if i= 1 then display_values(true,false) else
                            display_values(false,false);
            end;
        recursive:= true;
        if escape then goto 1;
        end;
    end;
end;    {of case}
1:
end;


procedure values_calculation;

begin
with data do
begin

for results:= 1 to 14 do
begin
max:= values[1,results];
peak_time:= 1;

if values[1,results] = -999.0 then
    begin
    sum:= 0.0;
    num_values:= 0;
    min:=999.0;
    end;

if values[1,results] > -999.0 then
    begin
    sum:= values[1,results] ;
    num_values:= 1;
    min:= values[1,results];
    end;

    for time := 2 to 14 do
    begin
    if max < values[time,results] then
        begin
        max:= values[time,results];
        peak_time:= time;
        end;

    if (values[time,results] > -999.0) and (min > values[time,results])
                then min:= values[time,results];

    if values[time,results] > -999.0 then
            begin
            sum:= sum + values[time,results] ;
            num_values:= num_values + 1;
            end;
    end;

average:= sum/num_values;
values[15,results]:= max;
values[16,results]:= min;
if average = 0.0 then values[17,results]:= -999.0 else
              values[17,results]:= average;

case peak_time of
1: values[18,results]:= -30.0;
2: values[18,results]:= -1.0;
3: values[18,results]:= 15.0;
4: values[18,results]:= 30.0;
5: values[18,results]:= 45.0;
6: values[18,results]:= 60.0;
7: values[18,results]:= 90.0;
8: values[18,results]:= 120.0;
9: values[18,results]:= 150.0;
10: values[18,results]:= 180.0;
11: values[18,results]:= 210.0;
12: values[18,results]:= 240.0;
13: values[18,results]:= 300.0;
14: values[18,results]:= 360.0;
end;

if average = 0.0 then values[18,results]:= -999.0;
end;


y:=21;
prompt(1,21,0,'max',false);
prompt(1,22,0,'min',false);
prompt(1,23,0,'ave',false);
prompt(1,24,0,'peak',false);
for time:= 1 to 4 do
    begin
    for results:= 1 to 14 do
        begin
        move_cursor(results*5+2,y);
        if (abs(values[time+14,results]) = 999.0) then
            write('    ') else
            write(values[time+14,results]:4:1);
        end;
    y:= y+ 1;
    end;
end; {of with data}
end;



procedure mistake (shift_over_x_axis_flag:boolean);
label 1,2;
var
strtime,strtest:$string80;
xtime,xtest: axis_label;
matrix,shift,i,j,time,test:byte;
found,finished:boolean;

begin
finished:= false;
repeat
erase_lines(1,1);
move_cursor(1,1);
write('Enter test and time of incorrect data, e.g. BS <cr> 30 <cr> ');
1: strtest:= input_data(65,1,4,true,0.0,0.0);
    if strtest[1] = chr(27) then
        begin
        finished:= true;
        goto 2;
        end;
    strtest:= ucase(strtest);
    strtime:= input_data(75,1,4,true,0.0,0.0);

    for i:= 1 to 4 do
        begin
        xtime[i]:= strtime[i];
        xtest[i]:= strtest[i];
        end;
erase_lines(1,1);

time:= 255;
test:= 255;
matrix:= 1;
found:= false;
repeat
if xtest = y_axis_label[matrix] then
        begin
        found:= true;
        test:= matrix;
        end;
matrix:= matrix + 1;
until (found) or (matrix > 14);

matrix:= 1;
found:= false;
repeat
if xtime = x_axis_label[matrix] then
        begin
        found:= true;
        time:= matrix;
        end;
matrix:= matrix + 1;
until (found) or (matrix > 14);

if time = 255 then
    begin
    erase_lines(1,1);
    move_cursor(1,1);
write('You have entered an invalid time, please reenter test & time: ');
    goto 1;
    end;

if test = 255 then
    begin
    erase_lines(1,1);
    move_cursor(1,1);
write('You have entered an invalid test, please reenter test & time: ');
    goto 1;
    end;

if shift_over_x_axis_flag then shift:= 4 else shift:= 2;

prompt(test*5+shift,time+5,0,'     ',false);
strvalue:= input_data(test*5+shift,time+5,4,false,9999.0,0.0);
if strvalue = '-999' then
    data.values[time,test]:= -999.0 else
    data.values[time,test]:= strtoreal(strvalue);

2: until finished;
erase_lines(1,1);
values_calculation;
end;


procedure update_first_record (number_recs:integer);
begin
reset(filename,fin);
with data do
begin
    read(fin:1,data);
    calculate(number_recs);
    data.name:='                              ';{DEBUG}
    write(fin:1,data);
    end;
end;



procedure get_vital_statistics;
var
xname,xchartnumber,xheight,xweight,xage,xboneage,xheightage:$string80;
xmonth,xday,xyear:$string80;
correction,i:byte;
correct:boolean;
wrong,xsex:char;


procedure get_patient_data (entry:byte);  {this procedure internal to above}
begin
case entry of
1:    begin
    prompt(1,2,30,'{1} Name: ',false);
    xname:= input_data(10,2,30,true,0.0,0.0);
    xname:=ucase(xname);
    end;
2:    begin
    prompt(50,2,6,'{2} Chart Number: ',false);
    xchartnumber:= input_data(67,2,6,true,0.0,0.0);
    end;
3:    begin
    repeat
    move_cursor(1,4);
    write('{3} Sex (m/f) ');
    read(xsex);
    until xsex in ['m','f','M','F'];
    end;
4:    begin
    prompt(20,4,0,'{4} Height (cm): ',false);
    xheight:= input_data(41,4,5,false,200.0,0.0);
    end;
5:     begin
    prompt(50,4,0,'{5} Weight (kg): ',false);
    xweight:= input_data(71,4,5,false,300.0,0.0);
    end;
6:    begin
    prompt(1,6,0,'{6} Age (yr.mo): ',false);
    xage:= input_data(20,6,5,false,30.0,0.1);
    end;
7:    begin
    prompt(30,6,0,'{7} Bone Age (yr.mo): ',false);
    xboneage:= input_data(52,6,4,false,20.0,0.0);
    end;
8:    begin
    prompt(1,8,0,'{8} Height Age (yr.mo): ',false);
    xheightage:= input_data(25,8,4,false,20.0,0.0);
    end;
9:    begin
    prompt(1,10,2,'{9} date: ',false);
    prompt(13,10,0,'/',false);
    prompt(16,10,0,'/',false);
    xmonth:= input_data(10,10,2,true,0.0,0.0);
    xday:= input_data(14,10,2,true,0.0,0.0);
    xyear:= input_data(17,10,2,true,0.0,0.0);
    end;
end; {of case}
end; {of procedure}


begin
clear_screen;
writeln;
prompt(1,2,0,'{1} Name: ',false);
prompt(50,2,0,'{2} Chart Number: ',false);
prompt(1,4,0,'{3} Sex (m/f): ',false);
prompt(20,4,0,'{4} Height (cm):',false);
prompt(50,4,0,'{5} Weight (kg):',false);
prompt(1,6,0,'{6} Age (yr.mo):',false);
prompt(30,6,0,'{7} Bone Age (yr.mo):',false);
prompt(1,8,0,'{8} Height Age (yr.mo):',false);
prompt(1,10,0,'{9} date: ',false);
prompt(13,10,0,'/',false);
prompt(16,10,0,'/',false);

for i:= 1 to 9 do get_patient_data(i);
repeat
correct:= query(1,15,'Is information correct as entered? y/n');
if correct = false then
    begin
    repeat
    erase_lines(15,1);
    move_cursor(1,15);
    write('Enter number corresponding to incorrect data: ');
    keyin(wrong);
    correction:= ord(wrong) - 48;
    until correction in [1..9];
    erase_lines(15,1);
    get_patient_data(correction);
    end;
until correct;
with data do
begin
for i:= 1 to 30 do name[i]:= xname[i];
for i:= 1 to 6  do chart_number[i]:= xchartnumber[i];
if xsex in ['m','M'] then sex:= male else sex:= female;
height:= strtoreal(xheight);
weight:= strtoreal(xweight);
chronological_age:= strtoreal(xage);
bone_age:=strtoreal(xboneage);
height_age:=strtoreal(xheightage);
for i:= 1 to 2 do
    begin
    date.month[i]:=xmonth[i];
    date.day[i]:= xday[i];
    date.year[i]:= xyear[i];
    end;
{calc_percent_overweight_for_height;}
surface_area:=exp((0.425*ln(weight)) + (0.725*ln(height)) + 4.274);

        {S.A.= weight^.425 * height^.725 * 71.84  according to}
            {DuBois & DuBois Arch Int Med 17:863 (1916)}

percent_overweight_for_height:=0.0;
total_body_water:= -10.313 + 0.252*weight + 0.154*(height);
end; {of with data}

end; {of procedure}


procedure get_data(flag:byte);
label 1;
var
rec:integer;
esc,num:byte;

begin
reset(filename,fin);
if eof(fin) then create_first_record;
rec:= number_records(filename) + 1;
repeat
with data do
begin
pad:= defaultpad;

if flag > 0 then get_vital_statistics;

clear_screen;
writeln;
move_cursor(1,1);
if flag = 0 then write('   Enter NORMAL laboratory values: ') else
             write('   Enter patient''s laboratory values: ');
axis(0);
x:= 7;
y:= 6;
for results:= 1 to 14 do
    begin
        time:= 1;
        while (time < 15) do
        begin
        strvalue:= input_data(x,y,4,false,9999.0,0.0);
        case ord(strvalue[1]) of
        27:    begin
            for esc:= time to 14 do
                values[time,results]:= -999.0;
            time:= 15;
            end;
        else:  begin
            if strvalue = '-999' then
            values[time,results]:= -999.0 else
            values[time,results]:= strtoreal(strvalue);
            time:= time + 1;
            y:= y+ 1;
            end;
        end; {of case}
        end; {of while}
x:= x+ 5;
y:= 6;
end;

continue:= query(1,1,'Is information correct as entered? y/n ');
if continue = false then mistake(false);

values_calculation;
case flag of
0: write(fin:1,data);
else: write(fin:rec,data);
end;

if flag = 0 then continue:= false else
    continue:= query(1,1,'Do you wish to add another record? y/n ');
if continue then rec:= rec + 1;
end; {of with data}
until continue = false;
if flag > 0 then update_first_record(rec);
end;


procedure set_normal_values;
begin
get_data(0);
end;


procedure get_normal_values;
begin
reset(filename,fin);
read(fin:1,norms);
end;


procedure print_individual_test_results (desire_hardcopy:boolean);
label 1;
var
x,y:byte;
test,continue:char;
output:text;


procedure choose_test;
begin
    clear_screen;
    writeln;
    writeln('A-  BLOOD SUGAR');
    writeln('B-  INSULIN');
    writeln('C-  GROWTH HORMONE');
    writeln('D-  LH');
    writeln('E-  FSH');
    writeln('F-  CORTISOL');
    writeln('G-  PROLACTIN');
    writeln('H-  TSH');
    writeln('I-  TESTOSTERONE');
    writeln('J-  DS');
    writeln('K-  ACTH');
    writeln('L-  T4');
    writeln('M-  TBGI');
    writeln('N-  TT3');
    writeln('O-  display values for a different patient');
    writeln('P-  return to the menu');
    writeln;
    write('Please enter the letter corresponding to the test: ');
    repeat
    move_cursor(61,19);
    keyin(test);
    if (ord(test) > 96) and (ord(test) < 123) then
        test:= chr(ord(test)-32);
    write(test);
    until test in ['A'..'P'];
    results:= ord(test)-64;
    clear_screen;
end;

begin
reset(filename,fin);
if eof(fin) then
    begin
    error:= true;
    goto 1;
    end;
if desire_hardcopy then rewrite('lst:',output);

get_chart_number;
if normal_value_flag = false then get_normal_values;
choose_test;
while results < 16 do
begin

if results = 15 then
    begin
    get_chart_number;
    choose_test;
    end;
if desire_hardcopy = false then axis(3) else
    begin
    clear_screen;
write('Prepare printer, then enter any character to initiate printing.');
    keyin(continue);
    erase_lines(1,1);
    writeln;
    write('Now printing results.');
    end;
with data do
begin

if desire_hardcopy = false then
    begin
    move_cursor(20,3);
    write(y_axis_label[results]);
    end;
if desire_hardcopy then
    begin
    write(output,chr(12));
    for x:= 1 to 3 do writeln(output);
    if normal_value_flag then chart_number:= 'NORMAL';
    write(output,'chart number: ',chart_number, y_axis_label[results]:15);
    writeln(output);
    write(output,'PATIENT':20,'NORMAL (AVE)':22, 'DEVIATION':15);
    writeln(output);
    end;

y:= 6;
for time:= 1 to 18 do
 begin
    case desire_hardcopy of
false:    begin
    move_cursor(10,y);
    if (normal_value_flag) or (abs(values[time,results]) = 999.0) then
        write('    ') else
        write(values[time,results]:4:1);
    move_cursor(20,y);
    if (abs(norms.values[time,results]) = 999.0) then
        write('    ') else
        write(norms.values[time,results]:4:1);
    move_cursor(35,y);
    if (abs(values[time,results]) = 999.0) or (normal_value_flag) or
        (abs(norms.values[time,results]) = 999.0) then
        write('    ') else
    if values[time,results] < norms.values[time,results] then
        write('LOW') else
    if values[time,results] > norms.values[time,results] then
        write('HIGH') else write('     ');
    if y = 19 then y:= y + 2 else y:= y + 1;
    end;

true:    begin
    if time < 15 then write (output,x_axis_label[time]) else
    case time of
    15: write(output,'max ');
    16: write(output,'min ');
    17: write(output,'ave ');
    18: write(output,'peak');
    end;

    if (abs(values[time,results]) = 999.0) or (normal_value_flag) then
        write(output,' ':15) else
        write(output,values[time,results]:15:1);

    if (abs(norms.values[time,results]) = 999.0) then
        write(output,' ':15) else
        write(output,norms.values[time,results]:15:1);

    if (abs(values[time,results]) = 999.0) or (normal_value_flag) or
       (abs(norms.values[time,results]) = 999.0) then
        write(output,' ':15) else
        if values[time,results] < norms.values[time,results] then
        write(output,'LOW':15) else
    if values[time,results] > norms.values[time,results] then
        write(output,'HIGH':15) else write(output,' ':15);

writeln(output);
end;
end;

end; {of time}
move_cursor(1,1);
write('Enter any character to continue ');
keyin(continue);
choose_test;
end;
end;
1:
end;



procedure correction;
label 1;
var
i:integer;
ch:char;
continue:boolean;

begin
clear_screen;
reset(filename,fin);
if eof(fin) then
    begin
    move_cursor(1,10);
    writeln('File not found!');
    writeln('Enter any character to continue.');
    keyin(ch);
    goto 1;
    end;

continue:= true;
repeat
get_chart_number;
if error = false then
    begin
    display_values(normal_value_flag,true);
    mistake(true);
    write(fin:rec,data);
    end;
continue:= query(1,1,'Do you wish to correct another patient''s record? y/n ');
until continue = false;

1:
end;


procedure get_filename;
var
newfile:boolean;

begin
clear_screen;
writeln;
writeln('Enter name of patient data file as:      drive:name.extension ');
writeln;
writeln('Drive is either ''A'' or ''B''  .');
writeln('Name may be up to 14 letters.   ');
writeln('Extention may be up to 3 letters.');
move_cursor(10,10);
write('---->   ');
read(filename);

reset(filename,fin);
if eof(fin) then
    begin
    prompt(10,15,0,'A file by that name is NOT FOUND. ',false);
    newfile:= query(10,16,'Is this a new file?    y/n');
    if newfile then rewrite(filename,fin) else get_filename;
    end;
end;




procedure menu;
var
ch:char;

begin
error:= false;
clear_screen;
writeln;
writeln('Choose one of the following: ');
writeln;
writeln('1-  Establish or set the normal values');
writeln('2-  Add patient results to file');
writeln('3-  Display on terminal selected test results for a patient');
writeln('4-  Print selected test results for a patient');
writeln('5-  Display on terminal all results for a patient');
writeln('6-  Print all results for a patient');
writeln('7-  Correct selected values or results for a patient''s record');
writeln;
writeln('8-  CHANGE NAME OF PATIENT DATA FILE');
writeln('0-  EXIT program');
writeln;
write('Your selection please:  ');
repeat
move_cursor(25,15);
keyin(ch);
write(ch);
until ch in ['0'..'8'];
case ch of
'1': set_normal_value;
'2': get_data(1);
'3': print_individual_test_results(false);
'4': print_individual_test_results(true);
'5': print(false);
'6': print(true);
'7': correction;
'8': get_filename;
'0': terminate:= true;
end;

end;




{**************************** main program *****************************}

begin
initialize;
terminate:= false;
get_filename;
repeat
menu;
until terminate ;
end.