home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug027.arc / GENERAL1.INC < prev    next >
Text File  |  1979-12-31  |  2KB  |  115 lines
  1. PROCEDURE Initialize( VAR Animal : Animal_rec);
  2. BEGIN
  3.   WITH Animal DO
  4.     BEGIN
  5.       Rec_No         := -1;
  6.       Ear_No         := '';
  7.       Name           := '';
  8.       Sex            := 'M';
  9.       Date_Born      := '__ ___ 19__';
  10.       Date_died      := '__ ___ 19__';
  11.       Sire           := '!000M';
  12.       Dam            := '!000F';
  13.       Comment_1      := '';
  14.       Comment_2      := '';
  15.       Comment_3      := '';
  16.       Date_Mated     := '__ ___ 19__';
  17.       Partner        := '';
  18.     END;
  19. END;
  20.  
  21. PROCEDURE dis(x,y : INTEGER; s : anystr);
  22. BEGIN
  23.   GotoXY(x,y);
  24.   GotoXY(x,y);
  25.   Write(s);
  26. END;
  27.  
  28. PROCEDURE DisDate;
  29. BEGIN
  30.   dis(2,2,Date_Today);
  31. END;
  32.  
  33. FUNCTION UpcaseStr(S : Str80) : Str80;
  34. (*  UpcaseStr converts a string to upper case *)
  35.  
  36. VAR 
  37.   P : INTEGER;
  38. BEGIN
  39.   FOR P := 1 TO Length(S) DO
  40.     S[P] := UpCase(S[P]);
  41.   UpcaseStr := S;
  42. END;
  43.  
  44. PROCEDURE Beep;
  45. (*  Beep sounds the terminal bell or beeper *)
  46. BEGIN
  47.   Write(^G);
  48. END;
  49.  
  50. FUNCTION ConstStr(C : CHAR; N : INTEGER) : Str80;
  51. (*  ConstStr returns a string with N characters of value C *)
  52.  
  53. VAR 
  54.   S : STRING[80];
  55. BEGIN
  56.   IF N < 0
  57.     THEN
  58.       N := 0;
  59.   S[0] := Chr(N);
  60.   FillChar(S[1],N,C);
  61.   ConstStr := S;
  62. END;
  63.  
  64. PROCEDURE Select(    x,y    : INTEGER;
  65.                      Prompt : Str80;
  66.                      Term   : CharSet;
  67.                  VAR TC     : CHAR    );
  68.  
  69. VAR 
  70.   Ch : CHAR;
  71. BEGIN
  72.   GotoXY(x,y);
  73.   Write(Prompt,'?' );
  74.   ClrEOL;
  75.   REPEAT
  76.     Read(Kbd,Ch);
  77.     TC := UpCase(Ch);
  78.     IF NOT (TC IN Term)
  79.       THEN
  80.         Beep;
  81.   UNTIL TC IN Term;
  82.   Write(Ch);
  83. END;
  84.  
  85. PROCEDURE ClearFrame;
  86. (*  ClearFrame clears the display frame, I.E. Lines 3 to 14 *)
  87.  
  88. VAR 
  89.   I : INTEGER;
  90. BEGIN
  91.   GotoXY(1,4);
  92.   FOR I := 4 TO 15 DO
  93.     BEGIN
  94.       GotoXY(1,I);
  95.       ClrEOL ;
  96.     END;
  97. END;
  98.  
  99. PROCEDURE fillup(VAR s : str5);
  100. CONST
  101.   zeroes = '00000';
  102. VAR
  103.   i : INTEGER;
  104. BEGIN
  105.   s := copy(zeroes,1,5 - Length(s)) + s;
  106. END;
  107.  
  108. PROCEDURE Line(J : INTEGER);
  109. BEGIN
  110.   GotoXY(1,j);
  111.   Write(constStr(chr(129),79));
  112.   GotoXY(1,j+2);
  113.   Write(constStr(chr(128),79));
  114. END;
  115.