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 / TTFAMILY.INC < prev    next >
Text File  |  1979-12-31  |  3KB  |  113 lines
  1. OVERLAY PROCEDURE Family_Display(Date : str14);
  2.  
  3. LABEL
  4.   escape;
  5. const
  6.   MaxParents = 50;
  7.   MaxChildren = 500;
  8. TYPE
  9.   child_rec = RECORD
  10.                 parent    : str5;
  11.                 Ear_No    : str5;
  12.               END;
  13.  
  14. VAR
  15.   dummy     : str5;
  16.   rab,
  17.   rab_child : Animal_rec;
  18.   i,y       : INTEGER;
  19.   k         : INTEGER;
  20.   child     : ARRAY[1..MaxChildren] OF child_rec; {holds record no of childern}
  21.   parent    : ARRAY[1..MaxParents]  OF str5;      {holds parents ear number}
  22.   rec       : INTEGER;
  23.   parents   : INTEGER;
  24.   got       : BOOLEAN;
  25.   J         : INTEGER;
  26.  
  27. PROCEDURE check(dd : str5);
  28. BEGIN
  29.   got := FALSE;
  30.   FOR i := 1 TO parents  DO
  31.     IF parent[i] = dd
  32.       THEN got := TRUE;
  33.   IF NOT got
  34.     THEN
  35.       BEGIN
  36.         parent[i]  := dd;
  37.         parents := parents + 1;
  38.       END;
  39. END;
  40.  
  41. BEGIN
  42.   line(1);
  43.   dis(1,2,'                         D I S P L A Y      F A M I L Y');
  44.   print;
  45.   if ch <> #27 then
  46.   begin
  47.    line(1);
  48.    gotoxy(1,2);
  49.    Write(Q,date,'     F A M I L Y   of');
  50.    ClrEOL;
  51.    Write(Q,'    ',Animal.name,' ':20-Length(Animal.name));
  52.    y := 3;
  53.    parents := 1;
  54.    FOR i := 1 TO MaxParents DO parent[i] := '';
  55.    dummy := Animal.ear_no;
  56.    IF Animal.sex = 'M'
  57.      THEN Writeln(Q,'FATHER',dummy:10)
  58.      ELSE Writeln(Q,'MOTHER',dummy:10);
  59.    rec := 1;
  60.    J   := 0;
  61.    REPEAT
  62.      J := J + 1;
  63.      GetRec(DatF,J,Rab);
  64.      IF (rab.sire = dummy) THEN
  65.          BEGIN
  66.            check(rab.dam);
  67.            child[rec].parent := rab.dam;
  68.            child[rec].Ear_No := rab.Ear_No;
  69.            rec := rec + 1;
  70.          END;
  71.      IF (rab.dam  = dummy) THEN
  72.          BEGIN
  73.            check(rab.sire);
  74.            child[rec].parent := rab.sire;
  75.            Child[rec].Ear_No := Rab.Ear_No;
  76.            rec := rec + 1;
  77.          END;
  78.    UNTIL J = UsedRecs(DatF);
  79.    FOR k := 1 TO parents - 1 DO
  80.      BEGIN
  81.        FindKey(EarIndexFile,J,parent[k]);
  82.        GetRec(DatF,J,Rab);
  83.        y := y + 1;
  84.        Writeln(Q);
  85.        Write(Q,'    ',rab.name,' ':30-Length(rab.name));
  86.        IF (rab.sex = 'M')
  87.          THEN Write(Q,'FATHER')
  88.          ELSE Write(Q,'MOTHER');
  89.        Writeln(Q,rab.ear_no:10);
  90.        FOR i := 1 TO rec -1 DO
  91.          BEGIN
  92.            IF rab.ear_no  = child[i].parent THEN
  93.                BEGIN
  94.                  FindKey(EarIndexFile,J,child[i].Ear_No);
  95.                  GetRec(DatF,J,rab_child);
  96.                  Write(Q,' ':14,rab_child.name,' ':20-Length(rab_child.name));
  97.                  Write(Q,rab_child.sex:3);
  98.                  Writeln(Q,rab_child.ear_no:7);
  99.                  y := y + 1;
  100.                END;
  101.          END;
  102.      END; {For K := 1 to parents}
  103.   Writeln;
  104.   Writeln;
  105.   end;
  106.   escape:
  107.   ASSIGN(Q,'CON:');
  108.   REWRITE(Q);
  109.   Write('Press RETURN to continue ':50);
  110.   Readln;
  111.   ch := ^M;
  112. END;
  113.