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 / TTLIST.INC < prev    next >
Text File  |  1979-12-31  |  5KB  |  185 lines
  1. OVERLAY PROCEDURE List(date : str14);
  2. LABEL
  3.   escape;
  4.  
  5. VAR
  6.   i,l,k    : INTEGER;
  7.   Bottom   : INTEGER;
  8.   Ptr,Rec  : INTEGER;
  9.   yes      : integer;
  10.   LD       : integer;
  11.   ch       : CHAR;
  12.   bl       : charset;
  13.   ear      : str5;
  14.   Animal   : Animal_rec;
  15.   yy,ww,dd : integer;
  16.   ok2      : boolean;
  17.  
  18. PROCEDURE Movecurs(ch : CHAR; VAR G : INTEGER);
  19.  
  20. VAR
  21.   old : INTEGER;
  22. BEGIN
  23.   old := G;
  24.   CASE ch OF
  25.     ^E  : BEGIN
  26.             G := G -1;
  27.             IF g = 3
  28.               THEN g := bottom + 3;
  29.           END;
  30.     ^X  : BEGIN
  31.             G := G + 1;
  32.             IF g = bottom + 4
  33.               THEN g := 4;
  34.           END;
  35.     ^Q  : G := 4;
  36.    END; {Case of ch}
  37.   dis(1,old,'  ');
  38.   dis(1,G,'->');
  39. END;
  40.  
  41. BEGIN
  42.   rec := 1;
  43.   line(1);
  44.   dis(1,2,'LIST     NAME                EAR NUMBER    SEX        AGE');
  45.   ClrEOL;
  46.     Display_Recs_Used;
  47.   line(16);
  48.   l := 4;
  49.   ClearKey(EarIndexFile);
  50.   ClearKey(NameIndexFile);
  51.   LD := FileLen(DatF) - 1;
  52.   repeat
  53.   ear := '';
  54.   dis(1,5,'Press RETURN to LIST ALL or type Starting Ear No. _____');
  55.   InputStr(ear,5,50,4,[^M,^Z,^X,^E],ch);
  56.   if ear <> '' then
  57.   begin
  58.     ear := UpCaseStr(ear);
  59.     fillup(ear);
  60.     FindKey(EarIndexFile,Ptr,Ear);
  61.     if (Not ok) then
  62.     begin
  63.       writeln;
  64.       writeln('Ear Number Not Found');
  65.     end;
  66.   end;
  67.   until ok or (ear = '');
  68.   if ear = '' then ear := '!!!!!';
  69.   ClearFrame;
  70.   Bottom := 0;
  71.   dis(1,17,
  72. '   |   |   |   |   |   | S = Screen | P = Printer   | <ESC> = MAIN   MENU |');
  73.   BL := ['P','S',#27,^M];
  74.   select(75,17,' ',BL,Ch);
  75.   if ch = #27 then goto escape;
  76.   if ch = 'P' then
  77.   begin
  78.     writeln(lst);
  79.     writeln(lst,'                       LIST of Animals on the ',date_Today);
  80.     writeln(lst,'   Name            Ear No  Sex  Sire   Dam         Birth         Death');
  81.     writeln(lst);
  82.     repeat
  83.       NextKey(EarIndexFile,Ptr,ear);
  84.       GetRec(DatF,Ptr,Animal);
  85.       with Animal do
  86.       begin
  87.         write(lst,name,' ':20 -(length(name)),ear_no,sex:4,sire:7,dam:7);
  88.         writeln(lst,date_born:14,date_died:14);
  89.       end;
  90.       l := l + 1;
  91.       if l = 57 then
  92.         begin
  93.           write('Press RETURN to continue.':50);
  94.           readln;
  95.           writeln(lst);
  96.           writeln(lst,'                       LIST of Animals on the ',date_Today);
  97.           writeln(lst,'   Name            Ear No  Sex  Sire   Dam         Birth         Death');
  98.           writeln(lst);
  99.           l := 4;
  100.         end;
  101.     until (not ok);
  102.     writeln(lst);
  103.   end;
  104.   l := 4;
  105.   rec := 0;
  106.   FindKey(EarIndexFile,Ptr,Ear);
  107.   PrevKey(EarIndexFile,Ptr,Ear);
  108.   REPEAT
  109.     IF  (UsedRecs(DatF) <= 12) THEN
  110.         BEGIN
  111.           dis(1,17,
  112. '   |   |   |   |   |   |          |                 | <ESC> = MAIN   MENU');
  113.           bl := [#27,^E,^X,^Q,'1','2','3','4','5','6'];
  114.         END;
  115.     IF (rec <= 12) AND (UsedRecs(DatF) > 12) THEN
  116.         BEGIN
  117.           dis(1,17,
  118. '   |   |   |   |   |   |          | N = Next screen | <ESC> = MAIN   MENU');
  119.           bl := ['N',#27,^E,^X,^Q,'1','2','3','4','5','6'];
  120.         END;
  121.     IF (rec > 12) THEN
  122.         BEGIN
  123.           dis(1,17,
  124. '   |   |   |   |   |   | B = Back | N = Next screen | <ESC> = MAIN   MENU');
  125.           bl := ['B','N',#27,^E,^X,^Q,'1','2','3','4','5','6'];
  126.         END;
  127.     NextKey(EarIndexFile,Ptr,ear);
  128.     GetRec(DatF,Ptr,Animal);
  129.     Bottom := Bottom + 1;
  130.     rec := rec + 1;
  131.     list_table[bottom ] := Animal;
  132.     WITH Animal DO
  133.       BEGIN
  134.         dis(4,L,name);
  135.         dis(30,L,Ear_no);
  136.         dis(45,L,sex);
  137.         yy := 0;
  138.         ww := 0;
  139.         dd := 0;
  140.         verify_date(Date_Born,ok2);
  141.         if ok2 then
  142.         begin
  143.           verify_date(Date_Died,ok2);
  144.           if ok2 then age(Date_Born,Date_Died,yy,ww,dd)
  145.                  else age(Date_Born,Date,yy,ww,dd);
  146.           gotoxy(50,L);
  147.           if yy > 0 then write(YY:2,' Years',ww:3,' Weeks',dd:3,' Days')
  148.                     else write(ww:2,' Weeks',dd:3,' Days');
  149.         end;
  150.       END;
  151.     L := L + 1;
  152.     IF (l = 16) or (Rec = LD) then
  153.         BEGIN
  154.           i := 4;
  155.           f_table;
  156.           REPEAT
  157.             movecurs(ch,i);
  158.             select(74,17,' ',BL,Ch);
  159.             IF ch = #27 THEN goto escape;
  160.               k := 0;
  161.               val(ch,k,yes);
  162.               IF k IN [1..6]
  163.               THEN
  164.                 Animals_table(k,list_table[i-3]);
  165.           UNTIL (ch = 'N') OR (ch = 'B');
  166.           IF ch = 'B'
  167.             THEN
  168.               BEGIN
  169.                 rec := rec - (12 + bottom);
  170.                 for i := 1 to 12 + bottom do
  171.                   PrevKey(EarIndexFile,Ptr,Ear);
  172.                 IF rec < 1
  173.                   THEN Rec := 1;
  174.               END;
  175.           if rec = UsedRecs(DatF) then rec := 1;
  176.           Ptr := Rec;
  177.           Bottom := 0;
  178.           ClearFrame;
  179.           l := 4;
  180.         END;
  181.   UNTIL (ch = #27);
  182.   escape:
  183. END;
  184.  
  185.