home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG027.ARC / TTGEN2.INC < prev    next >
Text File  |  1979-12-31  |  6KB  |  201 lines
  1. PROCEDURE displayform;
  2. BEGIN
  3.   GotoXY(1,4);
  4.   Writeln('      Animal Number : _____            Name : ____________________   Sex : _ ');
  5.   Writeln('               Born : __ ___ 19__      Current Age :                         ');
  6.   Writeln('               Died : __ ___ 19__                          ');
  7.   Writeln('               Sire :                                      ');
  8.   Writeln('               Dam  :                                      ');
  9.   Writeln('                                                           ');
  10.   Writeln('  Comment 1  : ________________________________________    ');
  11.   Writeln('  Comment 2  : ________________________________________    ');
  12.   Writeln('  Comment 3  : ________________________________________    ');
  13.   Writeln('                    The following is used for Females only.                ');
  14.   Writeln('Date of Last Mating : __ ___ 19__                Sire :                    ');
  15.   Writeln('                                                                           ');
  16. END;
  17.  
  18. PROCEDURE display_Animal(rab : Animal_rec);
  19. {Displays the Animals information in the correct place on the form}
  20. var
  21.   yy,ww,dd : integer;
  22.   ok       : boolean;
  23.  
  24. BEGIN
  25.   WITH rab DO
  26.     BEGIN
  27.       dis(23,4,  ear_no);
  28.       dis(47,4,  name);
  29.       dis(76,4,  sex);
  30.       dis(23,5,  Date_Born);
  31.       yy := 0;
  32.       ww := 0;
  33.       dd := 0;
  34.       verify_date(Date_Born,ok);
  35.       if ok then
  36.       begin
  37.         verify_date(Date_Died,ok);
  38.         if ok then age(Date_Born,Date_Died,yy,ww,dd)
  39.               else age(Date_Born,Date_Today,yy,ww,dd);
  40.         gotoxy(54,5);
  41.         if yy > 0 then write(YY:2,' Years ',ww:2,' Weeks ',dd:2,' Days')
  42.                   else write(ww:2,' Weeks ',dd:2,' Days');
  43.       end;
  44.       dis(23,6,  Date_Died);
  45.       dis(23,7,  sire);
  46.       dis(23,8,  dam);
  47.       dis(23,10, Comment_1);
  48.       dis(23,11, Comment_2);
  49.       dis(23,12, Comment_3);
  50.       if sex = 'F' then
  51.       begin
  52.         yy := 0;
  53.         ww := 0;
  54.         dd := 0;
  55.         dis(23,14, Date_Mated);
  56.         dis(57,14, Partner);
  57.         verify_date(Date_Mated,ok);
  58.         if ok then
  59.         begin
  60.           age(Date_Mated,Date_Today,yy,ww,dd);
  61.           if ww < 12 then
  62.           begin
  63.             dd := dd + (ww * 7);
  64.             gotoxy(30,15);
  65.             write(dd ,' Days');
  66.           end;
  67.         end;
  68.       end;
  69.     END;
  70. END;
  71.  
  72. PROCEDURE f_table;
  73. {This routine print the numbers along the command line.  It only
  74.  prints those number which have a name beside them.}
  75.  
  76. VAR
  77.   kx,i : INTEGER;
  78.   ch  : str1;
  79. BEGIN
  80.   kx := 2;
  81.   FOR i := 1 TO 6 DO
  82.     BEGIN
  83.       str(i,ch); {Converts i to a char so it can be printed by DIS}
  84.       IF (Animal_table[i].ear_no <> '')
  85.         THEN
  86.           BEGIN
  87.             GotoXY(1,i+18);
  88.             ClrEOL;
  89.             WITH Animal_table[i] DO
  90.               Write(ch,'   ',name ,' ':26-Length(name),Ear_No,' ': 14-Length(Ear_No),sex);
  91.             dis(kx,17,ch);
  92.           END
  93.         ELSE
  94.           BEGIN
  95.             dis(kx,17,' '); {Delete number if Animal has been deleted}
  96.             GotoXY(1,i+18);
  97.             ClrEOL;
  98.             Write(ch);
  99.           END;
  100.       kx := kx + 4;
  101.     END;
  102. END;
  103.  
  104. PROCEDURE Animals_table(no : INTEGER; Animal : Animal_rec);
  105. BEGIN
  106.   Animal_table[no] := Animal;
  107.   f_table;
  108. END;
  109.  
  110. PROCEDURE update_Animal_Table(Animal : Animal_rec);
  111. {Read through the 6 Animals in the table and see if its record number
  112.  matches the one that has just been edited.  If it does then print the
  113.  new information in its place.  The record number is used as it is the
  114.  only thing that cannot be change in the edit routine.}
  115.  
  116. VAR
  117.   i,l : INTEGER;
  118. BEGIN
  119.   FOR i := 1 TO 6 DO
  120.     IF Animal.Rec_No = Animal_table[i].Rec_No
  121.       THEN
  122.         BEGIN
  123.           Animals_table(i,Animal);
  124.         END;
  125. END;
  126.  
  127. PROCEDURE InputStr(VAR S     : AnyStr;
  128.                        K,X,Y : INTEGER;
  129.                        Term  : CharSet;
  130.                    VAR TC    : CHAR);
  131.  
  132. CONST
  133.   UnderScore  =  '_';
  134.  
  135. VAR
  136.   Ch : CHAR;
  137.   P  : INTEGER;
  138. BEGIN
  139.   P := 0;
  140.   GotoXY(X + 1,Y + 1);
  141.   Write(S,ConstStr(UnderScore,K - Length(S)));
  142.   REPEAT
  143.     GotoXY(X + P + 1,Y + 1);
  144.     Read(Kbd,Ch);
  145.     CASE Ch OF
  146.       #32..#126 : IF P < K
  147.                     THEN
  148.                       BEGIN
  149.                         IF Length(S) = K
  150.                           THEN
  151.                             Delete(S,K,1);
  152.                         P := P + 1;
  153.                         Insert(Ch,S,P);
  154.                         Write(Copy(S,P,K));
  155.                       END
  156.                     ELSE Beep;
  157.       ^S        : IF P > 0
  158.                     THEN
  159.                       P := P - 1
  160.                     ELSE Beep;
  161.       ^D        : IF P < Length(S)
  162.                     THEN
  163.                       P := P + 1
  164.                     ELSE Beep;
  165.       ^A        : P := 0;
  166.       ^F        : P := Length(S);
  167.       ^G        : IF P < Length(S)
  168.                     THEN
  169.                       BEGIN
  170.                         Delete(S,P + 1,1);
  171.                         Write(Copy(S,P + 1,K),UnderScore);
  172.                       END;
  173.       ^H,#127   : IF P > 0
  174.                     THEN
  175.                       BEGIN
  176.                         Delete(S,P,1);
  177.                         Write(^H,Copy(S,P,K),UnderScore);
  178.                         P := P - 1;
  179.                       END
  180.                     ELSE Beep;
  181.       ^Y        : BEGIN
  182.                     Write(ConstStr(UnderScore,Length(S) - P));
  183.                     Delete(S,P + 1,K);
  184.                   END;
  185.     ELSE
  186.       IF NOT (Ch IN Term)
  187.         THEN Beep;
  188.     END;  {of case}
  189.   UNTIL (Ch IN Term) OR (P = K);
  190.   P := Length(S);
  191.   GotoXY(X + P + 1,Y + 1);
  192.   Write('' :K - P);
  193.   IF (P = K)
  194.     THEN
  195.       CASE Ch OF
  196.        ^M,^E,^Z,#27 : ;
  197.       ELSE  ch := ^X;
  198.    END;
  199.   TC := ch;
  200. END;
  201.