home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol028 / recmake.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  8KB  |  342 lines
  1.  
  2.  
  3.  {Program to create the patient records used by DISKBILL.  Copyright
  4.  1980 by Richard Yensen, Ph.D., 2403 Talbot Rd., Baltimore, MD 21216.
  5.  Distribution for profit is prohibited.}
  6.  
  7.  (*$G+*)
  8.  PROGRAM RECMAKE;
  9.  TYPE
  10.  PATIENT=RECORD
  11.  NAME:STRING[32];
  12.  STREET,KEY:STRING[40];
  13.  CITYSTATE:STRING[40];
  14.  RATE:REAL;
  15.  RECEIVE, PERCENT:REAL;
  16.  CUT:BOOLEAN;
  17.  HARTMAN:ARRAY[1..2] OF ARRAY[1..18] OF INTEGER;
  18.  DIAGNOSIS:STRING[40];
  19.  SYMPTOMS:STRING[8];
  20.  INSURANCECO:STRING[40];
  21.  ACCTNUMBER:STRING[15];
  22.   SOCSECNUMBER:STRING[10];
  23.  EMPLOYER:STRING[40];
  24.  WKSTREET:STRING[40];
  25.  WKCTYSTATE:STRING[40];
  26.  FIRSTVISIT:STRING[8];
  27.  LASTVISIT:STRING[8];
  28.  BIRTHDATE:STRING[8];
  29.  WORKPHONE:STRING[12];
  30.  HOMEPHONE:STRING[12]
  31.  END;
  32.  VAR
  33.  RECNUM:INTEGER;
  34.  BUF:PATIENT;
  35.  TITLE:STRING;
  36.  FID:FILE OF PATIENT;
  37.  
  38.  PROCEDURE WIPESCREEN;
  39.  BEGIN
  40.  WRITE(CHR(26));
  41.  END;
  42.  
  43.  PROCEDURE PUTREAL(D:REAL);
  44.  VAR I:INTEGER;
  45.      B:INTEGER;
  46.  BEGIN
  47.  B:=ABS(ROUND((D-TRUNC(D))*100));
  48.  IF B<10 THEN 
  49.  BEGIN
  50.                      WRITE(TRUNC(D):3,'.0',B)
  51.  END
  52.  ELSE  (*  B>=10  *)
  53.  BEGIN
  54.  IF D>=1.0 THEN 
  55.  BEGIN
  56.  WRITE(TRUNC(D):3,'.',B) 
  57.  END;
  58.  IF D<1 THEN
  59.  BEGIN
  60.  I:=ROUND(D*100); 
  61.  IF I>0 THEN (*  D is positive  *) 
  62.  BEGIN 
  63.  WRITE('  0.',B);
  64.  END;
  65.  IF I<0 THEN   (*  D is negative  *) 
  66.  BEGIN
  67.  WRITE(' -0.');
  68.  IF B<10 THEN WRITE('0',B)
  69.  ELSE WRITE(B);
  70.  END;
  71.  IF I=0 THEN WRITE('  0   ');
  72.  END; 
  73.  END  (*  D>=1.0  *);
  74.  WRITELN;
  75.  END  (*  PUTREAL  *);
  76.  
  77.  
  78.  PROCEDURE ZEROREC(VAR REC:PATIENT);
  79.  VAR  SECTION, RATING : INTEGER;
  80.  BEGIN
  81.  WITH REC DO
  82.  BEGIN
  83.  NAME:='';
  84.  STREET:='';
  85.  CITYSTATE:='';
  86.  RECEIVE:=0;
  87.  RATE:=0;
  88.  CUT:=FALSE;
  89.  PERCENT:=0;
  90.  KEY:='';
  91.  INSURANCECO:='';
  92.  DIAGNOSIS:='';
  93.  SYMPTOMS:='';
  94.  ACCTNUMBER:='';
  95.  SOCSECNUMBER:='';
  96.  EMPLOYER:='';
  97.  WKSTREET:='';
  98.  WKCTYSTATE:='';
  99.  FIRSTVISIT:='';
  100.  LASTVISIT:='';
  101.  BIRTHDATE:='';
  102.  WORKPHONE:='';
  103.  HOMEPHONE:='';
  104.  FOR SECTION:=1 TO 2 DO
  105.  BEGIN
  106.  FOR RATING:=1 TO 18 DO
  107.  BEGIN
  108.    HARTMAN[SECTION,RATING]:=0;
  109.  END;
  110.  END;
  111.  END;
  112.                END(*  ZEROREC  *);
  113.  
  114.  PROCEDURE LASTHALFOFRECORD(REC:PATIENT);
  115.  BEGIN
  116.  WITH REC DO
  117.  BEGIN
  118.  WRITELN('Key to sort:              ',KEY);
  119.  WRITELN('Diagnosis:                ',DIAGNOSIS);
  120.  WRITELN('Date of First Symptoms:   ',SYMPTOMS);
  121.  WRITELN('Insurance Company:        ',INSURANCECO);
  122.  WRITELN('Account Number:           ',ACCTNUMBER);
  123.  WRITELN('Social Security #:        ',SOCSECNUMBER);
  124.  WRITELN('Employer:                 ',EMPLOYER);
  125.  WRITELN('  Address:                ',WKSTREET);
  126.  WRITELN('  City   State:           ',WKCTYSTATE);
  127.  WRITELN('  Telephone:              ',WORKPHONE);
  128.  WRITELN('Birthdate:                ',BIRTHDATE);
  129.  WRITELN('First Visit:              ',FIRSTVISIT);
  130.  WRITELN('Last Visit:               ',LASTVISIT);
  131.  WRITELN('Home Telephone:           ',HOMEPHONE);
  132.  END;
  133.  END;(*  LASTHALFOFRECORD  *)
  134.  
  135.  PROCEDURE SHOWREC(REC:PATIENT);
  136.  VAR ANSWER:CHAR;
  137.  BEGIN
  138.  WITH REC DO
  139.  BEGIN
  140.  WRITELN('Name:                     ',NAME);
  141.                                             WRITELN('Street:                   ',STREET);
  142.  WRITELN('City   State:             ',CITYSTATE);
  143.  WRITE('Hourly Rate:              $');PUTREAL(RATE);WRITELN;
  144.  WRITE('Paid Each Visit In Cash:  $');PUTREAL(RECEIVE);WRITELN;
  145.  WRITE('Professional Discount:    ');
  146.  IF CUT THEN
  147.  BEGIN
  148.  WRITELN('Yes');
  149.  WRITE('              Amount:     ');WRITELN (TRUNC(100*PERCENT),'%');
  150.  END
  151.   ELSE WRITELN('No');
  152.  LASTHALFOFRECORD(FID^);
  153.  WRITELN('<<<<<<< Press Any Character to Begin Entering Corrections >>>>>>>>');
  154.  READ(ANSWER);
  155.  END; 
  156.  END; (*SHOWREC*)
  157.  
  158.  
  159.  PROCEDURE GETREC(VAR REC:PATIENT);
  160.  LABEL 1;
  161.  VAR ANSWER:CHAR;
  162.  S:STRING;
  163.  R:REAL;
  164.  Q:INTEGER;
  165.  
  166.  FUNCTION READSTRING(VAR T:STRING):BOOLEAN;
  167.  BEGIN
  168.  WRITE('                               <esc> Return to skip record'); 
  169.  FOR Q:=1 TO 60 DO
  170.  BEGIN
  171.  WRITE(CHR(8));
  172.  END;
  173.  READLN(S);
  174.  READSTRING:=FALSE;
  175.  IF LENGTH(S)>0 THEN
  176.  IF S[LENGTH(S)]=CHR(27(*  ESC  *)) THEN READSTRING:=TRUE
  177.  ELSE
  178.  T:=S;
  179.  END;(*  READSTRING  *)
  180.  
  181.                         FUNCTION READBOOL(VAR T:BOOLEAN):BOOLEAN;
  182.  BEGIN
  183.  READLN(S);
  184.  READBOOL:=FALSE;
  185.  IF LENGTH(S)>0 THEN
  186.  IF S[LENGTH(S)]=CHR(27(*  ESC  *)) THEN READBOOL:=TRUE
  187.  ELSE
  188.  BEGIN
  189.  CASE S[1] OF
  190.  'F','f','N','n':T:=FALSE;
  191.  'T','t','Y','y':T:=TRUE
  192.  END
  193.  END;
  194.  END;(*  READBOOL  *)
  195.  
  196.  FUNCTION READREAL(VAR T:REAL): BOOLEAN;
  197.  BEGIN
  198.  WRITE('SKIP TO THE NEXT FIELD? <Yes or No>');
  199.  READ(ANSWER);
  200.  IF (ANSWER='N') OR (ANSWER='n') THEN
  201.  BEGIN
  202.  FOR Q :=1 TO 36 DO
  203.  BEGIN
  204.  WRITE(CHR(8));
  205.  END;
  206.  FOR Q :=1 TO 36 DO
  207.  BEGIN
  208.  WRITE(' ');
  209.  END;
  210.  FOR Q :=1 TO 36 DO
  211.  BEGIN
  212.  WRITE(CHR(8));
  213.  END;
  214.  WRITE('$             a minus entry will skip entire record');
  215.  FOR Q:=1 TO 50 DO
  216.  BEGIN
  217.  WRITE(CHR(8));
  218.  END;
  219.  READLN(R);
  220.  IF R<0 THEN READREAL:=TRUE
  221.  ELSE T:=R;
  222.  END;(*  IF ANSWER = N  *)
  223.  IF (ANSWER='Y')OR(ANSWER='y') THEN
  224.  WRITELN;
  225.  
  226.  END;
  227.  
  228.  FUNCTION READPCT(VAR T:REAL): BOOLEAN;
  229.  BEGIN
  230.  WRITE('SKIP TO THE NEXT FIELD? <Yes or No>');
  231.  READ(ANSWER);
  232.  IF (ANSWER='N') OR (ANSWER='n') THEN
  233.  BEGIN
  234.   FOR Q :=1 TO 36 DO
  235.  BEGIN
  236.  WRITE(CHR(8));
  237.  END;
  238.  FOR Q :=1 TO 36 DO
  239.  BEGIN
  240.  WRITE(' ');
  241.  END;
  242.  FOR Q :=1 TO 36 DO
  243.  BEGIN
  244.  WRITE(CHR(8));
  245.  END;
  246.  WRITE('  %          a minus entry will skip entire record');
  247.  FOR Q:=1 TO 50 DO
  248.  BEGIN
  249.  WRITE(CHR(8));
  250.  END;
  251.  READLN(R);
  252.  IF R<0 THEN READPCT:=TRUE
  253.  ELSE T:=R/100;
  254.  END;(*  IF ANSWER = N  *)
  255.  IF (ANSWER='Y')OR(ANSWER='y') THEN
  256.  WRITELN;
  257.  
  258.  END;
  259.  
  260.  BEGIN(*  GETREC  *)
  261.  WRITELN('Entering a return will skip to next item without changing the present item');
  262.    WRITELN;
  263.  WITH REC DO
  264.  BEGIN
  265.  WRITE('Name:                 ');IF READSTRING(NAME) THEN GOTO 1;
  266.  WRITE('Street:               ');IF READSTRING(STREET) THEN GOTO 1;
  267.  WRITE('City   State:         ');IF READSTRING(CITYSTATE) THEN GOTO 1;
  268.  WRITE('Hourly Rate:          ');IF READREAL(RATE) THEN GOTO 1;
  269.  WRITE('Paid Each Session:    ');IF READREAL(RECEIVE) THEN GOTO 1;
  270.  WRITE('Professional Discount:');IF READBOOL(CUT) THEN GOTO 1;
  271.  IF CUT THEN
  272.  BEGIN
  273.                                   WRITE('              Percent:');IF READPCT(PERCENT) THEN GOTO 1;
  274.  END
  275.  ELSE PERCENT:=0;
  276.  WRITE('Key to Sort by:        ');IF READSTRING(KEY) THEN GOTO 1;
  277.  WRITE('Diagnosis:             ');IF READSTRING(DIAGNOSIS) THEN GOTO 1;
  278.  WRITE(' First Symptoms:       ');IF READSTRING(SYMPTOMS) THEN GOTO 1;
  279.  WRITE('Insurance Company:     ');IF READSTRING(INSURANCECO) THEN GOTO 1;
  280.  WRITE('Account Number:        ');IF READSTRING(ACCTNUMBER) THEN GOTO 1;
  281.  WRITE('Social Security #:     ');IF READSTRING(SOCSECNUMBER) THEN GOTO 1;
  282.  WRITE('Employer:              ');IF READSTRING(EMPLOYER) THEN GOTO 1;
  283.  WRITE('  Address:             ');IF READSTRING(WKSTREET) THEN GOTO 1;
  284.  WRITE('  City   State:        ');IF READSTRING(WKCTYSTATE) THEN GOTO 1;
  285.  WRITE('  Telephone:           ');IF READSTRING(WORKPHONE) THEN GOTO 1;
  286.  WRITE('Birthdate:             ');IF READSTRING(BIRTHDATE) THEN GOTO 1;
  287.  WRITE('First Visit:           ');IF READSTRING(FIRSTVISIT) THEN GOTO 1;
  288.                                                           WRITE('Last Visit:            ');IF READSTRING(LASTVISIT) THEN GOTO 1;
  289.  WRITE('Home Telephone:       ');IF READSTRING(HOMEPHONE) THEN GOTO 1;
  290.  END;
  291.  1:    
  292.  END;(*  GETREC  *)
  293.  
  294.  
  295.  BEGIN(*  MAIN PROGRAM  *)
  296.  WIPESCREEN;
  297.  WRITE('FILE TITLE:');
  298.  READLN(TITLE);
  299.  (*$I-*)
  300.  RESET(FID,TITLE);
  301.  IF IORESULT<>0 THEN 
  302.  BEGIN
  303.  WRITELN('I am opening a new file: ',TITLE,' because it is not on this disk');
  304.  REWRITE(FID,TITLE);
  305.  END;
  306.  (*$I+*)
  307.  RECNUM:=0;
  308.  WHILE RECNUM>=0 DO
  309.  BEGIN
  310.  WRITELN;
  311.  WRITE('RECORD NUMBER:');
  312.  READLN(RECNUM);
  313.  IF RECNUM>=0 THEN
  314.  BEGIN
  315.  SEEK(FID,RECNUM);
  316.  GET(FID);
  317.  IF EOF(FID) THEN
  318.  BEGIN
  319.  WIPESCREEN;
  320.  WRITELN('ENTER NEW RECORD:');
  321.  ZEROREC(FID^);
  322.  END
  323.  ELSE
  324.  BEGIN
  325.  WIPESCREEN;
  326.  WRITELN('OLD RECORD:');
  327.  SHOWREC(FID^);
  328.  WRITELN;
  329.  WRITELN('ENTER CHANGES:');
  330.  END;
  331.  GETREC(FID^);
  332.  SEEK(FID,RECNUM);
  333.  PUT(FID);
  334.  END; (*  IF RECNUM>=0  *)
  335.  END(*  WHILE  *);
  336.  CLOSE(FID,LOCK);
  337.  END.
  338.                                                                               *)
  339.  END(*  WHILE  *);
  340.  CLOSE(FID,LOCK);
  341.  END.
  342.