home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / sigmv071.ark / STATISTI.PAS < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  15KB  |  739 lines
  1.  
  2.  
  3.  
  4. program xstat;{$P+}
  5. {$c-,m-,f-}
  6. label 1;
  7. const
  8. defaultpad ='                                                           ';
  9.  
  10. type
  11. id = array[1..6] of char;
  12. calendar = array [1..2] of char;
  13. date_of_test = record
  14.         month:calendar;
  15.         day:calendar;
  16.         year:calendar
  17.         end;
  18. lab_data = record
  19.     name: array [1..30] of char;
  20.     chart_number:id;
  21.     date: date_of_test;  
  22.     sex:boolean;
  23.     weight: real;
  24.     height: real;
  25.     surface_area: real;
  26.     chronological_age: real;
  27.     bone_age: real;
  28.     height_age:real;
  29.     percent_overweight_for_height:real;
  30.     total_body_water: real;
  31.     values:array[1..18,1..14] of real;
  32.     pad:array[1..59] of char;
  33.     end;
  34.  
  35. xstatistical = array[1..20,1..14,1..18] of real;
  36.  
  37.  
  38. byte = 0..255;
  39. $string0 = string 0;
  40. $string255 = string 255;
  41. $string80 = string 80;
  42. $string14 = string 14;
  43. $string4 = string 4;
  44. f = file of lab_data;
  45. axis_label = array[1..4] of char;
  46.  
  47. var
  48. filename:$string14;
  49. norms,data:lab_data;
  50. num_values, peak_time,time,results,x,y,i:byte;
  51. fin:f;
  52. average,max,min,sum:real;
  53. hardcopy,normal_value_flag, error, terminate, continue,escape:boolean;
  54. rec:integer;
  55. strvalue:$string80;
  56. x_axis_label,y_axis_label: array[1..14] of axis_label;
  57. statistics:xstatistical;
  58. output:text;
  59.  
  60.  
  61.  
  62.  
  63.  
  64. {************************* init labels for axis *************************}
  65. procedure initialize;
  66. var
  67. i:byte;
  68. begin
  69. x_axis_label[1]:= '-30 ';
  70. x_axis_label[2]:= '-1  ';
  71. x_axis_label[3]:= '15  ';
  72. x_axis_label[4]:= '30  ';
  73. x_axis_label[5]:= '45  ';
  74. x_axis_label[6]:= '60  ';
  75. x_axis_label[7]:= '90  ';
  76. x_axis_label[8]:= '120 ';
  77. x_axis_label[9]:= '150 ';
  78. x_axis_label[10]:= '180 ';
  79. x_axis_label[11]:= '210 ';
  80. x_axis_label[12]:= '240 ';
  81. x_axis_label[13]:= '300 ';
  82. x_axis_label[14]:= '360 ';
  83.  
  84. y_axis_label[1]:= 'BS  ';
  85. y_axis_label[2]:= 'IRI ';
  86. y_axis_label[3]:= 'GH  ';
  87. y_axis_label[4]:= 'LH  ';
  88. y_axis_label[5]:= 'FSH ';
  89. y_axis_label[6]:= 'F   ';
  90. y_axis_label[7]:= 'PRL ';
  91. y_axis_label[8]:= 'TSH ';
  92. y_axis_label[9]:= 'T   ';
  93. y_axis_label[10]:= 'DS  ';
  94. y_axis_label[11]:= 'ACTH';
  95. y_axis_label[12]:= 'T4  ';
  96. y_axis_label[13]:= 'TBG ';
  97. y_axis_label[14]:= 'TT3 ';
  98.  
  99. end;
  100.  
  101.  
  102. procedure setlength (var x:$string0; y:integer);external;
  103. function length (x:$string255):integer; external;
  104. procedure keyin(var cix:char);external;
  105.  
  106.  
  107. procedure clear_screen;
  108. begin
  109. write (chr(27),'*',chr(0),chr(0),chr(0),chr(0));
  110. end;
  111.  
  112. procedure erase_lines(starting_line,number_of_lines:byte);
  113. const
  114. blanks = '                                        ';
  115. var
  116. i:byte;
  117.  
  118. begin
  119. for i:= 1 to number_of_lines do
  120.     begin
  121.     write(chr(27),'=',chr(starting_line + 31),chr(32),blanks,blanks);
  122.     starting_line:= starting_line + 1;
  123.     end;
  124. end;
  125.  
  126. procedure move_cursor(x,y:byte);
  127. begin
  128. write(chr(27),'=',chr(y+31),chr(x+31));
  129. end;
  130.  
  131. procedure prompt (x,y,length:byte; p:$string80;
  132.               protected_field_desired:boolean);
  133.  
  134. var
  135. underline:string 80;
  136. i:byte;
  137. begin
  138. setlength(underline,0);
  139. for i:= 1 to length do append (underline,'_');
  140. if protected_field_desired = false then
  141.     write(chr(27),'=',chr(y+31),chr(x+31),p,underline)
  142.     else
  143.     write(chr(27),'=',chr(y+31),chr(x+31),chr(27),')',p,
  144.         underline,chr(27),'(');
  145. end;
  146.  
  147.  
  148. function query(x,y:byte; message:$string80):boolean;  {ask y/n question}
  149. var 
  150. answer:char;
  151. begin
  152. repeat
  153. move_cursor(x,y);
  154. write(message);
  155. keyin(answer);
  156. until answer in ['y','n','Y','N'];
  157. query:= ((answer = 'y') or (answer = 'Y'));
  158. erase_lines(y,1);
  159. end;
  160.  
  161.  
  162.  
  163.  
  164.  
  165. function number_records(filenam:$string14):integer;
  166. label 1;
  167. var
  168. num:integer;
  169. i:byte;
  170.  
  171. begin
  172. num:= 0;
  173. reset (filename,fin);
  174. if eof(fin) then
  175.     begin
  176.     num:= 1;
  177.     goto 1;
  178.     end;
  179. with data do
  180. begin
  181. read(fin:1,data);
  182. for i:= 1 to 6 do num:= num*10 + ord(chart_number[i])-48;
  183. end;
  184. 1: number_records:= num;
  185. end;
  186.  
  187. procedure init_statistical_array;
  188. begin
  189. clear_screen;
  190. writeln;
  191. writeln('Initializing and loading values into matrix. One moment,  please.');
  192. for rec:= 1 to 20 do
  193.     for results:= 1 to 14 do
  194.         for time:= 1 to 18 do
  195.             statistics[rec,results,time]:= -999.0;
  196. end;
  197.  
  198.  
  199. procedure axis;
  200. var
  201. i:byte;
  202.  
  203. begin
  204. writeln; {DEBUG delay...terminal does not seem to respond fast enough}
  205. for i:= 6 to 19 do
  206.     begin
  207.     move_cursor(1,i-1);
  208.     write(x_axis_label[i-5]:4);
  209.     end;
  210.  
  211. move_cursor(9,4);
  212. for i:= 1 to 14 do
  213.     write(y_axis_label[i]:4,' ');
  214. end;
  215.  
  216. procedure display_values;
  217. var
  218. x,y,i:byte;
  219. continue:char;
  220.  
  221. begin
  222. clear_screen;
  223. escape:=false;
  224. with data do
  225. begin
  226. writeln('      '); {DEBUG for terminal delay}
  227. axis;
  228. move_cursor(1,1);
  229. write('name: ',name:30,'chart #: ':10,data.chart_number:6,
  230.         'date: ':8,date.month:2,'/',date.day:2,'/',date.year:2);
  231. if sex then writeln('sex: male') else writeln('sex: female');
  232. write('ht: ',height:5:1,'wt: ':6,weight:5:1,
  233.     'S.A.:':5,surface_area:5:1);
  234. writeln('% OWt: ':8,percent_overweight_for_height:5:1,
  235.         'T.B.W.: ':10,total_body_water:5:1);
  236. writeln('age:':5,chronological_age:5:1,'B.A.: ':8,bone_age:5:1,
  237.     'H.A.: ':8,height_age:5:1);
  238.  
  239.  
  240.  
  241. x:= 7;
  242. y:= 5;
  243. for time:= 1 to 14 do
  244.     begin
  245.     for results:= 1 to 14 do
  246.         begin
  247.         move_cursor(x,y);
  248.         if abs(values[time,results]) <> 999.0 then
  249.             write(values[time,results]:4:1)  else
  250.             write('    '); {4 spaces}
  251.         x:= x + 5;
  252.         end;
  253.     y:= y + 1;
  254.     x:= 7;
  255.     end;
  256.  
  257. end; {of with data}
  258. end;
  259.  
  260.  
  261.  
  262. procedure values_calculation;
  263. var
  264. num:byte;
  265.  
  266.  
  267. begin
  268. with data do 
  269. begin
  270.  
  271. for results:= 1 to 14 do
  272. begin
  273. max:= values[1,results];
  274. peak_time:= 1;
  275.  
  276. if values[1,results] = -999.0 then
  277.     begin
  278.     sum:= 0.0;
  279.     num_values:= 0;
  280.     min:=999.0;
  281.     end;
  282.  
  283. if values[1,results] > -999.0 then
  284.     begin
  285.     sum:= values[1,results] ;
  286.     num_values:= 1;
  287.     min:= values[1,results];
  288.     end;
  289.  
  290.     for time := 2 to 14 do
  291.     begin
  292.     if max < values[time,results] then
  293.         begin
  294.         max:= values[time,results];
  295.         peak_time:= time;
  296.         end;
  297.     
  298.     if (values[time,results] > -999.0) and (min > values[time,results])
  299.                 then min:= values[time,results];
  300.  
  301.     if values[time,results] > -999.0 then
  302.             begin
  303.             sum:= sum + values[time,results] ;
  304.             num_values:= num_values + 1;
  305.             end;
  306.     end;
  307.  
  308. average:= sum/num_values;
  309. values[15,results]:= max;
  310. values[16,results]:= min;
  311. if average = 0.0 then values[17,results]:= -999.0 else
  312.               values[17,results]:= average;
  313.  
  314. case peak_time of 
  315. 1: values[18,results]:= -30.0;
  316. 2: values[18,results]:= -1.0;
  317. 3: values[18,results]:= 15.0;
  318. 4: values[18,results]:= 30.0;
  319. 5: values[18,results]:= 45.0;
  320. 6: values[18,results]:= 60.0;
  321. 7: values[18,results]:= 90.0;
  322. 8: values[18,results]:= 120.0;
  323. 9: values[18,results]:= 150.0;
  324. 10: values[18,results]:= 180.0;
  325. 11: values[18,results]:= 210.0;
  326. 12: values[18,results]:= 240.0;
  327. 13: values[18,results]:= 300.0;
  328. 14: values[18,results]:= 360.0;
  329. end;
  330.  
  331. if average = 0.0 then values[18,results]:= -999.0;
  332. end;
  333. end;
  334. end;
  335.  
  336.  
  337.  
  338. procedure mistake;
  339. label 1,2;
  340. var
  341. strtime,strtest:$string80;
  342. xtime,xtest: axis_label;
  343. matrix,i,ii,j,time,test:byte;
  344. found,finished:boolean;
  345.  
  346. begin
  347. finished:= false;
  348. repeat
  349. 1: erase_lines(1,1);
  350. move_cursor(1,1);
  351. write('Enter test and time of incorrect data, e.g. BS <cr> 30 <cr> ');
  352. move_cursor(65,1);
  353. i:=0;
  354.     repeat
  355.     i:= i + 1;
  356.     keyin(xtest[i]);
  357.     write(xtest[i]);
  358.     until (xtest[i] = chr(13)) or (i = 4);
  359.     if xtest[i] = chr(13) then
  360.         for ii:= i to 4 do xtest[ii]:= ' ';
  361.  
  362.     if xtest[1] = chr(27) then
  363.         begin
  364.         finished:= true;
  365.         goto 2;
  366.         end;
  367.  
  368. move_cursor(75,1);
  369. i:= 0;
  370.         repeat
  371.     i:= i + 1;
  372.     keyin(xtime[i]);
  373.     write(xtime[i]);
  374.     until (xtime[i] = chr(13)) or (i = 4);
  375.     if xtime[i] = chr(13) then
  376.         for ii:= i to 4 do xtime[ii]:= ' ';
  377.  
  378. erase_lines(1,1);
  379.  
  380. time:= 255;
  381. test:= 255;
  382. matrix:= 1;
  383. found:= false;
  384. repeat
  385. if xtime = x_axis_label[matrix] then
  386.         begin
  387.         found:= true;
  388.         time:= matrix;
  389.         end;
  390. matrix:= matrix + 1;
  391. until (found) or (matrix > 14);
  392. matrix:= 1;
  393. found:= false;
  394. repeat
  395. if xtest = y_axis_label[matrix] then
  396.         begin
  397.         found:= true;
  398.         test:= matrix;
  399.         end;
  400. matrix:= matrix + 1;
  401. until (found) or (matrix > 14);
  402.  
  403. if time = 255 then
  404.     begin
  405.     erase_lines(1,1);
  406.     move_cursor(1,1);
  407. write('You have entered an invalid time, please reenter test & time: ');
  408.     goto 1;
  409.     end;
  410.  
  411. if test = 255 then
  412.     begin
  413.     erase_lines(1,1);
  414.     move_cursor(1,1);
  415. write('You have entered an invalid test, please reenter test & time: ');
  416.     goto 1;
  417.     end;
  418.  
  419. prompt(test*5+4,time+2,0,'omit',false);
  420. data.values[time,test]:= -999.0;
  421.  
  422. 2: until finished;
  423. erase_lines(1,1);
  424. values_calculation;
  425. end;
  426.  
  427.  
  428.  
  429. procedure choose_and_exclude_test;
  430. var
  431. test:char;
  432.  
  433. begin
  434.     clear_screen;
  435.     writeln;
  436.     writeln('A-  BLOOD SUGAR');
  437.     writeln('B-  INSULIN');
  438.     writeln('C-  GROWTH HORMONE');
  439.     writeln('D-  LH');
  440.     writeln('E-  FSH');
  441.     writeln('F-  CORTISOL');
  442.     writeln('G-  PROLACTIN');
  443.     writeln('H-  TSH');
  444.     writeln('I-  TESTOSTERONE');
  445.     writeln('J-  DS');
  446.     writeln('K-  ACTH');
  447.     writeln('L-  T4');
  448.     writeln('M-  TBGI');
  449.     writeln('N-  TT3');
  450.     writeln('O-  finished excluding tests');
  451.     writeln;
  452.     write('Please enter the letter corresponding to the test: ');
  453. repeat
  454.     repeat
  455.     move_cursor(61,19);
  456.     keyin(test);
  457.     if (ord(test) > 96) and (ord(test) < 123) then
  458.         test:= chr(ord(test)-32);
  459.     write(test);
  460.     until test in ['A'..'O'];
  461.     results:= ord(test)-64;
  462.     if results < 15 then
  463.         begin
  464. writeln;
  465. write('Values for ',y_axis_label[results],' will be ignored during analysis.');
  466.     for time:= 1 to 18 do
  467.     data.values[time,results]:= -999.0
  468.     end;
  469. until results = 15;
  470. end;
  471.  
  472. procedure offer_hardcopy;
  473. var
  474. ch:char;
  475.  
  476. begin
  477. clear_screen;
  478. repeat
  479. move_cursor(1,5);
  480. write('Do you want a hardcopy of the data? y/n  ');
  481. keyin(ch);
  482. until ch in ['y','n','Y','N'];
  483. if ch in ['y','Y'] then hardcopy:= true else hardcopy:= false;
  484. clear_screen;
  485. if hardcopy = false then rewrite('con:',output) else 
  486.     begin
  487.     rewrite('lst:',output);
  488. writeln('Prepare printer, then enter any character to initiate printing.');
  489.     keyin(ch);
  490.     end;
  491. end;
  492.  
  493.  
  494. procedure load_statistical_array;
  495. label 1;
  496. var
  497. continue:char;
  498. last_record:integer;
  499. exclude:boolean;
  500.  
  501. procedure select_data;
  502. label 1;
  503. var
  504. exclusion:char;
  505.  
  506. begin
  507.     display_values;
  508.     move_cursor(1,19);
  509. writeln('Considering this patient''s lab results, choose one: ');
  510. writeln('1-  Accept all data as displayed for statistical analysis.');
  511. writeln('2-  Exclude all values for 1 or more test(s) from analysis.');
  512. writeln('3-  Exclude only one or more value(s) from statistical analysis.');
  513. writeln('4-  Exclude patient''s entire lab values from analysis.');
  514. repeat
  515. move_cursor(55,19);
  516. keyin(exclusion);
  517. until exclusion in ['0'..'4'];
  518. erase_lines(19,5);
  519. exclude:=false;
  520. case exclusion of
  521. '1': goto 1;
  522. '2': choose_and_exclude_test;
  523. '3': mistake;
  524. '4': exclude:= true;
  525. end;
  526.  
  527. 1:
  528. end; {of procedure}
  529.  
  530.  
  531. procedure print_raw_data;
  532. var
  533. stop,start:integer;
  534. i:byte;
  535. ch:char;
  536.  
  537. begin
  538. for results:= 1 to 14 do
  539. begin
  540. start:= 2;
  541.     repeat
  542.     if (start + 7) > last_record then stop:= last_record else
  543.                       stop:= start + 7;
  544.     if hardcopy then write(output,chr(12)) else
  545.         begin
  546.         erase_lines(1,1);
  547.         move_cursor(1,1);
  548.         write('Enter any character to continue. ');
  549.         keyin(ch);  
  550.         clear_screen;
  551.         end;
  552. for i:= 1 to 3 do writeln(output);
  553.  
  554. writeln(output,'RAW DATA FOR TEST    :',y_axis_label[results]:4);
  555. writeln(output);
  556. write(output,'   ');
  557. for i:= start to stop do write(output,'#':5,i:2);
  558. writeln(output);
  559. for time:= 1 to 18 do
  560.     begin
  561.     if time < 15 then write(output,x_axis_label[time]:4) else
  562.     case time of
  563.     15: write(output,'max ');
  564.     16: write(output,'min ');
  565.     17: write(output,'ave ');
  566.     18: write(output,'peak');
  567.     end;
  568.  
  569. for rec:= start to stop do
  570.     if abs(statistics[rec,results,time]) <> 999.0 then
  571.     write(output,statistics[rec,results,time]:7:1) else
  572.     write(output,' ':7);
  573.     writeln(output);
  574.     end;
  575. start:= start + 8;
  576. until start > last_record;
  577.  
  578. end;
  579. end;
  580.  
  581.  
  582. begin
  583. reset(filename,fin);
  584. if eof(fin) then
  585.     begin
  586.     clear_screen;
  587.     writeln('FILE NOT FOUND!');
  588.     writeln;
  589.     writeln('Enter any character to continue. ');
  590.     keyin(continue);
  591.     goto 1;
  592.     end;
  593. last_record:= number_records(filename);
  594. with data do
  595. begin
  596. for rec:= 2 to last_record do
  597.     begin
  598.     read(fin:rec,data);
  599.     select_data;
  600.     for results:= 1 to 14 do
  601.         for time:= 1 to 18 do
  602.         if exclude = true then statistics[rec,results,time]:=-999.0
  603.         else statistics[rec,results,time]:= values[time,results];
  604.     end;
  605. offer_hardcopy;
  606. print_raw_data;
  607. end;
  608. 1:
  609. end; {of procedure}
  610.  
  611.  
  612. procedure stat_average;
  613. var
  614. standard_deviation,max,min,average,sum:real;
  615. last_record,counter:integer;
  616. i:byte;
  617. ch:char;
  618.  
  619.  
  620. procedure calc_variance;
  621. var
  622. i:byte;
  623. variance,xvariance:real;
  624.  
  625. begin
  626. xvariance:=0.0;
  627. for i:= 2 to last_record do
  628. if abs(statistics[i,results,time]) <> 999.0 then
  629.     xvariance:=xvariance + sqr(statistics[i,results,time]-average);
  630. variance:=xvariance/(counter-1);
  631. standard_deviation:= sqrt(variance);
  632. end;
  633.  
  634. begin
  635. clear_screen;
  636. offer_hardcopy;
  637. last_record:= number_records(filename);
  638. writeln;
  639. if hardcopy then writeln('Now printing.');
  640. for results:= 1 to 14 do
  641.     begin
  642.     if hardcopy then write(output,chr(12)) else
  643.     begin
  644.     erase_lines(1,1);
  645.     move_cursor(1,1);
  646.     write('Enter any character to continue. ');
  647.     keyin(ch);
  648.     clear_screen;
  649.     end;
  650. for i:= 1 to 3 do writeln(output);
  651.  
  652. writeln(output,'STATISTICAL ANALYSIS FOR TEST   : ',y_axis_label[results]);
  653. writeln(output);
  654. writeln(output,'ave':9,'n':5,'s.d.':7,'max':6,'min':7);   
  655. writeln(output);
  656.  
  657. for time:= 1 to 18 do
  658. begin
  659. sum:= 0.0;
  660. counter:= 0;
  661. max:= statistics[1,results,1];
  662. if statistics[1,results,1] = -999.0 then
  663.     min:= 999.0 else min:= statistics[1,results,1];
  664.     
  665. if time < 15 then write(output,x_axis_label[time]:4) else
  666.     case time of 
  667.     15: write(output,'max ');
  668.     16: write(output,'min ');
  669.     17: write(output,'ave ');
  670.     18: write(output,'peak');
  671.     end;
  672. for rec:= 2 to last_record do
  673.     begin
  674.     if abs(statistics[rec,results,time]) <> 999.0 then
  675.         begin
  676.         sum:= sum + statistics[rec,results,time];
  677.         counter:= counter + 1;
  678.         if statistics[rec,results,time] > max then
  679.           max:= statistics[rec,results,time];
  680.          if statistics[rec,results,time] < min then
  681.           min:= statistics[rec,results,time];
  682.         end;
  683.     end;
  684.  
  685. average:= sum/counter;
  686. if (average = 0.0) or (abs(average) = 999.0) then
  687.     write(output,' ':18) else
  688.         begin
  689.         calc_variance;
  690.         write(output,average:7:1);
  691.         write(output,counter:4,standard_deviation:7:1);
  692.         end;
  693.  
  694. if abs(max) <> 999.0 then write(output,max:7:1) else
  695.               write(output,' ':7);
  696. if abs(min) <> 999.0 then write(output,min:7:1) else
  697.                   write(output,' ':7);
  698. writeln(output);
  699.  
  700. if hardcopy then writeln(output);    
  701. end;
  702. end;
  703. end;
  704.  
  705.  
  706. procedure get_filename;
  707. var
  708. newfile:boolean;
  709.  
  710. begin
  711. clear_screen;
  712. writeln;
  713. writeln('Enter name of patient data file as:      drive:name.extension ');
  714. writeln;
  715. writeln('Drive is either ''A'' or ''B''  .');
  716. writeln('Name may be up to 14 letters.   ');
  717. writeln('Extention may be up to 3 letters.');
  718. move_cursor(10,10);
  719. write('---->   ');
  720. read(filename);
  721.  
  722. reset(filename,fin);
  723. if eof(fin) then
  724.     begin
  725.     prompt(10,15,0,'A file by that name is NOT FOUND. ',false);
  726.     newfile:= query(10,16,'Is this a new file?    y/n');
  727.     if newfile then rewrite(filename,fin) else get_filename;
  728.     end;
  729. end;
  730.  
  731. {*************************** main program *******************************}
  732. begin
  733. get_filename;
  734. initialize;
  735. init_statistical_array;
  736. load_statistical_array;
  737. stat_average;
  738. end.
  739.