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 / INPUT.INC < prev    next >
Text File  |  1979-12-31  |  4KB  |  157 lines
  1. overlay PROCEDURE Update(Date : str14);
  2. (*  Update is used to update the data base *)
  3. VAR
  4.   Ch : CHAR;
  5.   k,ok2 : INTEGER;
  6.  
  7. PROCEDURE InputAnimal(VAR Animal : Animal_Rec; VAR ch : CHAR);
  8. CONST
  9.   Term : CharSet  =  [^E,^I,^M,^X,^Z,#27];
  10. VAR
  11.   L        : INTEGER;
  12.   TC       : CHAR;
  13.   ear      : str5;
  14.  
  15. PROCEDURE get_parents;
  16. VAR
  17.   dummy1 : str1;
  18.   ch     : CHAR;
  19.   k,ok2  : INTEGER;
  20. BEGIN
  21.   dummy1 := ' ';
  22.   k      := 0;
  23.   Read(kbd,dummy1);
  24.   val(dummy1,k,ok2);
  25.   IF k IN [1..6] THEN
  26.       BEGIN
  27.         WITH  Animal_Table[k] DO
  28.           BEGIN
  29.             ch := sex;
  30.             CASE ch OF
  31.               'M' : BEGIN
  32.                       IF L <> 13 THEN
  33.                           BEGIN
  34.                             Animal.sire := Ear_No;
  35.                             dis(23,7,name);
  36.                             ClrEOL;
  37.                           END;
  38.                       IF L = 13  THEN
  39.                           BEGIN
  40.                             Animal.partner := Ear_No;
  41.                             dis(57,14,name);
  42.                           END;
  43.                     END;
  44.               'F' : BEGIN
  45.                       IF L <> 13 THEN Animal.dam := Ear_No;
  46.                       dis(23,8,name);
  47.                       ClrEOL;
  48.                     END;
  49.             END;{case}
  50.           END;{with}
  51.       END;{ K in [1..6]}
  52. END;
  53.  
  54. BEGIN
  55.   L := 1;
  56.   ear := '';
  57.   WITH Animal DO
  58.     REPEAT
  59.       CASE L OF
  60.         1 : BEGIN
  61.               InputStr(Ear_No,5,22,3,term,tc);
  62.               Ear_No := UpcaseStr(Ear_No);
  63.               Fillup(Ear_No);
  64.             END;
  65.         2 : InputStr(Name,20,46,3,term,tc);
  66.         3 : BEGIN
  67.               InputStr(sex,1,75,3,term,tc);
  68.               IF sex <> '' THEN
  69.                   IF (sex IN ['m','M','f','F'])
  70.                     THEN
  71.                       sex := UpCase(sex)
  72.                     ELSE
  73.                       sex := '';
  74.             END;
  75.         4 : BEGIN
  76.               GotoXY(23,5);
  77.               Write(Date_Born);
  78.               getdate(date_born,4);
  79.             END;
  80.         5 : BEGIN
  81.               GotoXY(23,6);
  82.               Write(Date_Died);
  83.               getdate(date_died,5);
  84.             END;
  85.         6 : BEGIN
  86.             END;
  87.         8,7 : BEGIN
  88.                 LowVideo;
  89.                 GotoXY(1,7);
  90.                 Write('Selete from ');
  91.                 GotoXY(1,8);
  92.                 Write('Parent table.');
  93.                 NormVideo;
  94.                 GotoXY(13,7);
  95.                 get_parents;
  96.                 IF sire = ''
  97.                   THEN BEGIN
  98.                          sire := '!000M';
  99.                          dis(23,7,'Un Known Male');
  100.                          ClrEOL;
  101.                     END;
  102.                 IF dam  = ''
  103.                   THEN BEGIN
  104.                          dam  := '!000F';
  105.                          dis(23,8,'Un Known Female');
  106.                          ClrEOL;
  107.                     END;
  108.                 GotoXY(1,7);
  109.                 Write('              ');
  110.                 GotoXY(1,8);
  111.                 Write('              ');
  112.               END;
  113.         9 : InputStr(Comment_1,40,15,9,term,tc);
  114.         10: InputStr(Comment_2,40,15,10,term,tc);
  115.         11: InputStr(Comment_3,40,15,11,term,tc);
  116.         12: IF sex = 'F' THEN
  117.                 BEGIN
  118.                   getdate(date_mated,13);
  119.                 END
  120.               ELSE
  121.                 TC := ^X;
  122.         13: IF sex = 'F' THEN
  123.                 BEGIN
  124.                   LowVideo;
  125.                   GotoXY(40,14);
  126.                   Write('P/Table');
  127.                   NormVideo;
  128.                   GotoXY(57,14);
  129.                   get_parents;
  130.                   GotoXY(40,14);
  131.                   Write('        ');
  132.                 END
  133.               ELSE
  134.                 BEGIN
  135.                   IF TC = ^E
  136.                     THEN L := 11
  137.                     ELSE TC := ^X;
  138.                 END;
  139.  
  140.       END; {Case of L}
  141.       CASE TC OF
  142.         ^M,^I,^X
  143.              : BEGIN
  144.                  L := L + 1;
  145.                  IF L = 14
  146.                    THEN L := 1;
  147.                END;
  148.         ^E    : BEGIN
  149.                   L := L - 1;
  150.                   IF L = 0
  151.                     THEN L := 13;
  152.                 END;
  153.       END; {case of TC}
  154.     UNTIL (TC = ^Z) OR (TC = #27);
  155.   ch := TC;
  156. END;
  157.