Appointment Pad for DOS, poor example TP6 source

Filename MYAP.PAS
Sorry for posting such a mess, I wrote it ten years ago,
and thought it might make a good summer project to clean
it up, see how many global variables can be removed, etc. :-)

Ken Fischer

{     This program is for DOS only, written in TP6.0,
      _REQUIRES_ a directory on the C: drive called "APAD".

      Once the APAD directory is created, and added to
      the PATH in Autoexec.BAT the executable of this
      program can be copied to a directory that is in
      the path, and a small calendar and appointment
      system results.  Run the program to create a
      calendar pad for any month, and to enter short
      notes or appointtments.  After 1999, type 20nn.

      It writes .com files that can be viewed by just
      typing the name given that month, so use a very
      consistent naming system, and erase the previous
      year's file for that month, or name as june99, etc.

      Once a file for a month is created, the program
      reads the .com file to get the existing information
      to include in the modified file.   This could cause
      loss of information in case of power failure or
      other interruption of file creation, if the user
      wants to add a backup file routine, great.

      To just _VIEW_ a month's appointments, just type
      the name of the month, and it will be displayed
      by the .com file.

      The best list of names for months can be seen in
      the souurce code.
                              Kenneth E. Fischer      }

PROGRAM WRITE_APPOINTMENT_SHEET;

uses Dos,Crt;

TYPE    SCR_PAGE = ARRAY[1..23] OF ARRAY[1..80] OF CHAR;

VAR    PAGE1 : SCR_PAGE;

Var  month,m,yr,days: Real;
Var  D: Array[1..31] of String[3];
var  CA: array[1..42] of string[3];
VAR  e,j,O,P,Q,R,S,U,Cx,CXX,I,II,B,Z,molen,FM:  INTEGER;
VAR  CF,W,t,t1,t2,t3,t4,t5,t6,t7,Q1,Q2,Q3,Q4,Q5,Q6:  REAL;

VAR     CR,H1B,H5B,H3B,H22,H1A,H4A,H30,H31,H32,H01,
        INCDI,DECCX,INCSI,HB4,H09,HCD,H21,H20,H24                 :CHAR;

        B1,B2,B3,B4,N1,N2,N3,N4,saveX,saveY,
        X,Y,OS,SB,W1,W2,
        DI,SI,ES,year                    :INTEGER;

        MOVAH,MOVAL,MOVAX,MOVBH,MOVBL,MOVBX,MOVCH,MOVCL,MOVCX,
        MOVDH,MOVDL,MOVDX,MOVESAX,MOVDIAL,MOVALSI,Ch   :STRING[24];

        C,CC,CCC,CCH           :CHAR;

        TMPFIL,FILVAR,MODFIL    :TEXT;

        FNAME,FILENAME,MODNAME,MONTHNAME     :STRING[14];

VAR
         CF1,CF2,CF3,CF4,CF5,CF6,CF7,CF8,NOP,
         ESC,C5,PE,HN0,IC,SC,
         HN1,HN2                                    :CHAR;
         LOOP,US,SP,TERM,N0,NN0,SN,
         B5,B6,NN1,NN2,
         A,PB,PM,DOOVER                       :INTEGER;
         FIL,TEMPVAR                         :TEXT;
         MSG,FILNAM,FILENAM,TEMPFILE,TEMPFIL      :STRING[24];

Procedure LOC;
begin
   GotoXY(X,Y);
end;

Procedure GET_MOD_NAME_TO_WRITE; (* This version uses .COM file as template *)
LABEL   OVER,ALL;
VAR    L2        :    INTEGER;
begin
   DOOVER:= 0; FILENAME:= ''; FILENAM:= ''; Textcolor(6);
   GotoXY(26,5); Writeln('Aviance Appointment Pad'); textcolor(7);
   GotoXY(26,7); Writeln('   by  Joe Fischer     '); writeln;
Writeln('            When finished, CONTROL-Q Writes file, and Quits Program');
   GotoXY(1,12); textcolor(white);
   WRITE('Enter MONTH of Appointment File TO WRITE OR MODIFY :       ');
   GotoXY(53,12);
OVER:
   READLN(FILENAME);
   if Filename = '' then GOTO OVER;
   ASSIGN(FIL,FILENAME);
   {$I-}
   RESET(FIL);
   {$I+}
   IF IORESULT <> 0 THEN begin
                            DOOVER:= 1; WRITELN;
                            end;
                                     WRITELN(FILENAME);
   FOR L2:= 1 TO LENGTH(FILENAME) DO
         begin
            CH:= COPY(FILENAME,L2,1);
            IF CH = '.' THEN GOTO ALL;
            FILENAM:= FILENAM + CH;
         end;
ALL:
      TEMPFIL:= FILENAM;
      FILENAM:= '\APAD\' + FILENAM + '.COM';
                                     WRITELN(FILENAM);
      ASSIGN(FILVAR,FILENAM);
      {$I-}
      RESET(FILVAR);
      {$I+}
      IF IORESULT = 0 THEN begin
                              WRITELN(Filenam,' FILE ALREADY EXISTS!!!');
                              WRITELN('DO YOU WANT TO MODIFY, Y/N');
                              C:= ' '; C:= READkey;
                              If C = 'y' then C:= 'Y';
                              IF C = 'Y' THEN begin  DOOVER:= 1;
                                                  CLOSE(FILVAR);
                                               end ELSE DOOVER:= 2;
                           end ELSE      (* FILE DOES NOT EXIST *)
                             begin
                               WRITELN('FILE WILL BE NAMED  ',FILENAM);
                               DELAY(2000);
                             end;
end;

Procedure KEEP_INBOUNDS;
begin
   IF Y > 23 THEN Y:= 23;
   IF Y < 1 THEN Y:= 1;
   IF X < 1 THEN X:= 1;
   IF X > 79 THEN X:= 79;
end;

Procedure Write_Double_Spaced;
LABEL    ALL;
var        L3,Lp,Index      :Integer;
           LongPage_Filename:String[32];
           LongFilvar       :Text;
begin
   SaveX:= WhereX; SaveY:= WhereY;
   LongPage_Filename:= '';
   FOR L3:= 1 TO LENGTH(FILENAM) DO
         begin
            CH:= COPY(FILENAM,L3,1);
            IF CH = '.' THEN GOTO ALL;
            LongPage_Filename:= LongPage_Filename + CH;
         end;
ALL:

   Filnam:= '';
   Filnam:= 'C:' + LongPage_Filename + '.TXT';
   Assign(LongFilvar,Filnam);
   Rewrite(LongFilvar);
   Index:= 0;
   For Y:= 1 to 23 do
      begin
         FOR X:= 1 TO 80 DO
            begin
               SC:= PAGE1[Y,X];
               WRITE(LongFilvar,SC);
            end;   (* To lengthen the printout, just add another #12,#10 *)
         Write(LongFilvar,chr(13),chr(10),chr(13),chr(10));
         Index:= Index + 80;
      end;
Close(LongFilvar);
X:= SaveX; Y:= SaveY;
Keep_Inbounds; LOC;
end;

Procedure E_K;
begin
   CC:= READkey;
   CASE CC OF
#59  : begin Write_Double_Spaced; end;
#71  : begin X:= 1; end;
#80  : begin Y:= Y + 1; end;
#72  : begin Y:= Y - 1; end;
#75  : begin X:= X - 1; end;
#77  : begin X:= X + 1; end;
   end;  (* CASE *)
   KEEP_INBOUNDS; LOC;
end;

Procedure NEW_MOD;
begin
   WRITELN(filvar,'   APPOINTMENTS FOR ',MONTHname,'  ',YEAR);
end;

Procedure ENTER_DATA;
LABEL    MOV,BYE;
begin
   X:= 8; Y:= 4;
MOV:
   KEEP_INBOUNDS; LOC; GOTOXY(X,Y);
   C:= Readkey;
   IF C = #0 THEN begin E_K; GOTO MOV; end;
   IF C = #13 THEN begin
                      LOC; X:= 1; Y:= Y + 1; LOC; GOTO MOV;
                   end;
   IF C = #17 THEN GOTO BYE;
   IF C = #26 THEN begin LOC; WRITE(CHR(3)); PAGE1[Y,X]:= CHR(3);
                     X:= X + 1; LOC; GOTO MOV; end;
   IF C = #7 THEN begin LOC; WRITE(CHR(3));  PAGE1[Y,X]:= CHR(3);
                     X:= X + 1; LOC; GOTO MOV; end;
   IF C = #8 THEN begin LOC; WRITE(CHR(32)); PAGE1[Y,X]:= CHR(32);
                     X:= X - 1; LOC; GOTO MOV; end;
   IF C = #9 THEN begin LOC; WRITE(CHR(32)); PAGE1[Y,X]:= CHR(32);
                     X:= X + 1; LOC; GOTO MOV; end;
   IF C = #10 THEN begin LOC; WRITE(CHR(2)); PAGE1[Y,X]:= CHR(2);
                     X:= X + 1; LOC; GOTO MOV; end;
   IF C <> #27 THEN begin
                       LOC; WRITE(C); PAGE1[Y,X]:= C; X:= X + 1; LOC;
                   end;
GOTO MOV;
BYE:
end;

Procedure WRITE_FILE;
VAR      KN       :INTEGER;
begin
    ASSIGN(FILVAR,FILENAM);
    REWRITE(FILVAR);
    CF1:= CHR($B4); CF2:= CHR($09); CF3:= CHR($BA); CF4:= CHR($10);
    CF5:= CHR($01); CF6:= CHR($CD); CF7:= CHR($21); CF8:= CHR($20);
    X:= 7; Y:= 2; N1:= 5; N2:= 9; H32:= CHR($32); H4A:= CHR($4A);
    WRITE(FILVAR,CF1,CF2,CF3,CF4,CF5,CF6,CF7,CF6,CF8);
    NOP:= CHR($90);
    WRITE(FILVAR,NOP,NOP,NOP,NOP,NOP,NOP,NOP);
   FOR Y:= 1 TO 23 DO
      begin
         FOR X:= 1 TO 80 DO
            begin
               SC:= PAGE1[Y,X];
               WRITE(FILVAR,SC);
            end;
      end;
end;

Procedure LOAD_TEMP_MOD_FILE;
LABEL     SKIP;
begin
   TEMPFILE:= '\APAD\' + TEMPFIL + '.COM';
   ASSIGN(TEMPVAR,TEMPFILE);
   {$I-}
   RESET(TEMPVAR);
   {$I+}
   IF IORESULT <> 0 THEN begin
                          GOTOXY(1,3); WRITELN('FILE DOES NOT EXIST');
                          DOOVER:= 2; GOTOXY(1,1);
                          GOTO SKIP;
                       end;
   CLOSE(TEMPVAR);
   ASSIGN(TEMPVAR,TEMPFILE);
   RESET(TEMPVAR);
   FOR OS:= 0 TO 15 DO
      READ(TEMPVAR,SC);
   FOR Y:= 1 TO 23 DO
      begin
         FOR X:= 1 TO 80 DO
            begin
               READ(TEMPVAR,SC); IF SC = '$' THEN GOTO SKIP;
               LOC; WRITE(SC);
               PAGE1[Y,X]:= SC;
            end;
       end;
   WRITELN;
   CLOSE(TEMPVAR);
SKIP:
end;

Procedure N;      (* Patterned after Article in Sky & Telescope *)
begin (* July, 1985  from the Basic Program Converted from Fortran- *)
   I:= I + 1;
end;        (* Basic to Turbo Pascal 4.0 Conversion  by Joe Fischer *)

Procedure Assig_Dates;    {  BUILD ARRAY OF 2-BYTE STRINGS  }
begin
   I:= 1;
   D[I]:= '1 '; n; D[I]:= '2 '; n; D[I]:= '3 '; N; D[I]:= '4 '; N;
   D[I]:= '5 '; n; D[I]:= '6 '; n; D[I]:= '7 '; N; D[I]:= '8 '; N;
   D[I]:= '9 '; n; D[I]:= '10'; n; D[I]:= '11'; N; D[I]:= '12'; N;
   D[I]:= '13'; n; D[I]:= '14'; n; D[I]:= '15'; N; D[I]:= '16'; N;
   D[I]:= '17'; n; D[I]:= '18'; n; D[I]:= '19'; N; D[I]:= '20'; N;
   D[I]:= '21'; n; D[I]:= '22'; n; D[I]:= '23'; N; D[I]:= '24'; N;
   D[I]:= '25'; n; D[I]:= '26'; n; D[I]:= '27'; N; D[I]:= '28'; N;
   D[I]:= '29'; n; D[I]:= '30'; n; D[I]:= '31';
end;

Procedure Find_Num_Of_Days_In_Month;
begin
   if month = 1 then begin  days := 31E+00; monthname:= 'January'; end;
   if month = 2 then begin  days := 28E+00; monthname:= 'February'; end;
   if month = 3 then begin  days := 31E+00; monthname:= 'March'; end;
   if month = 4 then begin  days := 30E+00; monthname:= 'April'; end;
   if month = 5 then begin  days := 31E+00; monthname:= 'May'; end;
   if month = 6 then begin  days := 30E+00; monthname:= 'June'; end;
   if month = 7 then begin  days := 31E+00; monthname:= 'July'; end;
   if month = 8 then begin  days := 31E+00; monthname:= 'August'; end;
   if month = 9 then begin  days := 30E+00; monthname:= 'September'; end;
   if month = 10 then begin  days := 31E+00; monthname:= 'October'; end;
   if month = 11 then begin  days := 30E+00; monthname:= 'November'; end;
   if month = 12 then begin  days := 31E+00; monthname:= 'December'; end;
end;

Procedure MONTH_TO_NO;
begin
   IF COPY(FILENAME,1,3) = 'JAN' THEN MONTH:= 1;
   IF COPY(FILENAME,1,3) = 'FEB' THEN MONTH:= 2;
   IF COPY(FILENAME,1,3) = 'MAR' THEN MONTH:= 3;
   IF COPY(FILENAME,1,3) = 'APR' THEN MONTH:= 4;
   IF COPY(FILENAME,1,3) = 'MAY' THEN MONTH:= 5;
   IF COPY(FILENAME,1,3) = 'JUN' THEN MONTH:= 6;
   IF COPY(FILENAME,1,3) = 'JUL' THEN MONTH:= 7;
   IF COPY(FILENAME,1,3) = 'AUG' THEN MONTH:= 8;
   IF COPY(FILENAME,1,3) = 'SEP' THEN MONTH:= 9;
   IF COPY(FILENAME,1,3) = 'OCT' THEN MONTH:= 10;
   IF COPY(FILENAME,1,3) = 'NOV' THEN MONTH:= 11;
   IF COPY(FILENAME,1,3) = 'DEC' THEN MONTH:= 12;
   IF COPY(FILENAME,1,3) = 'jan' THEN MONTH:= 1;
   IF COPY(FILENAME,1,3) = 'feb' THEN MONTH:= 2;
   IF COPY(FILENAME,1,3) = 'mar' THEN MONTH:= 3;
   IF COPY(FILENAME,1,3) = 'apr' THEN MONTH:= 4;
   IF COPY(FILENAME,1,3) = 'may' THEN MONTH:= 5;
   IF COPY(FILENAME,1,3) = 'jun' THEN MONTH:= 6;
   IF COPY(FILENAME,1,3) = 'jul' THEN MONTH:= 7;
   IF COPY(FILENAME,1,3) = 'aug' THEN MONTH:= 8;
   IF COPY(FILENAME,1,3) = 'sep' THEN MONTH:= 9;
   IF COPY(FILENAME,1,3) = 'oct' THEN MONTH:= 10;
   IF COPY(FILENAME,1,3) = 'nov' THEN MONTH:= 11;
   IF COPY(FILENAME,1,3) = 'dec' THEN MONTH:= 12;
   IF COPY(FILENAME,1,3) = 'Jan' THEN MONTH:= 1;
   IF COPY(FILENAME,1,3) = 'Feb' THEN MONTH:= 2;
   IF COPY(FILENAME,1,3) = 'Mar' THEN MONTH:= 3;
   IF COPY(FILENAME,1,3) = 'Apr' THEN MONTH:= 4;
   IF COPY(FILENAME,1,3) = 'May' THEN MONTH:= 5;
   IF COPY(FILENAME,1,3) = 'Jun' THEN MONTH:= 6;
   IF COPY(FILENAME,1,3) = 'Jul' THEN MONTH:= 7;
   IF COPY(FILENAME,1,3) = 'Aug' THEN MONTH:= 8;
   IF COPY(FILENAME,1,3) = 'Sep' THEN MONTH:= 9;
   IF COPY(FILENAME,1,3) = 'Oct' THEN MONTH:= 10;
   IF COPY(FILENAME,1,3) = 'Nov' THEN MONTH:= 11;
   IF COPY(FILENAME,1,3) = 'Dec' THEN MONTH:= 12;
end;

Procedure CAL;
LABEL    BADC,LEAC,BYEC;
VAR      S1,S2,S3,S4,S5      :STRING[80];
begin
gotoxy(1,1); (* write('Enter number of Month : '); *) MONTH_TO_NO;
(* readln(month); *) Find_Num_Of_Days_In_Month; gotoxy(1,1);
BADC:
WRITE('                              ');
GOTOXY(1,1);
WRITE('ENTER YEAR : '); READLN(YEAR); WRITELN;
IF YEAR = 0 THEN begin
                   WRITELN('Please Enter four digits for Year');
                   GOTO BADC;
                 end;
if YEAR < 100 then YEAR:= YEAR + 1900;
YR:= YEAR; M:= MONTH;  (* change yyyy to 2000 after 1999 *)
t1:= trunc((m+9)/12);
t2:= trunc(7*(yr+t1))/4;
t3:= trunc(275*m/9);
t5:= 367E+00 * YR;
t7:= (t5 - t2) + t3 + 1.721031E+06;
T:= t7;
MOLEN:=0; IF M <= 2 THEN MOLEN:= - 1;
t:= t - trunc(3 * (trunc((YR+MOLEN)/100)+1)/4);
MOLEN:= TRUNC(days); IF M <> 2 THEN GOTO LEAC;
W:= trunc(YR -100 * trunc(YR/100)); CxX:= trunc(YR - 4 * trunc(YR/ 4));
Z:= trunc(YR - 400 * trunc(YR/ 400));
IF CxX <> 0 THEN GOTO LEAC;
IF W = 0 THEN IF Z <> 0 THEN GOTO LEAC;
MOLEN:= 29;
LEAC:
Q1:= T/7E+00;
Q2:= INT(Q1);
Q3:= (Q2 * 7);
Q4:= (T - Q3); IF Q4-INT(Q4)<0.5E+00 THEN Q4:= Q4+ 1;
Q5:= ROUND(Q4); {these two if-then's added to compensate for rounding}
CX:= TRUNC(Q5); IF CX = 7 THEN CX:= 0; GOTOXY(1,1);
S1:= 'SUNDAY     MONDAY     TUESDAY    WEDNESDAY  THURSDAY   FRIDAY     SATURDAY      ';
write(filvar,S1); FM:= 96 + 74;
WRITE(filvar,'                                                                                ');
For I:= 1 to 42 do
        begin
          CA[I]:= '  ';
        end;
Assig_Dates;
For I:= 1 to MOLEN do
        begin
        CA[I+CX]:= D[I];
        end;
For II:= 1 to 5 do
        begin
        J:= II*7;
Write(filvar,CA[J-6],'         ',CA[J-5],'         ',CA[J-4],'         ',
        CA[J-3],'         ',CA[J-2],'         ',CA[J-1],'         ',CA[J],'  ');
        IF II < 6 THEN begin
WRITE(filvar,'                                                                                   ');
WRITE(filvar,'                                                                                   ');
WRITE(filvar,'                                                                                    ');
                       end;
        end;
Write(filvar,CA[42-6],'         ',CA[42-5],'         ',CA[42-4]);
   WRITE(filvar,'                APPOINTMENTS FOR ',MONTHname,'  ',YEAR,'         ');
{   Write(FilVar,'                                                                                  ');
   Write(FilVar,'                                                                                  ');
 }
BYEC:
end;

Procedure NEW_FILE;
VAR      KN,l9       :INTEGER;
begin
    ASSIGN(FILVAR,FILENAM);
    REWRITE(FILVAR);
    CF1:= CHR($B4); CF2:= CHR($09); CF3:= CHR($BA); CF4:= CHR($10);
    CF5:= CHR($01); CF6:= CHR($CD); CF7:= CHR($21); CF8:= CHR($20);
    X:= 7; Y:= 2; N1:= 5; N2:= 9; H32:= CHR($32); H4A:= CHR($4A);
    WRITE(FILVAR,CF1,CF2,CF3,CF4,CF5,CF6,CF7,CF6,CF8);
    NOP:= CHR($90);
    WRITE(FILVAR,NOP,NOP,NOP,NOP,NOP,NOP,NOP);
    CAL;
WRITE(FILVAR,H24,H1A);
CLOSE(FILVAR);
end;

LABEL    MIDL;

begin        (**************** M A I N ********************)
   FOR Y:= 1 TO 23 DO
      begin
         FOR X:= 1 TO 80 DO
            begin
               PAGE1[Y,X]:= CHR(32);
            end;
       end;
   CLRSCR; TextMode(BW80); FILENAME:= ''; MONTH:= 0;
   GOTOXY(1,1); H1A:= CHR($1A); H01:= CHR($01);
   HB4:= CHR($B4); H09:= CHR($09); HCD:= CHR($CD); H21:= CHR($21);
   H20:= CHR($20); MOVAH:= CHR($B4); MOVDX:= CHR($BA);
   H22:= CHR($22); H24:= CHR($24); H1B:= CHR($1B); H5B:= CHR($5B);
   H32:= CHR($32); H4A:= CHR($4A); DOOVER:= 0;
MIDL:
   GET_MOD_NAME_TO_WRITE;
   IF DOOVER = 2 THEN begin ClrScr; GOTO MIDL; end;
   IF DOOVER = 1 THEN LOAD_TEMP_MOD_FILE;
   IF DOOVER = 2 THEN begin NEW_FILE; clrscr; LOAD_TEMP_MOD_FILE; end;
   ENTER_DATA;
   WRITE_FILE;

WRITE(FILVAR,H24,H1A);
CLOSE(FILVAR);
CLRSCR;
end.