CP/M/CPM_CDROM.iso/mbug/mbug027.arc/TTGEN2.INC

Text File | 1979-12-31 | 6KB | 201 lines

PROCEDURE displayform;
BEGIN
  GotoXY(1,4);
  Writeln('      Animal Number : _____            Name : ____________________   Sex : _ ');
  Writeln('               Born : __ ___ 19__      Current Age :                         ');
  Writeln('               Died : __ ___ 19__                          ');
  Writeln('               Sire :                                      ');
  Writeln('               Dam  :                                      ');
  Writeln('                                                           ');
  Writeln('  Comment 1  : ________________________________________    ');
  Writeln('  Comment 2  : ________________________________________    ');
  Writeln('  Comment 3  : ________________________________________    ');
  Writeln('                    The following is used for Females only.                ');
  Writeln('Date of Last Mating : __ ___ 19__                Sire :                    ');
  Writeln('                                                                           ');
END;

PROCEDURE display_Animal(rab : Animal_rec);
{Displays the Animals information in the correct place on the form}
var
  yy,ww,dd : integer;
  ok       : boolean;

BEGIN
  WITH rab DO
    BEGIN
      dis(23,4,  ear_no);
      dis(47,4,  name);
      dis(76,4,  sex);
      dis(23,5,  Date_Born);
      yy := 0;
      ww := 0;
      dd := 0;
      verify_date(Date_Born,ok);
      if ok then
      begin
        verify_date(Date_Died,ok);
        if ok then age(Date_Born,Date_Died,yy,ww,dd)
              else age(Date_Born,Date_Today,yy,ww,dd);
        gotoxy(54,5);
        if yy > 0 then write(YY:2,' Years ',ww:2,' Weeks ',dd:2,' Days')
                  else write(ww:2,' Weeks ',dd:2,' Days');
      end;
      dis(23,6,  Date_Died);
      dis(23,7,  sire);
      dis(23,8,  dam);
      dis(23,10, Comment_1);
      dis(23,11, Comment_2);
      dis(23,12, Comment_3);
      if sex = 'F' then
      begin
        yy := 0;
        ww := 0;
        dd := 0;
        dis(23,14, Date_Mated);
        dis(57,14, Partner);
        verify_date(Date_Mated,ok);
        if ok then
        begin
          age(Date_Mated,Date_Today,yy,ww,dd);
          if ww < 12 then
          begin
            dd := dd + (ww * 7);
            gotoxy(30,15);
            write(dd ,' Days');
          end;
        end;
      end;
    END;
END;

PROCEDURE f_table;
{This routine print the numbers along the command line.  It only
 prints those number which have a name beside them.}

VAR
  kx,i : INTEGER;
  ch  : str1;
BEGIN
  kx := 2;
  FOR i := 1 TO 6 DO
    BEGIN
      str(i,ch); {Converts i to a char so it can be printed by DIS}
      IF (Animal_table[i].ear_no <> '')
        THEN
          BEGIN
            GotoXY(1,i+18);
            ClrEOL;
            WITH Animal_table[i] DO
              Write(ch,'   ',name ,' ':26-Length(name),Ear_No,' ': 14-Length(Ear_No),sex);
            dis(kx,17,ch);
          END
        ELSE
          BEGIN
            dis(kx,17,' '); {Delete number if Animal has been deleted}
            GotoXY(1,i+18);
            ClrEOL;
            Write(ch);
          END;
      kx := kx + 4;
    END;
END;

PROCEDURE Animals_table(no : INTEGER; Animal : Animal_rec);
BEGIN
  Animal_table[no] := Animal;
  f_table;
END;

PROCEDURE update_Animal_Table(Animal : Animal_rec);
{Read through the 6 Animals in the table and see if its record number
 matches the one that has just been edited.  If it does then print the
 new information in its place.  The record number is used as it is the
 only thing that cannot be change in the edit routine.}

VAR
  i,l : INTEGER;
BEGIN
  FOR i := 1 TO 6 DO
    IF Animal.Rec_No = Animal_table[i].Rec_No
      THEN
        BEGIN
          Animals_table(i,Animal);
        END;
END;

PROCEDURE InputStr(VAR S     : AnyStr;
                       K,X,Y : INTEGER;
                       Term  : CharSet;
                   VAR TC    : CHAR);

CONST
  UnderScore  =  '_';

VAR
  Ch : CHAR;
  P  : INTEGER;
BEGIN
  P := 0;
  GotoXY(X + 1,Y + 1);
  Write(S,ConstStr(UnderScore,K - Length(S)));
  REPEAT
    GotoXY(X + P + 1,Y + 1);
    Read(Kbd,Ch);
    CASE Ch OF
      #32..#126 : IF P < K
                    THEN
                      BEGIN
                        IF Length(S) = K
                          THEN
                            Delete(S,K,1);
                        P := P + 1;
                        Insert(Ch,S,P);
                        Write(Copy(S,P,K));
                      END
                    ELSE Beep;
      ^S        : IF P > 0
                    THEN
                      P := P - 1
                    ELSE Beep;
      ^D        : IF P < Length(S)
                    THEN
                      P := P + 1
                    ELSE Beep;
      ^A        : P := 0;
      ^F        : P := Length(S);
      ^G        : IF P < Length(S)
                    THEN
                      BEGIN
                        Delete(S,P + 1,1);
                        Write(Copy(S,P + 1,K),UnderScore);
                      END;
      ^H,#127   : IF P > 0
                    THEN
                      BEGIN
                        Delete(S,P,1);
                        Write(^H,Copy(S,P,K),UnderScore);
                        P := P - 1;
                      END
                    ELSE Beep;
      ^Y        : BEGIN
                    Write(ConstStr(UnderScore,Length(S) - P));
                    Delete(S,P + 1,K);
                  END;
    ELSE
      IF NOT (Ch IN Term)
        THEN Beep;
    END;  {of case}
  UNTIL (Ch IN Term) OR (P = K);
  P := Length(S);
  GotoXY(X + P + 1,Y + 1);
  Write('' :K - P);
  IF (P = K)
    THEN
      CASE Ch OF
       ^M,^E,^Z,#27 : ;
      ELSE  ch := ^X;
   END;
  TC := ch;
END;