home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol028 / diskbill.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  19.1 KB  |  878 lines
  1.  
  2.  {Simpleminded billing program for professional services (clinical
  3.  psychology).  Written for ADM-3 CRT.  Copyright 1980 by Richard
  4.  Yensen, Ph.D., 2403 Talbot Rd., Baltimore, MD 21216.  Distribution for 
  5.  profit is prohibited.}
  6.  
  7.  (*$G+*)
  8.  PROGRAM DISKBILL;
  9.  TYPE
  10.  PATIENT=RECORD
  11.  
  12.  NAME:STRING[32];
  13.  STREET,KEY:STRING[40];
  14.  CITYSTATE:STRING[40];
  15.  RATE:REAL;
  16.  RECEIVE, PERCENT:REAL;
  17.  CUT:BOOLEAN;
  18.  HARTMAN:ARRAY[1..2] OF ARRAY[1..18] OF INTEGER;
  19.  DIAGNOSIS:STRING[40];
  20.  SYMPTOMS:STRING[8];
  21.  INSURANCECO:STRING[40];
  22.  ACCTNUMBER:STRING[15];
  23.  SOCSECNUMBER:STRING[10];
  24.  EMPLOYER:STRING[40];
  25.  WKSTREET:STRING[40];
  26.  WKCTYSTATE:STRING[40];
  27.  FIRSTVISIT:STRING[8];
  28.  LASTVISIT:STRING[8];
  29.  BIRTHDATE:STRING[8];
  30.  WORKPHONE:STRING[12];
  31.  HOMEPHONE:STRING[12]
  32.  END;
  33.  
  34.  VAR HANDLE:STRING[32];
  35.  RECNUM:INTEGER;
  36.  BUF:PATIENT;
  37.  TITLE:STRING;
  38.  FID:FILE OF PATIENT;
  39.  GOTCASH,TOTAL,AMT:REAL;
  40.  INDEX,DEFAULT:INTEGER;
  41.  ANSWER:CHAR;
  42.  DATE:ARRAY[1..26] OF STRING[9];
  43.  TIME:ARRAY[1..26] OF REAL;
  44.           SHOWTIME, FOUNDIT, KEEPGOING:BOOLEAN;
  45.  OUT:TEXT;
  46.  
  47.  PROCEDURE WIPESCREEN;
  48.  BEGIN
  49.  WRITE(CHR(26));
  50.  END;
  51.  
  52.  PROCEDURE SHALI;
  53.  BEGIN
  54.  WIPESCREEN;GOTOXY(12,12);
  55.  WRITELN('Shall we continue?  ');
  56.  READ(ANSWER);
  57.  IF (ANSWER='N') OR (ANSWER='n') THEN KEEPGOING:=FALSE;
  58.  END;
  59.  
  60.  PROCEDURE PROMPT;
  61.  BEGIN
  62.  WIPESCREEN;
  63.  GOTOXY(12,12);
  64.  WRITELN('This is a program to prepare bills.  Please enter the name of');
  65.  WRITELN('the person you would like to prepare a bill for:  ');
  66.  READLN(HANDLE);
  67.  END; (*  PROMPT  *)
  68.  
  69.  PROCEDURE SEARCH;
  70.  VAR ANSWER:CHAR;
  71.  BEGIN
  72.  FOUNDIT:=FALSE;
  73.  RECNUM:=0;
  74.  RESET(FID,'PATIENTS');
  75.  WHILE (NOT FOUNDIT) AND (NOT EOF(FID)) DO
  76.  BEGIN
  77.  WITH FID^ DO
  78.  BEGIN
  79.  IF HANDLE=NAME THEN FOUNDIT:=TRUE;
  80.  END;
  81.  IF NOT FOUNDIT THEN
  82.    BEGIN
  83.  RECNUM:=RECNUM+1;
  84.  SEEK(FID,RECNUM);
  85.  GET(FID);
  86.  END; (* IF NOT FOUNDIT *)
  87.  END; (* WHILE *)
  88.  IF (EOF(FID)) AND (NOT FOUNDIT) THEN 
  89.  BEGIN
  90.  WRITELN('Could not find ',HANDLE,' in the file');
  91.                                            WRITELN('Be sure you put in the full name.');
  92.  WRITELN('TYPE A "C" TO TRY AGAIN OR ANY OTHER CHARACTER TO STOP');
  93.  READ(ANSWER);
  94.  IF (ANSWER='C')OR(ANSWER='c')THEN
  95.  BEGIN
  96.  CLOSE(FID,LOCK);
  97.  PROMPT;
  98.  SEARCH;
  99.  END;
  100.  END;
  101.  END; (*  SEARCH  *)
  102.  
  103.   
  104.  PROCEDURE DODOTS(N:INTEGER)   {PRETTIES UP THE DISPLAY};
  105.  VAR I:INTEGER;
  106.  BEGIN
  107.  FOR I:=1 TO N DO
  108.  BEGIN
  109.  WRITE('-');
  110.  *END;
  111.  END   {DODOTS};
  112.  
  113.  PROCEDURE PUTREAL(D:REAL);
  114.  VAR I:INTEGER;
  115.      B:INTEGER;
  116.  BEGIN
  117.  B:=ABS(ROUND((D-TRUNC(D))*100));
  118.  IF B<10 THEN 
  119.  BEGIN
  120.  WRITE(TRUNC(D):3,'.0',B)
  121.  END
  122.  ELSE  {B>=10}
  123.  BEGIN
  124.  IF D>=1.0 THEN 
  125.  BEGIN
  126.  WRITE(TRUNC(D):3,'.',B) 
  127.  END;
  128.  IF D<1 THEN
  129.  BEGIN
  130.  I:=ROUND(D*100); 
  131.  IF I>0 THEN {D is positive} 
  132.  BEGIN 
  133.  WRITE('  0.',B);
  134.  END;
  135.  IF I<0 THEN   {D is negative} 
  136.  BEGIN
  137.  WRITE(' -0.');
  138.  IF B<10 THEN WRITE('0',B)
  139.  ELSE WRITE(B);
  140.  END;
  141.  IF I=0 THEN WRITE('  0   ');
  142.  END; 
  143.  END  {D>=1.0};
  144.  END  {PUTREAL};
  145.  
  146.  
  147.  PROCEDURE PUTIME(D:REAL);
  148.  VAR I:INTEGER;
  149.      B:INTEGER;
  150.        BEGIN
  151.  B:=ABS(ROUND((D-TRUNC(D))*100));
  152.  IF B<10 THEN 
  153.  BEGIN
  154.  WRITE(TRUNC(D):1,'.0',B)
  155.  END
  156.  ELSE  {B>=10}
  157.  BEGIN
  158.  IF D>=1.0 THEN 
  159.  BEGIN
  160.  WRITE(TRUNC(D):1,'.',B) 
  161.  END;
  162.  IF D<1 THEN
  163.  BEGIN
  164.  I:=ROUND(D*100); 
  165.  IF I>0 THEN {D is positive} 
  166.  BEGIN 
  167.  WRITE('  0.',B);
  168.  END;
  169.  IF I<0 THEN   {D is negative} 
  170.  BEGIN
  171.  WRITE(' -0.');
  172.  IF B<10 THEN WRITE('0',B)
  173.  ELSE WRITE(B);
  174.  END;
  175.  IF I=0 THEN WRITE('  0   ');
  176.  END; 
  177.  END  {D>=1.0};
  178.  END  {PUTIME};
  179.  
  180.  PROCEDURE PRINTAB(I:INTEGER);
  181.  VAR J:INTEGER;
  182.  BEGIN
  183.  FOR J:=1 TO I DO
  184.  BEGIN
  185.  WRITE(OUT,' ');
  186.  END;
  187.  END;
  188.  
  189.  PROCEDURE TAB(I:INTEGER);
  190.  VAR J:INTEGER;
  191.  BEGIN
  192.  FOR J:=1 TO I DO
  193.  BEGIN
  194.  WRITE(' ');
  195.  END;
  196.  END;
  197.  
  198.  PROCEDURE LASTHALFOFRECORD(REC:PATIENT);
  199.  BEGIN
  200.  WITH REC DO
  201.  BEGIN
  202.  WRITELN('Key to sort:              ',KEY);
  203.  WRITELN('Diagnosis:                ',DIAGNOSIS);
  204.  WRITELN('Date of First Symptoms:   ',SYMPTOMS);
  205.  WRITELN('Insurance Company:        ',INSURANCECO);
  206.                                              WRITELN('Account Number:           ',ACCTNUMBER);
  207.  WRITELN('Social Security #:        ',SOCSECNUMBER);
  208.  WRITELN('Employer:                 ',EMPLOYER);
  209.  WRITELN('  Address:                ',WKSTREET);
  210.  WRITELN('  City   State:           ',WKCTYSTATE);
  211.  WRITELN('  Telephone:              ',WORKPHONE);
  212.  WRITELN('Birthdate:                ',BIRTHDATE);
  213.  WRITELN('First Visit:              ',FIRSTVISIT);
  214.  WRITELN('Last Visit:               ',LASTVISIT);
  215.  WRITELN('Home Telephone:           ',HOMEPHONE);
  216.  END;
  217.  END;(*  LASTHALFOFRECORD  *)
  218.  
  219.  PROCEDURE SHOWREC(REC:PATIENT);
  220.  BEGIN
  221.  WRITELN;
  222.  WITH REC DO
  223.  BEGIN
  224.  WRITELN('Name:                     ',NAME);
  225.  WRITELN('Street:                   ',STREET);
  226.  WRITELN('City   State:             ',CITYSTATE);
  227.  WRITE('Hourly Rate:              $');PUTREAL(RATE);WRITELN;
  228.  WRITE('Paid Each Visit In Cash:  $');PUTREAL(RECEIVE);WRITELN;
  229.  WRITE('Professional Discount:    ');
  230.  IF CUT THEN
  231.  BEGIN
  232.  WRITELN('Yes');
  233.                                             WRITE('              Amount:     ');WRITELN (TRUNC(100*PERCENT),'%');
  234.  END
  235.  ELSE WRITELN('No');
  236.  LASTHALFOFRECORD(FID^);
  237.  END; 
  238.  END; (*SHOWREC*)
  239.  
  240.  
  241.  
  242.  PROCEDURE GETREC(VAR REC:PATIENT);
  243.  LABEL 1;
  244.  VAR ANSWER:CHAR;
  245.  S:STRING;
  246.  R:REAL;
  247.  Q:INTEGER;
  248.  
  249.  FUNCTION READSTRING(VAR T:STRING):BOOLEAN;
  250.  BEGIN
  251.  WRITE('                               <esc> Return to skip record'); 
  252.  FOR Q:=1 TO 60 DO
  253.  BEGIN
  254.  WRITE(CHR(8));
  255.  END;
  256.  READLN(S);
  257.  READSTRING:=FALSE;
  258.  IF LENGTH(S)>0 THEN
  259.  IF S[LENGTH(S)]=CHR(27(*  ESC  *)) THEN READSTRING:=TRUE
  260.  ELSE
  261.  T:=S;
  262.  END;(*  READSTRING  *)
  263.  
  264.  FUNCTION READBOOL(VAR T:BOOLEAN):BOOLEAN;
  265.  BEGIN
  266.  READLN(S);
  267.  READBOOL:=FALSE;
  268.  IF LENGTH(S)>0 THEN
  269.  IF S[LENGTH(S)]=CHR(27(*  ESC  *)) THEN READBOOL:=TRUE
  270.  ELSE
  271.  BEGIN
  272.  CASE S[1] OF
  273.  'F','f','N','n':T:=FALSE;
  274.  'T','t','Y','y':T:=TRUE
  275.  END
  276.  END;
  277.  END;(*  READBOOL  *)
  278.  
  279.  FUNCTION READREAL(VAR T:REAL): BOOLEAN;
  280.  BEGIN
  281.  WRITE('SKIP TO THE NEXT FIELD? <Yes or No>');
  282.  READ(ANSWER);
  283.                        IF (ANSWER='N') OR (ANSWER='n') THEN
  284.  BEGIN
  285.  FOR Q :=1 TO 36 DO
  286.  BEGIN
  287.  WRITE(CHR(8));
  288.  END;
  289.  FOR Q :=1 TO 36 DO
  290.  BEGIN
  291.  WRITE(' ');
  292.  END;
  293.  FOR Q :=1 TO 36 DO
  294.  BEGIN
  295.  WRITE(CHR(8));
  296.  END;
  297.  WRITE('$             a minus entry will skip entire record');
  298.  FOR Q:=1 TO 50 DO
  299.  BEGIN
  300.  WRITE(CHR(8));
  301.  END;
  302.  READLN(R);
  303.  IF R<0 THEN READREAL:=TRUE
  304.  ELSE T:=R;
  305.  END;(*  IF ANSWER = N  *)
  306.  IF (ANSWER='Y')OR(ANSWER='y') THEN
  307.  WRITELN;
  308.  
  309.  END;
  310.  
  311.  FUNCTION READPCT(VAR T:REAL): BOOLEAN;
  312.  BEGIN
  313.  WRITE('SKIP TO THE NEXT FIELD? <Yes or No>');
  314.  READ(ANSWER);
  315.  IF (ANSWER='N') OR (ANSWER='n') THEN
  316.  BEGIN
  317.  FOR Q :=1 TO 36 DO
  318.  BEGIN
  319.  WRITE(CHR(8));
  320.  END;
  321.  FOR Q :=1 TO 36 DO
  322.  BEGIN
  323.  WRITE(' ');
  324.  END;
  325.  FOR Q :=1 TO 36 DO
  326.  BEGIN
  327.  WRITE(CHR(8));
  328.  END;
  329.  WRITE('  %          a minus entry will skip entire record');
  330.  FOR Q:=1 TO 50 DO
  331.  BEGIN
  332.  WRITE(CHR(8));
  333.  END;
  334.  READLN(R);
  335.  IF R<0 THEN READPCT:=TRUE
  336.  ELSE T:=R/100;
  337.  END;(*  IF ANSWER = N  *)
  338.  IF (ANSWER='Y')OR(ANSWER='y') THEN
  339.         WRITELN;
  340.  
  341.  END;
  342.  
  343.  BEGIN(*  GETREC  *)
  344.  WRITELN('Entering a return will skip to next item without changing the present item');
  345.    WRITELN;
  346.  WITH REC DO
  347.  BEGIN
  348.  WRITE('Name:                 ');IF READSTRING(NAME) THEN GOTO 1;
  349.  WRITE('Street:               ');IF READSTRING(STREET) THEN GOTO 1;
  350.  WRITE('City   State:         ');IF READSTRING(CITYSTATE) THEN GOTO 1;
  351.  WRITE('Hourly Rate:          ');IF READREAL(RATE) THEN GOTO 1;
  352.  WRITE('Paid Each Session:    ');IF READREAL(RECEIVE) THEN GOTO 1;
  353.  %WRITE('Professional Discount:');IF READBOOL(CUT) THEN GOTO 1;
  354.  IF CUT THEN
  355.  BEGIN
  356.  WRITE('              Percent:');IF READPCT(PERCENT) THEN GOTO 1;
  357.  END
  358.  ELSE PERCENT:=0;
  359.  WRITE('Key to Sort by:        ');IF READSTRING(KEY) THEN GOTO 1;
  360.  WRITE('Diagnosis:             ');IF READSTRING(DIAGNOSIS) THEN GOTO 1;
  361.  WRITE('Date of First Symptoms:');IF READSTRING(SYMPTOMS) THEN GOTO 1;
  362.  WRITE('Insurance Company:     ');IF READSTRING(INSURANCECO) THEN GOTO 1;
  363.                                                  WRITE('Account Number:        ');IF READSTRING(ACCTNUMBER) THEN GOTO 1;
  364.  WRITE('Social Security #:     ');IF READSTRING(SOCSECNUMBER) THEN GOTO 1;
  365.  WRITE('Employer:              ');IF READSTRING(EMPLOYER) THEN GOTO 1;
  366.  WRITE('  Address:             ');IF READSTRING(WKSTREET) THEN GOTO 1;
  367.  WRITE('  City   State:        ');IF READSTRING(WKCTYSTATE) THEN GOTO 1;
  368.  WRITE('  Telephone:           ');IF READSTRING(WORKPHONE) THEN GOTO 1;
  369.  WRITE('Birthdate:             ');IF READSTRING(BIRTHDATE) THEN GOTO 1;
  370.  WRITE('First Visit:           ');IF READSTRING(FIRSTVISIT) THEN GOTO 1;
  371.  WRITE('Last Visit:            ');IF READSTRING(LASTVISIT) THEN GOTO 1;
  372.  WRITE('Home Telephone:       ');IF READSTRING(HOMEPHONE) THEN GOTO 1;
  373.  END;
  374.  1:    
  375.  END;(*  GETREC  *)
  376.  
  377. PROCEDURE DIDNTPAY(VAR REC:PATIENT);
  378.  VAR ANSWER:CHAR;
  379.  CASH:REAL;
  380.  BEGIN
  381.  WITH REC DO
  382.  REPEAT
  383.  GOTCASH:=0;
  384.  IF (RECEIVE>0)  THEN
  385.   REPEAT
  386.  WIPESCREEN;GOTOXY(12,12);
  387.  WRITE('Enter number of times ', NAME ,' did not pay $');
  388.                   PUTREAL(RECEIVE);
  389.  WRITELN;
  390.  READLN(DEFAULT);
  391.  GOTCASH:=RECEIVE*(INDEX-DEFAULT);
  392.  WIPESCREEN;GOTOXY(12,12);
  393.  WRITE('If ',NAME,' paid $');
  394.  PUTREAL(RECEIVE);
  395.  WRITELN(' each visit.');
  396.  WRITE('Then you received $');PUTREAL(GOTCASH);WRITE(' Is this okay?');
  397.  READ (ANSWER);
  398.  IF (ANSWER='Y') OR (ANSWER='y') THEN ANSWER:='X';
  399.  UNTIL ANSWER='X';
  400.  WIPESCREEN;GOTOXY(12,12);
  401.  WRITELN('Have you received any additional cash from ',NAME,' ?');
  402.  READ(ANSWER);
  403.  IF (ANSWER='N')OR(ANSWER='n')OR(ANSWER='F')OR(ANSWER='f')THEN ANSWER:='Q';
  404.  IF (ANSWER ='Y') OR (ANSWER='y') OR (ANSWER ='T') OR (ANSWER='t') THEN
  405.  BEGIN
  406.  REPEAT
  407.  WIPESCREEN;GOTOXY(12,12);
  408.  CASH:=0;
  409.  WRITE('Enter the amount received from ',NAME,' $');
  410.  READLN(CASH);
  411.  WRITE('$');PUTREAL(CASH);
  412.  WRITELN('  Is this okay?');
  413.  READ(ANSWER);
  414.  IF (ANSWER ='Y') OR (ANSWER='y') OR (ANSWER='T') OR (ANSWER='t') THEN ANSWER:='X';
  415.  UNTIL ANSWER='X';
  416.  GOTCASH:=GOTCASH+CASH;
  417.  WIPESCREEN;GOTOXY(0,12);
  418.  WRITE('You have received a total of $');
  419.          PUTREAL(GOTCASH);
  420.  WRITELN(' from ',NAME,' in cash. ');
  421.  WRITE(' Is this Correct?');
  422.  READ(ANSWER);
  423.  END; (* IF THEN *)
  424.    UNTIL (ANSWER='Y')OR(ANSWER='y')OR(ANSWER='T')OR(ANSWER='t')OR(ANSWER='Q'); 
  425.  (*  WITH REC DO *)
  426.  WIPESCREEN;
  427.  END; (*  DIDNTPAY  *)
  428.  
  429.  
  430.  PROCEDURE DATES(VAR REC:PATIENT);
  431.  VAR I:INTEGER;
  432.  SAMETIME:BOOLEAN;
  433.  LONG:REAL;
  434.  BEGIN
  435.  WITH REC DO
  436.  BEGIN
  437.  WIPESCREEN;GOTOXY(12,12);
  438.  I:=0;
  439.  WRITELN('Enter the dates of service followed by the time spent.');
  440.  WRITELN('Hit RETURN to proceed.');
  441.  READ(ANSWER);
  442.  WIPESCREEN;GOTOXY(1,12);
  443.  WRITE('Do you want the time displayed on the bill');
  444.  READ(ANSWER);
  445.  IF (ANSWER='N')OR(ANSWER='n') THEN SHOWTIME:=FALSE ELSE SHOWTIME:=TRUE;
  446.  WIPESCREEN;GOTOXY(1,12);
  447.  WRITE('Does this patient come for the same number of hours each week? ');
  448.  READ(ANSWER);LONG:=0;
  449.  IF (ANSWER='Y')OR(ANSWER='y') THEN
  450.  BEGIN
  451.  WIPESCREEN; GOTOXY(12,12);
  452.  SAMETIME:=TRUE;
  453.  WRITE('How many hours? ');
  454.  READLN(LONG);
  455.  END
  456.  ELSE SAMETIME:=FALSE;
  457.  REPEAT
  458.     I:=I+1;
  459.  WIPESCREEN;GOTOXY(12,12);
  460.  WRITE('date #',I,'=');
  461.  READLN(DATE[I]);
  462.  WIPESCREEN;GOTOXY(12,12);
  463.  WRITE(DATE[I],' Correct?');
  464.  READ(ANSWER);
  465.  IF ANSWER='N' THEN 
  466.  BEGIN
  467.  WIPESCREEN;GOTOXY(12,12);
  468.  WRITE('date #',I,'=');
  469.  READLN(DATE[I]);
  470.  END;
  471.  IF ANSWER='n' THEN 
  472.  BEGIN
  473.  WIPESCREEN;GOTOXY(12,12);
  474.  WRITE('date #',I,'=');
  475.  READLN(DATE[I]);
  476.  END;
  477.  IF NOT SAMETIME THEN
  478.  BEGIN
  479.  WIPESCREEN;GOTOXY(12,12);
  480.  WRITE('length of appointment=');
  481.  READLN(TIME[I]);
  482.  WIPESCREEN;GOTOXY(12,12);
  483.  WRITE(DATE[I],' ', NAME  ,' spent ');
  484.  PUTREAL(TIME[I]);WRITE(' hours.   Correct?');
  485.  READ(ANSWER);
  486.  IF ANSWER='N' THEN 
  487.  BEGIN
  488.  WIPESCREEN;GOTOXY(12,12);
  489.  WRITE('time for ',DATE[I],'= ');
  490.  READLN(TIME[I]);
  491.  END;
  492.  IF ANSWER='n' THEN 
  493.  BEGIN
  494.  WIPESCREEN;GOTOXY(12,12);
  495.  WRITE('time for ',DATE[I],'= ');
  496.  READLN(TIME[I]);
  497.  END;
  498.  END;  (* IF NOT SAMETIME *)
  499.  IF SAMETIME THEN TIME[I]:=LONG;
  500.  UNTIL DATE[I]='';
  501.  INDEX:=I-1;
  502.  END;
  503.  END;(*  DATES  *)
  504.  
  505.  
  506.                                      PROCEDURE DOBILL(VAR REC:PATIENT);
  507.  VAR J:INTEGER;
  508.  BEGIN
  509.  WITH REC DO
  510.  BEGIN
  511.  WIPESCREEN;
  512.  TOTAL:=0;
  513.  TAB(15);
  514.  WRITELN(NAME);
  515.  TAB(15);
  516.  WRITELN(STREET);
  517.  TAB(15);
  518.  WRITELN(CITYSTATE);
  519.  WRITELN;
  520.  WRITELN;
  521.  WRITELN('Individual Psychotherapy:');
  522.  WRITELN;
  523.  WRITELN;
  524.  FOR J:=1 TO INDEX DO
  525.  BEGIN
  526.  WRITE(DATE[J]);
  527.  DODOTS(15-LENGTH(DATE[J]));
  528.  IF SHOWTIME THEN
  529.   BEGIN
  530.  WRITE('(');
  531.  PUTIME(TIME[J]);
  532.  WRITE(' hour');
  533.  IF TIME[J]>1 THEN WRITE('s')
  534.  ELSE WRITE(' ');
  535.  WRITE(')');
  536.  DODOTS(13);
  537.  END
  538.  ELSE DODOTS(25);
  539.  WRITE('$');
  540.  AMT:=(TIME[J]*RATE);
  541.  PUTREAL(AMT);
  542.  WRITELN;
  543.  TOTAL:=TOTAL+AMT;
  544.  END;
  545.  IF (CUT) OR (RECEIVE>0) OR (GOTCASH>0) THEN
  546.  BEGIN
  547.  WRITELN;
  548.  WRITELN;
  549.  WRITE('Total');
  550.  DODOTS(35);
  551.  WRITE('$');
  552.  PUTREAL(TOTAL);
  553.  END;
  554.  IF CUT THEN
  555.  BEGIN
  556.  WRITELN;
  557.  WRITELN;
  558.  WRITE('Professional Discount');
  559.  DODOTS(19);
  560.  WRITE('$');
  561.  PUTREAL(PERCENT*TOTAL);
  562.  TOTAL:=TOTAL-(PERCENT*TOTAL);
  563.  END;
  564.  IF (RECEIVE>0) OR (GOTCASH>0) THEN
  565.  BEGIN
  566.  WRITELN;
  567.  WRITELN;
  568.     WRITE('Received from ',NAME);
  569.  DODOTS(26-LENGTH(NAME));
  570.  WRITE('$');
  571.  PUTREAL(GOTCASH);
  572.  END;
  573.  WRITELN;
  574.  WRITELN;
  575.  WRITE('Balance Due');
  576.  DODOTS(29);
  577.  WRITE('$');
  578.  IF (CUT) OR (RECEIVE>0) OR (GOTCASH>0)THEN TOTAL:=(TOTAL-(GOTCASH));
  579.  PUTREAL(TOTAL);
  580.  END;
  581.  END; (*  DOBILL  *)
  582.  
  583.  PROCEDURE PRINTDOTS(N:INTEGER)   {PRETTIES UP THE DISPLAY};
  584.  VAR I:INTEGER;
  585.  BEGIN
  586.  FOR I:=1 TO N DO
  587.  BEGIN
  588.  WRITE(OUT,'-');
  589.  END;
  590.  END   {PRINTDOTS};
  591.  
  592.  PROCEDURE PRINTREAL(D:REAL);
  593.  VAR I:INTEGER;
  594.      B:INTEGER;
  595.  BEGIN
  596.  B:=ABS(ROUND((D-TRUNC(D))*100));
  597.  IF B<10 THEN 
  598.  BEGIN
  599.  WRITE(OUT,TRUNC(D):3,'.0',B)
  600.  END
  601.  ELSE  {B>=10}
  602.  BEGIN
  603.  IF D>=1.0 THEN 
  604.  BEGIN
  605.  WRITE(OUT,TRUNC(D):3,'.',B) 
  606.  END;
  607.  IF D<1 THEN
  608.  BEGIN
  609.  I:=ROUND(D*100); 
  610.  IF I>0 THEN {D is positive} 
  611.  BEGIN 
  612.  WRITE(OUT,'  0.',B);
  613.  END;
  614.  IF I<0 THEN   {D is negative} 
  615.  BEGIN
  616.  WRITE(OUT,' -0.');
  617.  IF B<10 THEN WRITE(OUT,'0',B)
  618.  ELSE WRITE(OUT,B);
  619.  END;
  620.  IF I=0 THEN WRITE(OUT,'  0   ');
  621.  END; 
  622.  END  {D>=1.0};
  623.                 END  {PRINTREAL};
  624.  
  625.  PROCEDURE PRINTIME(D:REAL);
  626.  VAR I:INTEGER;
  627.      B:INTEGER;
  628.  BEGIN
  629.  B:=ABS(ROUND((D-TRUNC(D))*100));
  630.  IF B<10 THEN 
  631.  BEGIN
  632.  WRITE(OUT,TRUNC(D):1,'.0',B)
  633.  END
  634.  ELSE  {B>=10}
  635.  BEGIN
  636.  IF D>=1.0 THEN 
  637.  BEGIN
  638.  WRITE(OUT,TRUNC(D):1,'.',B) 
  639.  END;
  640.  IF D<1 THEN
  641.  BEGIN
  642.  I:=ROUND(D*100); 
  643.  IF I>0 THEN {D is positive} 
  644.  BEGIN 
  645.  WRITE(OUT,'  0.',B);
  646.  END;
  647.  IF I<0 THEN   {D is negative} 
  648.  BEGIN
  649.  WRITE(OUT,' -0.');
  650.  IF B<10 THEN WRITE(OUT,'0',B)
  651.  ELSE WRITE(OUT,B);
  652.  END;
  653.  IF I=0 THEN WRITE(OUT,'  0   ');
  654.  END; 
  655.  END  {D>=1.0};
  656.  END  {PRINTIME};
  657.  
  658.  PROCEDURE PRINTBILL(VAR REC:PATIENT);
  659.  VAR C,Q,M,J,X:INTEGER;
  660.  BEGIN
  661.  WITH REC DO
  662.  BEGIN
  663.  WIPESCREEN;GOTOXY(12,12);
  664.  C:=0;
  665.  WRITELN('How many bills?');
  666.  READLN (M);WRITELN;
  667.  FOR Q:=1 TO M DO
  668.  BEGIN
  669.  WIPESCREEN;GOTOXY(12,12);
  670.  WRITELN('READY WITH BILL IN PRINTER?');
  671.  READ(ANSWER);
  672.  WIPESCREEN;GOTOXY(12,12);
  673.  C:=C+1;WRITELN('THIS IS THE #',C,' COPY I AM ABOUT TO PRINT.  DO YOU WANT MORE THAN ',M,'?');
  674.           READ(ANSWER);WIPESCREEN;
  675.  IF ANSWER='Y' THEN
  676.  BEGIN
  677.  WIPESCREEN;GOTOXY(12,12);
  678.  WRITELN('HOW MANY EXTRA?');
  679.  READ(X);WRITELN;
  680.  M:=M+X;
  681.  END;
  682.  IF ANSWER='y' THEN
  683.  BEGIN
  684.  WIPESCREEN;GOTOXY(12,12);
  685.  WRITELN('HOW MANY EXTRA?');
  686.  READ(X);
  687.  M:=M+X;
  688.  END;
  689.  WRITELN(OUT);
  690.  PRINTAB(12);
  691.  WRITELN(OUT,NAME);
  692.  PRINTAB(12);
  693.  WRITELN(OUT,STREET);
  694.  PRINTAB(12);
  695.  WRITELN(OUT,CITYSTATE);
  696.  WRITELN(OUT);
  697.  WRITELN(OUT);
  698.  WRITELN(OUT);
  699.  WRITELN(OUT);
  700.  WRITELN(OUT);
  701.  WRITELN(OUT,'Individual Psychotherapy:');
  702.  WRITELN(OUT);
  703.  WRITELN(OUT);
  704.  TOTAL:=0;
  705.  FOR J:=1 TO INDEX DO
  706.  BEGIN
  707.  WRITE(OUT,DATE[J]);
  708.  PRINTDOTS(15-LENGTH(DATE[J]));
  709.  IF SHOWTIME THEN
  710.  BEGIN
  711.  WRITE(OUT,'(');
  712.  PRINTIME(TIME[J]);
  713.  WRITE(OUT,' hour');
  714.  IF TIME[J]>1 THEN WRITE(OUT,'s')
  715.  ELSE WRITE(OUT,' ');
  716.  WRITE(OUT,')');
  717.  PRINTDOTS(13);
  718.  END
  719.  ELSE PRINTDOTS(25);
  720.  WRITE(OUT,'$');
  721.  AMT:=(TIME[J]*RATE);
  722.  PRINTREAL(AMT);
  723.  TOTAL:=TOTAL+AMT;
  724.  WRITELN(OUT);
  725.  END;
  726.  IF (CUT) OR (RECEIVE>0) OR (GOTCASH>0) THEN
  727.  BEGIN
  728.           WRITELN(OUT);
  729.  WRITELN(OUT);
  730.  WRITE(OUT,'Total');
  731.  PRINTDOTS(35);
  732.  WRITE(OUT,'$');
  733.  PRINTREAL(TOTAL);
  734.  END;
  735.  IF CUT THEN
  736.  BEGIN
  737.  WRITELN(OUT);
  738.  WRITELN(OUT);
  739.  WRITE(OUT,'Professional Discount');
  740.  PRINTDOTS(19);
  741.  WRITE(OUT,'$');
  742.  PRINTREAL(PERCENT*TOTAL);
  743.  TOTAL:=TOTAL-(PERCENT*TOTAL);
  744.  END;
  745.  IF (RECEIVE>0) OR (GOTCASH>0) THEN
  746.  BEGIN
  747.  WRITELN(OUT);
  748.  WRITELN(OUT);
  749.  WRITE(OUT,'Received from ',NAME);
  750.  PRINTDOTS(26-LENGTH(NAME));
  751.  WRITE(OUT,'$');
  752.  PRINTREAL(GOTCASH);
  753.  END;
  754.  WRITELN(OUT);
  755.  WRITELN(OUT);
  756.  WRITE(OUT,'Balance Due');
  757.  PRINTDOTS(29);
  758.  WRITE(OUT,'$');
  759.  PRINTREAL(TOTAL-GOTCASH);
  760.  END;
  761.  END;
  762.  END; (*  PRINTBILL  *)
  763.  
  764.  PROCEDURE OKAY;
  765.  BEGIN
  766.  WRITELN;
  767.  WRITELN('Is this bill in the form you wish printed?');
  768.  READ(ANSWER);
  769.  IF (ANSWER='N') OR (ANSWER='n') THEN
  770.  BEGIN
  771.  WIPESCREEN;GOTOXY(12,12);
  772.  WRITELN('Is the error in the entry of visits and charges?');
  773.  READ(ANSWER);
  774.  IF (ANSWER='Y') OR (ANSWER='y') THEN
  775.    BEGIN
  776.  DATES(FID^);
  777.  DOBILL(FID^);
  778.  OKAY;
  779.         ANSWER:=' ';
  780.  END;
  781.  END;
  782.  END;  (*  OKAY  *)
  783.  
  784.  
  785.  PROCEDURE ENVELOPE(VAR REC:PATIENT);
  786.  BEGIN
  787.  WITH REC DO
  788.  BEGIN
  789.  WIPESCREEN;GOTOXY(12,12);
  790.  WRITELN('Shall I print an envelope for you?');
  791.  READ(ANSWER);WIPESCREEN;
  792.  IF ANSWER='Y' THEN
  793.  BEGIN
  794.  PRINTAB(30);
  795.  WRITELN(OUT,NAME);
  796.  PRINTAB(30);
  797.  WRITELN(OUT,STREET);
  798.  PRINTAB(30);
  799.  WRITELN(OUT,CITYSTATE);
  800.  END;
  801.  IF ANSWER='y' THEN
  802.  BEGIN
  803.  PRINTAB(30);
  804.  WRITELN(OUT,NAME);
  805.  PRINTAB(30);
  806.  WRITELN(OUT,STREET);
  807.  PRINTAB(30);
  808.  WRITELN(OUT,CITYSTATE);
  809.  END;
  810.    WIPESCREEN;GOTOXY(12,12);
  811.  WRITELN('ANOTHER?');
  812.  READ(ANSWER);WIPESCREEN;
  813.  IF (ANSWER='Y') OR (ANSWER='y') THEN ENVELOPE(FID^);
  814.  END;
  815.  END;
  816.  
  817.  PROCEDURE MOREBILLS;
  818.  BEGIN
  819.  GOTOXY(12,12);
  820.  WRITELN('MORE BILLS WITH SAME ADRESS?');
  821.  READ(ANSWER);WIPESCREEN;
  822.  IF (ANSWER='Y') OR (ANSWER='y') THEN
  823.  BEGIN
  824.  DATES(FID^);
  825.  DIDNTPAY(FID^);
  826.  DOBILL(FID^);
  827.  OKAY;
  828.  PRINTBILL(FID^);
  829.  END;
  830.  END    {MOREBILLS};
  831.  
  832.  
  833.  
  834.  PROCEDURE FOUNDTHERECORD(REC:PATIENT);
  835.  BEGIN
  836.               SHOWREC(FID^);
  837.  WRITE('Is this record okay?');
  838.  READ(ANSWER);
  839.  IF (ANSWER='N') OR (ANSWER='n') THEN 
  840.  BEGIN
  841.  GETREC(FID^);
  842.  SEEK(FID,RECNUM);
  843.  PUT(FID);
  844.  END;
  845.  WITH REC DO
  846.  BEGIN
  847.  DATES(FID^);
  848.  DIDNTPAY(FID^);
  849.  DOBILL(FID^);
  850.  OKAY;
  851.  REWRITE(OUT,'PRINTER:');
  852.  PRINTBILL(FID^);
  853.  WRITELN('More Copies? ');
  854.  READ(ANSWER);
  855.  WIPESCREEN;
  856.  IF (ANSWER='Y') OR (ANSWER='y') THEN PRINTBILL(FID^);
  857.  ENVELOPE(FID^);
  858.  MOREBILLS;
  859.  CLOSE(OUT);
  860.  END;
  861.  END;(* FOUNDTHERECORD *)
  862.  
  863.  
  864.  BEGIN  (*  MAIN PROGRAM  *)
  865.  KEEPGOING:=TRUE;
  866.  WHILE KEEPGOING DO
  867.  BEGIN
  868.  PROMPT;
  869.  RECNUM:=0;
  870.  FOUNDIT:=FALSE;
  871.  SEARCH;
  872.  IF FOUNDIT THEN FOUNDTHERECORD(FID^);
  873.  SHALI;
  874.  CLOSE(FID,LOCK);
  875.  END; (* WHILE KEEPGOING *)
  876.  END.
  877.  
  878.