home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TP4PROCS.ZIP / TP4PROCS.PAS
Encoding:
Pascal/Delphi Source File  |  1989-01-11  |  48.3 KB  |  1,420 lines
  1. UNIT tp4procs;
  2.  
  3. INTERFACE
  4.  
  5. USES dos,crt;
  6.  
  7. {$V-,R-}
  8.  
  9. TYPE
  10.  
  11. {$IFOPT N-}
  12. double = real;   { No 8087 calculations. Default }
  13. {$ELSE}
  14. real = single;   { 8087 mode }
  15. {$ENDIF}
  16.  
  17. str255   = STRING[255];
  18. str80   = STRING[80];
  19. str8   = STRING[8];
  20. date   = str8;
  21. eurodate   = str8;
  22. videopointer   = ARRAY[1..3840] OF Char;
  23. videoaddr   = ^videopointer;
  24. keyarr   = ARRAY[1..40] OF Integer;
  25.  
  26. ln   = ARRAY[0..128, 1..3] OF Byte;
  27. lincolarr   = ^ln;
  28.  
  29. {---------------------------------------------------------------------------}
  30. CONST
  31.  
  32.   { Scan code/Ascii code key definitions }
  33.   cr   = $1c0d;               { cr to exit}
  34.   esc   = $011b;              { esc to exit}
  35.   right   = $4d00;            { move cursor right}
  36.   left   = $4b00;             { mover cursor left}
  37.   up   = $4800;               { up arrow key}
  38.   down   = $5000;             { down key}
  39.   ins   = $5200;              { insert mode on}
  40.   del   = $5300;              { delete char at cursor}
  41.   back   = $0e08;             { delete previous character}
  42.   home   = $4700;             { goto start of string}
  43.   end   = $4f00;              { goto end in string}
  44.   cright   = $7400;           { ctrl right}
  45.   cleft   = $7300;            { ctrl left}
  46.   chome   = $7700;            { ctrl home}
  47.   cend   = $7500;             { ctrl end}
  48.   cpgup   = -31744; {h8400}   { ctrl pgup}
  49.   cpgdn   = $7600;            { ctrl pgdn}
  50.   tab   = $0f09;              { tab down}
  51.   btab   = $0f00;             { tab up}
  52.   f1   = $3b00;               { F1}
  53.   f2   = $3c00;               { F2}
  54.   f3   = $3d00;               { F3}
  55.   f4   = $3e00;               { F4}
  56.   f5   = $3f00;               { F5}
  57.   f6   = $4000;               { F6}
  58.   f7   = $4100;               { F7}
  59.   f8   = $4200;               { F8}
  60.   f9   = $4300;               { F9}
  61.   f10   = $4400;              { F10}
  62.   pgdn   = $5100;             { Pg Down}
  63.   pgup   = $4900;             { Pg Up}
  64.   period   = $342e;           { Period}
  65.   nul   = $0;
  66.  
  67.   { The following array MUST be terminated by a 0 }
  68.   { If you wish for any of the GETfield routines to exit, you must
  69.   put the key in this array and then check it in the variable param
  70.   "lastkey  " }
  71.  
  72.   keys   : keyarr   = (cleft, chome, cpgup, btab, up, cright, cend,
  73.     cpgdn, cr, tab, down, esc, pgdn, pgup,
  74.     f1, f2, f3, f4, f5, f6, f7, f8, f9, f10,
  75.     left, right, del, ins, home, end, back,
  76.     nul, nul, nul, nul, nul, nul, nul, nul, 0);
  77.  
  78.   startcursor   : Integer = 1; { Default initial cursor position in field }
  79.   hidden   : Boolean = False;  { True to not display a field }
  80.                                { Is always reset back to false after exiting
  81.                                  a GETxxx field procedure }
  82.   {---------------------------------------------------------------------------}
  83. VAR
  84.   { Variables set by various functions to control screen display and entry }
  85.  
  86.   video : Videoaddr  ;      { Video monitor address $B800 or $B000 }
  87.   screen : Integer;         { Current Screen number }
  88.   numfield : Integer;       { Number of fields in current screen }
  89.   fieldnum : Integer;       { Current field number }
  90.   inpmode : Boolean;        { TRUE if we are inputing in to a field
  91.                               FALSE if we are displaying only }
  92.   lastkey : Integer;        { Last key pressed to exit a field }
  93.   exit : Boolean;           { TRUE to exit the current screen }
  94.   exitcursor : Integer;     { Last cursor position when exiting GETITEM }
  95.  
  96.   r : registers;            { Register variable declaration }
  97.   clear25 : Boolean;        { TRUE if line 25 has a message on it }
  98.   beepon : Boolean;         { TRUE if you wish to have beeping for errors }
  99.   snow : Boolean;           { True if monitor card makes snow. Determined
  100.                               by GETVIDEO procedure below }
  101.   speed, flash : Text;    { Used if calling Flashup or Speed Screen }
  102.   lincol : lincolarr  ;
  103.   ok : Boolean;
  104.   autohelp : Boolean;       {Display associated help automatically
  105.                              if using Flash-Up }
  106.   helpcount : Word;         { Number of help windows up. See display_help
  107.                               and clear_help procedures in main program }
  108.  
  109.   { Comments on the procedures below may be found at the start of
  110.     each implementation }
  111.   FUNCTION inarray(key : Integer; VAR k : keyarr  ) : Boolean;
  112.   PROCEDURE beep(beepon : Boolean);
  113.   PROCEDURE color(foregr, backgr : Byte);
  114.   PROCEDURE cursoron;
  115.   PROCEDURE cursoroff;
  116.   PROCEDURE cursorhalf;
  117.   PROCEDURE cursornormal;
  118.   PROCEDURE dispmessage(message : str80  );
  119.   PROCEDURE replicate(VAR varname : str80  ; num : Integer; achar : Char);
  120.   PROCEDURE clearmessage;
  121.   PROCEDURE getvideo(VAR video : videoaddr  );
  122.   PROCEDURE videooff;
  123.   PROCEDURE videoon;
  124.   PROCEDURE display_screen(screen_name : str80  ; video : videoaddr  ;
  125.             VAR exist : Boolean; speed:Boolean);
  126.   PROCEDURE inkey(VAR key : Integer);
  127.   PROCEDURE clearkbd;
  128.   PROCEDURE fixnum(VAR temp_item : str80  );
  129.   FUNCTION date_check(datevar : date  ) : Boolean;
  130.   FUNCTION checkdate(datefield, date_low, date_high : date  ) : Boolean;
  131.   FUNCTION checkeurodate(datefield, datelow, datehigh : eurodate  ) : Boolean;
  132.   PROCEDURE getfield(
  133.                   ftype : Char;
  134.                   VAR field : str80  ;
  135.                   lin, col, len : Integer;
  136.                   pict : str80  ;
  137.                   inpmode : Boolean;
  138.                   fgr, bgr : Byte;
  139.                   VAR lastkey : Integer
  140.                   );
  141.   PROCEDURE getstr(VAR fieldname : str80  ; lin, col, len : Integer;
  142.             picture : str80  ; inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  143.   PROCEDURE getmemo(VAR fieldname : str80  ; lin, col, len : Integer;
  144.             picture : str80  ; inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  145.   PROCEDURE getdt(VAR fieldname : date  ; lin, col : Integer;
  146.             inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  147.   PROCEDURE geteurodate(VAR fieldname : eurodate  ; lin, col : Integer;
  148.             inpmode : Boolean;
  149.             fgr, bgr : Byte; VAR lastkey : Integer);
  150.   PROCEDURE getint(VAR fieldname : Integer; lin, col, len : Integer;
  151.             inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  152.   PROCEDURE getlong(VAR fieldname : Longint; lin, col, len : Integer;
  153.             inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  154.   PROCEDURE getreal(VAR fieldname : Real; lin, col, len, decimal : Integer;
  155.             inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  156.   PROCEDURE getdouble(VAR fieldname : Double; lin, col, len, decimal : Integer;
  157.             inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  158.   PROCEDURE getyn(VAR fieldname : Boolean; lin, col : Integer;
  159.             inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer);
  160.   FUNCTION get_value(fieldname : str255  ; nthstring : Integer) : str80  ;
  161.   PROCEDURE getupfield(lincol: lincolarr  );
  162.   PROCEDURE getdownfield(lincol: lincolarr  );
  163.   PROCEDURE getleftfield(lincol: lincolarr  );
  164.   PROCEDURE getrightfield(lincol: lincolarr  );
  165.  
  166. IMPLEMENTATION
  167.   {---------------------------------------------------------------------------}
  168.   {* FUNCTION inarray(key : Integer; VAR k : keyarr  ) : Boolean; *}
  169.   FUNCTION inarray;
  170.     { True if "key" is in "k" array else return false. }
  171.     { Last elment in "k" must be 0 }
  172.   VAR
  173.     i : Integer;
  174.   BEGIN
  175.   i := 1;
  176.   WHILE (k[i] <> 0) AND (k[i] <> key) DO i := i+1;
  177.   inarray := (k[i] <> 0);
  178.   END;
  179.  
  180.   {---------------------------------------------------------------------------}
  181.   {* PROCEDURE beep(beepon : Boolean); *}
  182.   PROCEDURE beep;
  183.   BEGIN
  184.   IF beepon THEN Write(Chr(7));
  185.   END;
  186.  
  187.   {---------------------------------------------------------------------------}
  188.   {* PROCEDURE color(foregr, backgr : Byte); *}
  189.   PROCEDURE color;
  190.     { Select current color by setting Foreground and Background
  191.     Any values between 0 and 15 are acceptable. See Tech Ref Manual
  192.     }
  193.   BEGIN
  194.   IF backgr > 7 THEN foregr := foregr+16;
  195.   TextColor(foregr); TextBackground(backgr);
  196.   END;
  197.  
  198.   {---------------------------------------------------------------------------}
  199.   PROCEDURE cursoron;
  200.     { Turn cursor on }
  201.   BEGIN
  202.   r  .ah := 3;                  { get cursor type in r  .cx }
  203.   Intr($10, r  );
  204.   r  .ah := 1;
  205.   r  .ch := r  .ch AND $0f;
  206.   Intr($10, r  );
  207.   END;
  208.  
  209.   {---------------------------------------------------------------------------}
  210.   PROCEDURE cursoroff;
  211.     { Turn cursor off }
  212.   BEGIN
  213.   r  .ah := 3;
  214.   Intr($10, r  );               { get cursor type in r  .cx }
  215.   r  .ah := 1;
  216.   r  .ch := r  .ch AND $0f;
  217.   r  .ch := r  .ch OR $30;        { set cursor blink bits to no cursor }
  218.   Intr($10, r  );
  219.   END;
  220.  
  221.   {---------------------------------------------------------------------------}
  222.   PROCEDURE cursorhalf;
  223.     { Set cursor to half size }
  224.   VAR
  225.     monitortype : Byte;
  226.   BEGIN
  227.   r  .ah := 15;
  228.   Intr($10, r  );
  229.   monitortype := r  .al;
  230.   r  .ah := 3;
  231.   Intr($10, r  );
  232.   IF monitortype = 7 THEN
  233.     BEGIN
  234.     r  .cl := $0c;              { Monochrome monitor }
  235.     r  .ch := r  .ch AND $f0;
  236.     r  .ch := r  .ch OR $06;
  237.   END ELSE
  238.     BEGIN
  239.     r  .cl := $07;              { Graphics monitor }
  240.     r  .ch := r  .ch AND $f0;
  241.     r  .ch := r  .ch OR $03;
  242.     END;
  243.   r  .ah := 1;
  244.   Intr($10, r  );
  245.   END;
  246.  
  247.   {---------------------------------------------------------------------------}
  248.   PROCEDURE cursornormal;
  249.     { Set cursor to normal size }
  250.   VAR
  251.     monitortype : Byte;
  252.   BEGIN
  253.   r  .ah := 15;
  254.   Intr($10, r  );
  255.   monitortype := r  .al;
  256.   r  .ah := 3;
  257.   Intr($10, r  );
  258.   IF monitortype = 7 THEN
  259.     BEGIN
  260.     r  .cl := $0c;              { Monochrome monitor }
  261.     r  .ch := r  .ch AND $f0;
  262.     r  .ch := r  .ch OR $0b;
  263.   END ELSE
  264.     BEGIN
  265.     r  .cl := $07;              { Graphics monitor }
  266.     r  .ch := r  .ch AND $f0;
  267.     r  .ch := r  .ch OR $06;
  268.     END;
  269.   r  .ah := 1;
  270.   Intr($10, r  );
  271.   END;
  272.  
  273.   {---------------------------------------------------------------------------}
  274.   { PROCEDURE dispmessage(message : str80  ); }
  275.   { Display a message on line 25 and set the Clear25   flag to true }
  276.   PROCEDURE dispmessage;
  277.   VAR
  278.     center : Integer;
  279.   BEGIN
  280.   beep(beepon  );
  281.   clear25   := True;
  282.   center := (80-Length(message)) DIV 2;
  283.   color(0, 7);
  284.   cursoroff;
  285.   GoToXY(center, 25);
  286.   Write(' ', message, ' ');
  287.   clearkbd;
  288.   cursoron;
  289.   END;
  290.  
  291.   {---------------------------------------------------------------------------}
  292.   { PROCEDURE replicate(VAR varname : str80  ; num : Integer; achar : Char); }
  293.   { Replicate the "achar", "num" times }
  294.   PROCEDURE replicate;
  295.   BEGIN
  296.   varname := '';
  297.   WHILE (num > 0) DO
  298.     BEGIN
  299.     varname := varname+achar;
  300.     num := num-1;
  301.     END;
  302.   END;
  303.  
  304.   {---------------------------------------------------------------------------}
  305.   PROCEDURE clearmessage;
  306.     { If "clear25  " is TRUE clear line 25 }
  307.   VAR
  308.     blanks : str80  ;
  309.   BEGIN
  310.   IF clear25   THEN
  311.     BEGIN
  312.     clear25   := False;
  313.     replicate(blanks, 79, ' ');
  314.     cursoroff;
  315.     GoToXY(1, 25);
  316.     Write(blanks);
  317.     cursoron;
  318.     END;
  319.   END;
  320.  
  321.   {---------------------------------------------------------------------------}
  322.   { PROCEDURE getvideo(VAR video : videoaddr  ); }
  323.   { Determine the type of video by returning the video address in video }
  324.   { Also set "snow  " to True if CGA, False if EGA  or Monochrome }
  325.   PROCEDURE getvideo;
  326.   BEGIN
  327.   r  .ah := 15;
  328.   Intr($10, r  );
  329.   IF r  .al = 7 THEN
  330.     BEGIN
  331.     video := Ptr($b000, 0);
  332.     snow   := False;
  333.   END ELSE
  334.     IF r  .al IN [2, 3] THEN
  335.       BEGIN
  336.       video := Ptr($b800, 0);
  337.       { -- Check if EGA to avoid checking for snow }
  338.       r  .ah := $12;
  339.       r  .cx := 0;
  340.       r  .bl := $10;
  341.       Intr($10, r  );
  342.       IF r  .cx = 0 THEN
  343.         snow   := True        { Regular Graphics card }
  344.       ELSE
  345.         snow   := False;      { EGA card }
  346.     END ELSE
  347.       BEGIN
  348.       WriteLn; WriteLn('Invalid mode'); Halt;
  349.       END;
  350.   END;
  351.  
  352.   {---------------------------------------------------------------------------}
  353.   PROCEDURE videooff;
  354.     { Turn video off if a graphics with snow card }
  355.   BEGIN
  356.   IF snow   THEN Port[$3d8] := 1;
  357.   END;
  358.  
  359.   {---------------------------------------------------------------------------}
  360.   PROCEDURE videoon;
  361.     { Turn video on if a graphics with snow card }
  362.   VAR
  363.     von   : Byte;
  364.   BEGIN
  365.   IF snow   THEN
  366.     BEGIN
  367.     von   := Mem[$40:$65];
  368.     Port[$3d8] := von  ;
  369.     END;
  370.   END;
  371.  
  372.   {---------------------------------------------------------------------------}
  373.   { PROCEDURE display_screen(screen_name : str80  ; video : videoaddr  ;
  374.   VAR exist : Boolean; speed:Boolean); }
  375.   PROCEDURE display_screen;
  376.     { Display screen from disk. The screen must be an   R file. }
  377.     { See below if using Speed Screen(tm). }
  378.   VAR
  379.     bload : ARRAY[1..3968] OF Char;
  380.     scrname : FILE;
  381.   BEGIN
  382.   IF speed THEN               { Use speed screen if "speed" is TRUE }
  383.     BEGIN
  384.     GoToXY(1, 1);
  385.     Write(speed  , '~x:s=', screen_name, '/');
  386.     exist := True;
  387.   END ELSE
  388.     BEGIN
  389.     Assign(scrname, screen_name);
  390.     {$I-} Reset(scrname);     {$I+}
  391.     exist := False;
  392.     IF IOResult = 0 THEN
  393.       BEGIN
  394.       exist := True;
  395.       BlockRead(scrname, bload[1], FileSize(scrname));
  396.       Close(scrname);
  397.       videooff;
  398.       Move(bload[8], video  ^, 3840);
  399.       videoon;
  400.       END;
  401.     END;
  402.   END;
  403.  
  404.   {---------------------------------------------------------------------------}
  405.   { PROCEDURE inkey(VAR key : Integer); }
  406.   PROCEDURE inkey;
  407.     { Get a keystroke. "key" contains the scan,ascii code. }
  408.   BEGIN
  409.   r  .ah := 0;
  410.   Intr($16, r  );               { call BIOS to get key }
  411.   key := r  .ax;
  412.   END;
  413.  
  414.   {---------------------------------------------------------------------------}
  415.   PROCEDURE clearkbd;
  416.     { Clear keyboard buffer }
  417.   VAR
  418.     clear : Boolean;
  419.   BEGIN
  420.   REPEAT
  421.   r  .ah := 1;
  422.   Intr($16, r  );                    { call BIOS to check for a key }
  423.   IF (r  .flags AND $0040) = 0 THEN
  424.     clear := True                    { clear the keyboard }
  425.   ELSE
  426.     clear := False;                  { no keys to clear }
  427.   IF clear THEN
  428.     BEGIN
  429.     r  .ah := 0;                     { pull key from buffer }
  430.     Intr($16, r  );
  431.     END;
  432.   UNTIL NOT clear;
  433.   END;
  434.  
  435.   {---------------------------------------------------------------------------}
  436.   { PROCEDURE fixnum(VAR temp_item : str80  ); }
  437.   PROCEDURE fixnum;
  438.     { Strip blanks on both sides of temp_item. Called onlly for numerics. }
  439.   VAR
  440.     i, j : Byte;
  441.   BEGIN
  442.   IF temp_item <> '' THEN
  443.     BEGIN
  444.     j := Length(temp_item);
  445.     { Strip Leading Blanks }
  446.     i := 0;
  447.     WHILE (temp_item[i+1] = ' ') AND (i < j) DO i := i+1; { strip leading blanks }
  448.     IF (i > 0) AND (i < j) THEN temp_item := Copy(temp_item, i+1, j-i)
  449.     ELSE IF (i = j) AND (temp_item[j] = ' ') THEN temp_item := '';
  450.     i := Pos(' ', temp_item); { strip trailing blanks }
  451.     IF i <> 0 THEN temp_item := Copy(temp_item, 1, i-1);
  452.     IF temp_item[Length(temp_item)] = '.' THEN temp_item := temp_item+'0';
  453.     END;
  454.   END;                        { fixnum procedure }
  455.  
  456.   {---------------------------------------------------------------------------}
  457.   { FUNCTION date_check(datevar : date  ) : Boolean; }
  458.   FUNCTION date_check;
  459.     { Checks For Date Validity including leap year
  460.     IF datevar is correct THEN date_check is True }
  461.     CONST
  462.       month_days:ARRAY[1..12] OF Integer = (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  463.   VAR mm, dd, yy : STRING[2];
  464.     mmi, ddi, yyi : Integer;
  465.     error : Integer;
  466.     ch_date : Boolean;
  467.     year : Integer;
  468.   BEGIN
  469.   IF Ord(datevar[0]) <> 8 THEN
  470.     BEGIN
  471.     date_check := False
  472.   END ELSE
  473.     BEGIN
  474.     ch_date := True;
  475.     mm := Copy(datevar, 1, 2);
  476.     dd := Copy(datevar, 4, 2);
  477.     yy := Copy(datevar, 7, 2);
  478.     Val(mm, mmi, error);
  479.     IF (error <> 0) OR (mmi < 1) OR (mmi > 12) THEN ch_date := False;
  480.     IF ch_date THEN
  481.       BEGIN
  482.       Val(dd, ddi, error);
  483.       IF (error <> 0) OR (ddi < 1) OR (ddi > month_days[mmi]) THEN ch_date := False;
  484.       END;
  485.     IF ch_date THEN
  486.       BEGIN
  487.       Val(yy, yyi, error);
  488.       IF error <> 0 THEN ch_date := False;
  489.       END;
  490.     IF ch_date THEN
  491.       IF (mmi = 2) AND (ddi > 28) THEN { Check for leap year }
  492.         BEGIN
  493.         year := 1900+yyi;
  494.         IF NOT((year MOD 4 = 0) AND
  495.         (year MOD 100 <> 0) OR (year MOD 400 = 0)) THEN
  496.           ch_date := False;
  497.         END;
  498.     date_check := ch_date;
  499.     END;
  500.   END;                        { PROCEDURE DATE_CHECK }
  501.  
  502.   {---------------------------------------------------------------------------}
  503.   { FUNCTION checkdate(datefield, date_low, date_high : date  ) : Boolean; }
  504.   FUNCTION checkdate;
  505.     { Check Validity If Date and whether it falls between low and high }
  506.     { If low range date is higer than high range date then we assume }
  507.     { we crossed centuries eg. 09/09/84 to 01/01/10 }
  508.     { Also a null date is ignored }
  509.   VAR
  510.     ch_date : Boolean;
  511.   CONST
  512.     datenull = '  /  /  ';
  513.   BEGIN
  514.   IF datefield <> datenull THEN ch_date := date_check(datefield) ELSE ch_date := True;
  515.   IF ch_date AND (datefield <> datenull) AND (date_low <> datenull) AND (date_high <> datenull) THEN
  516.     BEGIN
  517.     IF ch_date THEN ch_date := date_check(date_low);
  518.     IF ch_date THEN ch_date := date_check(date_high);
  519.     IF ch_date THEN
  520.       BEGIN
  521.       datefield := Copy(datefield, 7, 2)+Copy(datefield, 1, 6);
  522.       date_low := Copy(date_low, 7, 2)+Copy(date_low, 1, 6);
  523.       date_high := Copy(date_high, 7, 2)+Copy(date_high, 1, 6);
  524.       IF (date_low <= date_high) THEN { Low Date < High Date }
  525.         BEGIN
  526.         IF (datefield < date_low) OR (datefield > date_high) THEN ch_date := False
  527.       END ELSE                { Low Date  > High Date }
  528.         IF (datefield < date_low) AND (datefield > date_high) THEN ch_date := False;
  529.       END;
  530.     END;
  531.   checkdate := ch_date;
  532.   END;
  533.  
  534.  
  535.   {---------------------------------------------------------------------------}
  536.   { FUNCTION checkeurodate(datefield, datelow, datehigh : eurodate  ) : Boolean;}
  537.   { Check European style date. DD/MM/YY }
  538.   FUNCTION checkeurodate;
  539.   VAR tempchar : Char;
  540.   BEGIN
  541.   datefield := Copy(datefield, 4, 3)+Copy(datefield, 1, 3)+Copy(datefield, 7, 2);
  542.   datelow := Copy(datelow, 4, 3)+Copy(datelow, 1, 3)+Copy(datelow, 7, 2);
  543.   datehigh := Copy(datehigh, 4, 3)+Copy(datehigh, 1, 3)+Copy(datehigh, 7, 2);
  544.   checkeurodate := checkdate(datefield, datelow, datehigh);
  545.   END;
  546.  
  547.   {---------------------------------------------------------------------------}
  548.   {===========================================================================}
  549.   (* Displays the current value of "field" at "lin" and "col" using "bgr" and
  550.   "fgr" for color.
  551.   Allows data entry if inpmode is TRUE.
  552.   The default starting cursor position is specified in "startcursor  "
  553.   Uses all editing keys as defined in the "editkeyarr  " array.
  554.   Checks for picture masks as defined by "pict" while typing.
  555.   Cannot exit the "len" of the field.
  556.   Returns "lastkey" pressed on exit.
  557.   Set the global "exitcursor  " to the last cursor position on exit.
  558.  
  559.   PROCEDURE getfield(
  560.                   ftype : Char;            { Type: S,R,G,B,I,L,D,E }
  561.                   VAR field : str80  ;     { Field name }
  562.                   lin, col, len : Integer; { line, column and length of field}
  563.                   pict : str80  ;          { picture mask }
  564.                   inpmode : Boolean;       { TRUE to allow data entry}
  565.                   fgr, bgr : Byte;         { fore abd background color }
  566.                   VAR lastkey : Integer    { lastkey pressed to exit }
  567.                   );
  568.   *)
  569.   PROCEDURE getfield;
  570.  
  571.   TYPE
  572.     pict_type = SET OF Char;
  573.  
  574.   CONST
  575.     pict_elements : pict_type = ['X', '!', 'Y', '#', '9', 'A', 'N', 'L'];
  576.     hidchar = #254;
  577.  
  578.   VAR
  579.     endcol,                   { end column within field }
  580.     startcol,                 { start column within field }
  581.     hcol,                     { horizontal column of cursor on screen }
  582.     pcol,                     { cursor position in field }
  583.     i, j, ilen : Byte;        { Assorted temp variables }
  584.  
  585.     decimal,                  { decimal position from the right }
  586.     keycode : Integer;        { temp variable for keys pressed }
  587.  
  588.     insert_mode,              { True if in insert mode }
  589.     end_of_field, begin_of_field, {True if try to move cursor past
  590.                                   end or begin of field }
  591.     modified,                 { True if field was modified }
  592.     int_flag,                 { True if this is an number with no decimals }
  593.     dec_flag,                 { True if this is a number with decimals }
  594.     special : Boolean;        { True if key pressed was an exiting or help key
  595.                               Note: All keys in the keyarrays above exit
  596.                               except for the editing keys. }
  597.  
  598.     temp_item,
  599.     wfield : str80  ;         { Work field for item }
  600.  
  601.     kchar : Char;             { Temporary character field }
  602.  
  603.     { Function to get a key from the keyboard. Checks allowable
  604.     key according to picture mask before returning. If not allowed
  605.     then prints error message on line 25 }
  606.     FUNCTION getchar(ctype : Char; VAR keycode : Integer) : Boolean;
  607.       { If getchar=true on return then keycode is in "key  "}
  608.       { If getchar=false on return then keycode is alpha numeric}
  609.       { ctype must be one of the following:
  610.         'X', '!', 'Y', '#', '9', 'A', 'N', 'L'}
  611.     VAR
  612.       tempp, tempc, tempm, ascii : Char;
  613.       scan : Byte;
  614.       correct : Boolean;
  615.     BEGIN
  616.     keycode := 0;
  617.  
  618.     REPEAT
  619.  
  620.     getchar := False;
  621.     correct := False;
  622.     inkey(keycode);
  623.  
  624.     { Clear Line 25 if a message was there }
  625.     color(7, 0);
  626.     clearmessage;
  627.     GoToXY(hcol, lin);
  628.     color(fgr, bgr);
  629.  
  630.     IF inarray(keycode, keys  ) THEN
  631.       BEGIN
  632.       correct := True;        { Exit Getchar }
  633.       getchar := True;        { TRUE means it is a special key }
  634.     END ELSE
  635.       BEGIN
  636.       scan := keycode DIV 256;
  637.       ascii := Chr(keycode AND $00ff);
  638.       IF (ascii >= ' ') AND (ascii <= '~') AND (scan <> 0) THEN
  639.         CASE ctype OF
  640.           'X' : correct := True;
  641.           '!' : BEGIN
  642.                 IF ascii IN ['a'..'z'] THEN ascii := Chr(Ord(ascii) AND $df);
  643.                 keycode := scan*256+Ord(ascii);
  644.                 correct := True;
  645.                 END;
  646.           'Y' : BEGIN
  647.                 IF ascii IN ['Y', 'N', 'y', 'n'] THEN
  648.                   BEGIN
  649.                   ascii := Chr(Ord(ascii) AND $df);
  650.                   keycode := scan*256+Ord(ascii);
  651.                   correct := True;
  652.                 END ELSE
  653.                   dispmessage('Only Y,N');
  654.                 END;
  655.           'L' : BEGIN
  656.                 IF ascii IN ['T', 'F', 't', 'f', 'Y', 'N', 'y', 'n'] THEN
  657.                   BEGIN
  658.                   ascii := Chr(Ord(ascii) AND $df);
  659.                   keycode := scan*256+Ord(ascii);
  660.                   correct := True;
  661.                 END ELSE
  662.                   dispmessage('Only T,F,Y,N');
  663.                 END;
  664.           '#' : BEGIN
  665.                 tempp := #0;
  666.                 tempc := #0;
  667.                 tempm := #0;
  668.                 IF dec_flag OR (ftype IN ['S','M']) THEN tempp := '.';
  669.                 IF (len-decimal >= 3) OR ((decimal = 0) AND (len >= 2))
  670.                   OR (ftype IN ['M','S']) THEN
  671.                   BEGIN
  672.                   tempc := '-';
  673.                   tempm := '+';
  674.                   END;
  675.                 IF ascii IN ['0'..'9', tempc, tempm, ' ', tempp] THEN correct := True
  676.                 ELSE
  677.                   IF tempc <> #0 THEN
  678.                     dispmessage('Only 0 thru 9, spaces and (-,+) allowed')
  679.                   ELSE
  680.                     dispmessage('Only 0 thru 9 and spaces allowed');
  681.                 END;
  682.           '9' : BEGIN
  683.                 tempp := #0;
  684.                 tempc := #0;
  685.                 tempm := #0;
  686.                 IF dec_flag OR int_flag THEN
  687.                   BEGIN
  688.                   IF dec_flag THEN tempp := '.';
  689.                   IF (len-decimal >= 3) OR ((decimal = 0) AND (len >= 2)) THEN
  690.                     BEGIN
  691.                     tempc := '-';
  692.                     tempm := '+';
  693.                     END;
  694.                   END;
  695.                 IF ascii IN ['0'..'9', tempp, tempc, tempm] THEN correct := True
  696.                 ELSE
  697.                   IF tempc <> #0 THEN
  698.                     dispmessage('Only 0 thru 9 and (-,+) allowed')
  699.                   ELSE
  700.                     dispmessage('Only 0 thru 9 allowed');
  701.                 END;
  702.           'A' : IF ascii IN ['a'..'z', 'A'..'Z', ' '] THEN correct := True
  703.                 ELSE dispmessage('Only alpha characters allowed');
  704.           'N' : IF ascii IN ['a'..'z', 'A'..'Z', '0'..'9', ' '] THEN correct := True
  705.                 ELSE dispmessage('Only alphanumeric characters allowed');
  706.         END;
  707.       END;
  708.     GoToXY(hcol, lin);
  709.     UNTIL correct;
  710.     END;                      { getchar function }
  711.  
  712.     PROCEDURE decrcol;
  713.       { Positions Cursor At the previous Non Edit Character }
  714.     VAR
  715.       elem_end : Boolean;
  716.       i : Byte;
  717.     BEGIN
  718.     IF hcol <> (col+startcol-1) THEN
  719.       BEGIN
  720.       i := pcol;
  721.       elem_end := False;
  722.       REPEAT
  723.       i := i-1;
  724.       IF (pict[i] IN pict_elements) OR (i < 1)
  725.       OR (dec_flag AND (pict[pcol+i-1] = '.')) THEN elem_end := True;
  726.       UNTIL elem_end;
  727.       IF i >= 1 THEN
  728.         BEGIN
  729.         hcol := hcol-(pcol-i);
  730.         pcol := i;
  731.         END;
  732.     END ELSE
  733.       begin_of_field := True;
  734.     END;                      { decrcol procedure }
  735.  
  736.     PROCEDURE incrcol;
  737.       { positions Cursor At the Next Non Edit Character }
  738.     VAR
  739.       elem_end : Boolean;
  740.       i : Byte;
  741.     BEGIN
  742.     IF hcol <> (col+len-1) THEN
  743.       BEGIN
  744.       i := 1; elem_end := False;
  745.       REPEAT
  746.       i := i+1;
  747.       IF (pict[pcol+i-1] IN pict_elements) OR (pcol+i > len)
  748.       OR (dec_flag AND (pict[pcol+i] = '.')) THEN elem_end := True;
  749.       UNTIL elem_end;
  750.       IF i <= len THEN
  751.         BEGIN
  752.         hcol := hcol+i-1;
  753.         pcol := pcol+i-1;
  754.         END;
  755.     END ELSE
  756.       end_of_field := True;
  757.     END;                      { incrcol procedure }
  758.  
  759.   BEGIN                       { Main Procedure Of getfield }
  760.  
  761.   wfield := field;            { Store Actual wfield In A Work Variable }
  762.   end_of_field := False;      { We havent moved past the start or end of field }
  763.   begin_of_field := False;
  764.   modified := False;          { Numeric field has not been modified }
  765.   insert_mode := False;       { insert mode is off }
  766.   cursornormal;               { Cursor is normal size }
  767.   keycode := 0;
  768.  
  769.   pcol := startcursor  ;      { Initialize to starting cursor position }
  770.  
  771.   i := Length(wfield);
  772.   { If picture and/or wfield size is less than length than
  773.   make them as big as length }
  774.   WHILE i < len DO
  775.     BEGIN
  776.     wfield := wfield+' ';
  777.     i := i+1;
  778.     END;
  779.  
  780.   IF (pict = '') THEN pict := 'X';
  781.   i := Length(pict);
  782.   kchar := pict[i];
  783.   WHILE i < len DO
  784.     BEGIN
  785.     pict := pict+kchar;
  786.     i := i+1;
  787.     END;
  788.  
  789.   { Determine if the picture is a numeric picture with a decimal point. }
  790.   dec_flag := False;
  791.   int_flag := False;
  792.   decimal := 0;
  793.   IF ftype IN ['I', 'R', 'G', 'B'] THEN
  794.     BEGIN
  795.     j := Pos('.', pict);
  796.     IF j > 0 THEN
  797.       BEGIN
  798.       decimal := len-j;
  799.       dec_flag := True;
  800.     END ELSE
  801.       int_flag := True;
  802.     END;
  803.  
  804.   {- Copy edit characters to wfield -}
  805.   FOR i := 1 TO len DO
  806.     IF NOT(pict[i] IN pict_elements) THEN wfield[i] := pict[i];
  807.  
  808.   {- Display The wfield on the screen -}
  809.   color(fgr, bgr);
  810.   cursoroff;
  811.   GoToXY(col, lin);
  812.   IF NOT hidden   THEN Write(wfield);
  813.   GoToXY(col, lin);
  814.   cursoron;
  815.  
  816.   {- Get Data From Screen If inpmode is True -}
  817.   IF inpmode THEN
  818.     BEGIN
  819.     { Determine the start and end column by skiping over
  820.     the hard coded picture elements e.g.  (999)  start=2 end=4 }
  821.     startcol := 1;
  822.     WHILE (NOT(pict[startcol] IN pict_elements)) AND (pcol <= len) DO
  823.       startcol := startcol+1;
  824.  
  825.     endcol := len;
  826.     WHILE (NOT(pict[endcol] IN pict_elements)) AND (endcol > startcol) DO
  827.       endcol := endcol-1;
  828.     ilen := len;              { Save length to reset before exiting getfield }
  829.     len := endcol;            { Get the lengt between col and end col}
  830.     pcol := startcol;
  831.     hcol := col+pcol-1;
  832.     j := startcursor  ;       { Get starting cursor global variable }
  833.     IF j > len THEN j := len; { If start out of field adjust to length }
  834.  
  835.     i := pcol;
  836.     WHILE i <= (j-1) DO       { Move cursor from startcol to startcursor }
  837.       BEGIN
  838.       IF NOT end_of_field THEN incrcol;
  839.       i := i+1;
  840.       END;
  841.  
  842.     IF (len >= startcol) THEN { if room between and end then get field }
  843.       BEGIN
  844.       hcol := col+pcol-1;
  845.       GoToXY(hcol, lin);      {* Go to location on screen*}
  846.       REPEAT
  847.       end_of_field := False;
  848.       begin_of_field := False;
  849.       special := False;
  850.  
  851.       IF NOT getchar(pict[pcol], keycode) THEN
  852.         BEGIN
  853.         { if it is not a period and not a numeric field }
  854.         IF (keycode <> period  ) OR NOT dec_flag THEN
  855.           BEGIN
  856.           kchar := Chr(Lo(keycode));
  857.           IF NOT insert_mode THEN
  858.             BEGIN
  859.             IF NOT hidden   THEN Write(kchar);
  860.             wfield[pcol] := kchar;
  861.           END ELSE
  862.             BEGIN
  863.             j := pcol+1;
  864.             WHILE (pict[j] IN pict_elements) AND (j <= len) DO
  865.               j := j+1;
  866.             j := j-1;
  867.             FOR i := j DOWNTO pcol+1 DO wfield[i] := wfield[i-1];
  868.             wfield[pcol] := kchar;
  869.             cursoroff;
  870.             GoToXY(col, lin);
  871.             IF NOT hidden   THEN Write(wfield);
  872.             END;
  873.           incrcol;
  874.           GoToXY(hcol, lin);
  875.           cursoron;
  876.           modified := True;
  877.         END ELSE
  878.           BEGIN
  879.           { decimal point allowed only on left side of decimal point}
  880.           { otherwise it is ignored }
  881.           IF pcol <= (len-decimal) THEN
  882.             BEGIN
  883.             temp_item := Copy(wfield, 1, pcol-1); { get integer }
  884.             wfield := Copy(wfield, (len-decimal+1), decimal); { get decimal }
  885.  
  886.             fixnum(temp_item);
  887.             IF temp_item = '' THEN temp_item := '0'; { at least a digit }
  888.             i := (len-decimal-1); { fill blanks on left }
  889.             WHILE Length(temp_item) < i DO
  890.               temp_item := ' '+temp_item;
  891.             cursoroff;
  892.             GoToXY(col, lin);
  893.             IF NOT hidden   THEN Write(temp_item); { display wfield }
  894.  
  895.             wfield := temp_item+'.'+wfield; { add to decimal side }
  896.             pcol := endcol-decimal+1; { set cursor columns }
  897.             hcol := col+pcol-1;
  898.             GoToXY(hcol, lin);
  899.             cursoron;
  900.             END;
  901.           END;
  902.       END ELSE
  903.         CASE keycode OF
  904.           left   : BEGIN
  905.                    decrcol;
  906.                    GoToXY(hcol, lin);
  907.                    END;       {Left}
  908.           right   : BEGIN
  909.                     incrcol;
  910.                     GoToXY(hcol, lin);
  911.                     END;      {Right}
  912.           del  ,
  913.           back   : BEGIN      {Delete}
  914.                    IF keycode = back   THEN
  915.                      BEGIN
  916.                      decrcol;
  917.                      begin_of_field := False;
  918.                      END;
  919.                    j := pcol+1; {FInd where the next edit char starts}
  920.                    WHILE (pict[j] IN pict_elements) AND (j <= len) DO
  921.                      j := j+1;
  922.                    j := j-1;  { i=start, j:=end}
  923.                    { Move chars left }
  924.                    FOR i := pcol TO j-1 DO
  925.                      BEGIN
  926.                      wfield[i] := wfield[i+1];
  927.                      END;
  928.                    { & put blank at end}
  929.                    wfield[j] := ' ';
  930.                    {rewrite the wfield}
  931.                    cursoroff;
  932.                    GoToXY(col, lin);
  933.                    IF NOT hidden   THEN Write(wfield);
  934.                    GoToXY(hcol, lin);
  935.                    cursoron;
  936.                    END;
  937.           ins   : BEGIN       {Insert}
  938.                   insert_mode := NOT insert_mode;
  939.                   IF insert_mode THEN cursorhalf ELSE cursornormal;
  940.                   END;
  941.           home   : BEGIN
  942.                    hcol := col+startcol-1;
  943.                    pcol := startcol;
  944.                    GoToXY(hcol, lin);
  945.                    END;
  946.           end   : BEGIN
  947.                   i := endcol;
  948.                   WHILE (wfield[i] = ' ') AND (i >= startcol) DO
  949.                     i := i-1;
  950.                   IF i < len THEN i := i+1;
  951.                   pcol := i;
  952.                   hcol := col+pcol-1;
  953.                   GoToXY(hcol, lin);
  954.                   WHILE (NOT(pict[pcol] IN pict_elements)) AND (pcol > 1) DO
  955.                     pcol := pcol-1;
  956.                   END;
  957.         ELSE
  958.         special := True;
  959.         END { Case keycode } ;
  960.       UNTIL end_of_field OR begin_of_field OR special;
  961.       END;
  962.     len := ilen;              { Put original length back }
  963.     END;
  964.  
  965.   { Strip Trailing Blanks for String types only }
  966.   IF ftype IN ['S','M'] THEN
  967.     BEGIN
  968.     i := len;
  969.     WHILE (wfield[i] = ' ') AND (i > 0) DO i := i-1;
  970.     wfield[0] := Chr(i);
  971.     END;
  972.  
  973.   { Fixup the number ofr numeric types only }
  974.   IF (ftype IN ['I', 'R', 'G', 'B']) AND modified THEN
  975.     BEGIN
  976.     i := pcol;
  977.     IF end_of_field THEN i := pcol ELSE i := pcol -1;
  978.     temp_item := Copy(wfield, 1, i);
  979.     fixnum(temp_item);
  980.     IF temp_item <> '' THEN wfield := temp_item;
  981.     END;
  982.  
  983.   cursornormal;
  984.  
  985.   exitcursor   := pcol;       { Last cursor column in field }
  986.  
  987.   field := wfield;            { Return result Back To witem }
  988.   if (inpmode) THEN lastkey := keycode; { Stuff the last key pressed }
  989.  
  990.   END;                        { getfield procedure}
  991.  
  992.   {===========================================================================}
  993.   { In the following procedures the parameters have the following meanings:
  994.  
  995.   ( Not all procedures have these parameters, because they make assumptions
  996.   about certain types of fields. All procedures however do call GETFIELD
  997.   which expects all the parameters.)
  998.  
  999.   fieldname = the variable name for the field
  1000.   lin,col,len = line, column, length of the field on screen
  1001.   picture = the picture of the field
  1002.   inpmode = TRUE if to display and get a field, FALSE to display only
  1003.   fgr,bgr = The attribute foreground and background colors (0-15) of the field
  1004.   lastkey = The Integer scan/ascii code OF the last key pressed
  1005.   }
  1006.  
  1007.   {---------------------------------------------------------------------------}
  1008.   { PROCEDURE getstr(VAR fieldname : str80  ; lin, col, len : Integer;
  1009.         picture : str80  ; inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1010.   { Gets a field of type string }
  1011.   PROCEDURE getstr;
  1012.   BEGIN
  1013.   IF Length(fieldname) > len THEN fieldname := Copy(fieldname, 1, len);
  1014.   getfield('S', fieldname, lin, col, len, picture, inpmode, fgr, bgr, lastkey);
  1015.   hidden   := False;
  1016.   END;
  1017.  
  1018.   {---------------------------------------------------------------------------}
  1019.   { PROCEDURE getmemo(VAR fieldname : str80  ; lin, col, len : Integer;
  1020.         picture : str80  ; inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1021.   PROCEDURE getmemo;
  1022.   BEGIN
  1023.   IF Length(fieldname) > len THEN fieldname := Copy(fieldname, 1, len);
  1024.   getfield('S', fieldname, lin, col, len, picture, inpmode, fgr, bgr, lastkey);
  1025.   hidden   := False;
  1026.   END;
  1027.  
  1028.   {---------------------------------------------------------------------------}
  1029.   { PROCEDURE getdt(VAR fieldname : date  ; lin, col : Integer;
  1030.         inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1031.   PROCEDURE getdt;
  1032.   VAR
  1033.     okdate : Boolean;
  1034.   CONST
  1035.     datenull = '  /  /  ';
  1036.   BEGIN
  1037.   REPEAT
  1038.   getfield('D', fieldname, lin, col, 8, '99/99/99', inpmode, fgr, bgr, lastkey);
  1039.   IF inpmode THEN
  1040.     BEGIN
  1041.     IF fieldname = '  /  /' THEN fieldname := datenull;
  1042.     okdate := checkdate(fieldname, fieldname, fieldname);
  1043.     IF NOT okdate THEN dispmessage('Invalid Date Entered');
  1044.   END ELSE okdate := True;
  1045.   UNTIL okdate;
  1046.   hidden   := False;
  1047.   END;
  1048.  
  1049.   {---------------------------------------------------------------------------}
  1050.   { PROCEDURE geteurodate(VAR fieldname : eurodate  ; lin, col : Integer;
  1051.         inpmode : Boolean; fgr, bgr : Byte; VAR lastkey : Integer); }
  1052.   PROCEDURE geteurodate;
  1053.   VAR
  1054.     okdate : Boolean;
  1055.   CONST
  1056.     datenull = '  /  /  ';
  1057.   BEGIN
  1058.   REPEAT
  1059.   getfield('D', fieldname, lin, col, 8, '99/99/99', inpmode, fgr, bgr, lastkey);
  1060.   IF inpmode THEN
  1061.     BEGIN
  1062.     IF fieldname = '  /  /' THEN fieldname := datenull;
  1063.     okdate := checkeurodate(fieldname, fieldname, fieldname);
  1064.     IF NOT okdate THEN dispmessage('Invalid European Date Entered');
  1065.   END ELSE okdate := True;
  1066.   UNTIL okdate;
  1067.   hidden   := False;
  1068.   END;
  1069.  
  1070.   {---------------------------------------------------------------------------}
  1071.   { PROCEDURE getint(VAR fieldname : Integer; lin, col, len : Integer;
  1072.         inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1073.   PROCEDURE getint;
  1074.   VAR picture : STRING[25];
  1075.     tempfield : STRING[25];
  1076.     tempreal : Real;
  1077.     err : Integer;
  1078.   BEGIN
  1079.   Str(fieldname:len, tempfield);
  1080.   IF length(tempfield) > len THEN
  1081.     BEGIN
  1082.     replicate(tempfield,len,'*');
  1083.     END;
  1084.   IF inpmode THEN
  1085.     BEGIN
  1086.     replicate(picture, len, '#');
  1087.     REPEAT
  1088.     getfield('I', tempfield, lin, col, len, picture, inpmode, fgr, bgr, lastkey);
  1089.     fixnum(tempfield);
  1090.     Val(tempfield, tempreal, err);
  1091.     err := 0;
  1092.     IF (tempreal < -32768.0) OR (tempreal > 32767.0) THEN
  1093.       BEGIN
  1094.       dispmessage(' Number must be within -32768 and 32767 range. ');
  1095.       err := 1;
  1096.       END;
  1097.     UNTIL err = 0;
  1098.     Val(tempfield, fieldname, err);
  1099.     Str(fieldname:len, tempfield);
  1100.     END;
  1101.   color(fgr, bgr);
  1102.   cursoroff;
  1103.   GoToXY(col, lin);
  1104.   IF NOT hidden   THEN Write(tempfield);
  1105.   GoToXY(col, lin);
  1106.   cursoron;
  1107.   hidden   := False;
  1108.   END;
  1109.  
  1110.   {---------------------------------------------------------------------------}
  1111.   { PROCEDURE getlong(VAR fieldname : Longint; lin, col, len : Integer;
  1112.         inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1113.   PROCEDURE getlong;
  1114.   VAR picture : STRING[25];
  1115.     tempfield : STRING[25];
  1116.     err : Integer;
  1117.     tempreal : Real;
  1118.   BEGIN
  1119.   Str(fieldname:len, tempfield);
  1120.   IF length(tempfield) > len THEN
  1121.     BEGIN
  1122.     replicate(tempfield,len,'*');
  1123.     END;
  1124.   IF inpmode THEN
  1125.     BEGIN
  1126.     replicate(picture, len, '#');
  1127.     REPEAT
  1128.     getfield('G', tempfield, lin, col, len, picture, inpmode, fgr, bgr, lastkey);
  1129.     fixnum(tempfield);
  1130.     Val(tempfield, tempreal, err);
  1131.     err := 0;
  1132.     IF (tempreal < -2147483648.0) OR (tempreal > 2147483647.0) THEN
  1133.       BEGIN
  1134.       dispmessage(' Number must be within -2147483648 and 2147483647 range. ');
  1135.       err := 1;
  1136.       END;
  1137.     UNTIL err = 0;
  1138.     Val(tempfield, fieldname, err);
  1139.     Str(fieldname:len, tempfield);
  1140.     END;
  1141.   color(fgr, bgr);
  1142.   cursoroff;
  1143.   GoToXY(col, lin);
  1144.   IF NOT hidden   THEN Write(tempfield);
  1145.   GoToXY(col, lin);
  1146.   cursoron;
  1147.   hidden   := False;
  1148.   END;
  1149.  
  1150.   {---------------------------------------------------------------------------}
  1151.   { PROCEDURE getreal(VAR fieldname : Real; lin, col, len, decimal : Integer;
  1152.         inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1153.   PROCEDURE getreal;
  1154.   VAR picture : STRING[25];
  1155.     tempfield : STRING[25];
  1156.     err : Integer;
  1157.   BEGIN
  1158.   Str(fieldname:len:decimal, tempfield);
  1159.   IF length(tempfield) > len THEN
  1160.     BEGIN
  1161.     replicate(tempfield,len,'*');
  1162.     END;
  1163.   IF inpmode THEN
  1164.     BEGIN
  1165.     replicate(picture, len, '#');
  1166.     IF decimal > 0 THEN picture[len-decimal] := '.';
  1167.     getfield('R', tempfield, lin, col, len, picture, inpmode, fgr, bgr, lastkey);
  1168.     fixnum(tempfield);
  1169.     Val(tempfield, fieldname, err);
  1170.     Str(fieldname:len:decimal, tempfield);
  1171.     END;
  1172.   color(fgr, bgr);
  1173.   cursoroff;
  1174.   GoToXY(col, lin);
  1175.   IF NOT hidden   THEN Write(tempfield);
  1176.   GoToXY(col, lin);
  1177.   cursoron;
  1178.   hidden   := False;
  1179.   END;
  1180.  
  1181.   {---------------------------------------------------------------------------}
  1182.   { PROCEDURE getdouble(VAR fieldname : Double; lin, col, len, decimal : Integer;
  1183.         inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1184.   PROCEDURE getdouble;
  1185.   VAR picture : STRING[25];
  1186.     tempfield : STRING[25];
  1187.     err : Integer;
  1188.   BEGIN
  1189.   Str(fieldname:len:decimal, tempfield);
  1190.   IF length(tempfield) > len THEN
  1191.     BEGIN
  1192.     replicate(tempfield,len,'*');
  1193.     END;
  1194.   IF inpmode THEN
  1195.     BEGIN
  1196.     replicate(picture, len, '#');
  1197.     IF decimal > 0 THEN picture[len-decimal] := '.';
  1198.     getfield('B', tempfield, lin, col, len, picture, inpmode, fgr, bgr, lastkey);
  1199.     fixnum(tempfield);
  1200.     Val(tempfield, fieldname, err);
  1201.     Str(fieldname:len:decimal, tempfield);
  1202.     END;
  1203.   color(fgr, bgr);
  1204.   cursoroff;
  1205.   GoToXY(col, lin);
  1206.   IF NOT hidden   THEN Write(tempfield);
  1207.   GoToXY(col, lin);
  1208.   cursoron;
  1209.   hidden   := False;
  1210.   END;
  1211.  
  1212.   {---------------------------------------------------------------------------}
  1213.   { PROCEDURE getyn(VAR fieldname : Boolean; lin, col : Integer;
  1214.         inpmode : Boolean; fgr, bgr : Integer; VAR lastkey : Integer); }
  1215.   PROCEDURE getyn;
  1216.   VAR yn: STRING[1];
  1217.   BEGIN
  1218.   IF fieldname THEN yn := 'Y' ELSE yn := 'N';
  1219.   getfield('Y', yn, lin, col, 1, 'Y', inpmode, fgr, bgr, lastkey);
  1220.   fieldname := (yn = 'Y');
  1221.   hidden   := False;
  1222.   END;
  1223.  
  1224.   {---------------------------------------------------------------------------}
  1225.   { FUNCTION get_value(fieldname : str255  ; nthstring : Integer) : str80  ; }
  1226.   FUNCTION get_value;
  1227.     { Find the nth string in field name by counting the delimiters }
  1228.     { the string must be of the form '*xxx*yyy*abc*' so the 3rd string is 'abc' }
  1229.   VAR i, j : Integer;
  1230.     delim : Char;
  1231.   BEGIN
  1232.   i := 1;
  1233.   delim := fieldname[1];
  1234.   j := Pos(delim, fieldname); { is string empty ? }
  1235.   IF j > 0 THEN fieldname[j] := #0; { 0 out the first delimiter }
  1236.  
  1237.   WHILE (i < nthstring) AND (j > 0) DO
  1238.     BEGIN
  1239.     j := Pos(delim, fieldname);
  1240.     IF j > 0 THEN fieldname[j] := #0;
  1241.     i := i+1;
  1242.     END;
  1243.  
  1244.   IF j > 0 THEN
  1245.     BEGIN
  1246.     i := Pos(delim, fieldname);
  1247.     get_value := Copy(fieldname, j+1, i-j-1);
  1248.   END ELSE
  1249.     BEGIN
  1250.     get_value := '';
  1251.     END;
  1252.   END;
  1253.  
  1254.   {---------------------------------------------------------------------------}
  1255.   { PROCEDURE getupfield(lincol: lincolarr  ); }
  1256.   PROCEDURE getupfield;
  1257.     { Gets the Moves to the field in the above line. Uses logic to determine
  1258.     which is the best field to goto }
  1259.   VAR bestfld, i : Integer;
  1260.     curcol, curlin, curlen : Byte;
  1261.     numfields : Byte;
  1262.   BEGIN
  1263.   curlin := lincol^[fieldnum  , 1]; { Set current field line, col, and len}
  1264.   curcol := lincol^[fieldnum  , 2]+exitcursor  -1;
  1265.   curlen := lincol^[fieldnum  , 3]-exitcursor  +1;
  1266.   numfields := lincol^[0, 1];
  1267.   bestfld := 0;
  1268.   FOR i := 1 TO numfields DO
  1269.     IF (lincol^[i, 1] <> $FF) THEN
  1270.       IF bestfld = 0 THEN
  1271.         BEGIN                 {Get first acceptable field}
  1272.         IF lincol^[i, 1] < curlin THEN bestfld := i;
  1273.         END
  1274.       ELSE
  1275.         IF (lincol^[i, 1] > lincol^[bestfld, 1]) {If new field line is closer}
  1276.         AND (lincol^[i, 1] < curlin) THEN
  1277.           bestfld := i
  1278.         ELSE                  {If field are on same line}
  1279.           IF lincol^[i, 1] = lincol^[bestfld, 1] THEN
  1280.             IF (lincol^[i, 2] <= curcol) AND (lincol^[bestfld, 2] <= curcol) THEN
  1281.               BEGIN
  1282.               IF lincol^[i, 2] > lincol^[bestfld, 2] THEN bestfld := i;
  1283.               END
  1284.             ELSE
  1285.               IF (lincol^[i, 2] >= curcol) AND (lincol^[bestfld, 2] >= curcol) THEN
  1286.                 BEGIN
  1287.                 IF lincol^[i, 2] < lincol^[bestfld, 2] THEN bestfld := i;
  1288.                 END
  1289.               ELSE
  1290.                 IF (lincol^[i, 2] < lincol^[bestfld, 2]) THEN
  1291.                   BEGIN
  1292.                   IF ((lincol^[i, 2]+lincol^[i, 3]) > curcol)
  1293.                   OR ((curcol+curlen-1) < lincol^[bestfld, 2]) THEN bestfld := i;
  1294.                   END
  1295.                 ELSE
  1296.                   IF ((lincol^[bestfld, 2]+lincol^[bestfld, 3]-1) < curcol)
  1297.                   AND ((curcol+curlen-1) > lincol^[i, 2]) THEN bestfld := i;
  1298.   IF bestfld <> 0 THEN fieldnum   := bestfld;
  1299.   END;
  1300.  
  1301.   {---------------------------------------------------------------------------}
  1302.   {PROCEDURE getdownfield(lincol : lincolarr  );}
  1303.   PROCEDURE getdownfield;
  1304.     { Gets the fieldnum   of the field in line below. Uses logic to determine.
  1305.     which is the best field to goto }
  1306.   VAR bestfld, i : Integer;
  1307.     curcol, curlin, curlen : Byte;
  1308.     numfields : Byte;
  1309.   BEGIN
  1310.   curlin := lincol^[fieldnum  , 1]; { Set current field line, col, and len}
  1311.   curcol := lincol^[fieldnum  , 2]+exitcursor  -1;
  1312.   curlen := lincol^[fieldnum  , 3]-exitcursor  +1;
  1313.   numfields := lincol^[0, 1];
  1314.   bestfld := 0;
  1315.   FOR i := 1 TO numfields DO
  1316.     IF (lincol^[i, 1] <> $ff) THEN
  1317.       IF bestfld = 0 THEN
  1318.         BEGIN
  1319.         IF lincol^[i, 1] > curlin THEN bestfld := i;
  1320.         END
  1321.       ELSE
  1322.         IF (lincol^[i, 1] < lincol^[bestfld, 1]) {If new field line is closer}
  1323.         AND (lincol^[i, 1] > curlin) THEN
  1324.           bestfld := i
  1325.         ELSE
  1326.           IF lincol^[i, 1] = lincol^[bestfld, 1] THEN {If fields on same line}
  1327.             IF (lincol^[i, 2] >= curcol) AND (lincol^[bestfld, 2] >= curcol) THEN
  1328.               BEGIN
  1329.               IF lincol^[i, 2] < lincol^[bestfld, 2] THEN bestfld := i;
  1330.               END
  1331.             ELSE
  1332.               IF (lincol^[i, 2] <= curcol) AND (lincol^[bestfld, 2] <= curcol) THEN
  1333.                 BEGIN
  1334.                 IF lincol^[i, 2] > lincol^[bestfld, 2] THEN bestfld := i;
  1335.                 END
  1336.               ELSE
  1337.                 IF (lincol^[i, 2] < lincol^[bestfld, 2]) AND
  1338.                 ((lincol^[i, 2]+lincol^[i, 3]-1) >= curcol) THEN bestfld := i
  1339.                 ELSE
  1340.                   IF (lincol^[bestfld, 2]+lincol^[bestfld, 3]-1) < curcol THEN
  1341.                     bestfld := i;
  1342.   IF bestfld <> 0 THEN fieldnum   := bestfld;
  1343.   END;
  1344.  
  1345.   {---------------------------------------------------------------------------}
  1346.   {PROCEDURE getleftfield(lincol : lincolarr  );}
  1347.   PROCEDURE getleftfield;
  1348.   { Gets the fieldnum   to the left of the current one on the same line.
  1349.   Uses logic to determine which is the best field to goto. }
  1350.   VAR
  1351.     bestfld, i : Integer;
  1352.     curcol, curlin : Byte;
  1353.     numfields : Byte;
  1354.   BEGIN
  1355.   curlin := lincol^[fieldnum  , 1]; { Set current field line, col, and len}
  1356.   curcol := lincol^[fieldnum  , 2];
  1357.   numfields := lincol^[0, 1];
  1358.   bestfld := 0;
  1359.   FOR i := 1 TO numfields DO
  1360.     IF (lincol^[i, 1] <> $ff) THEN
  1361.     IF bestfld = 0 THEN
  1362.       BEGIN
  1363.       IF (lincol^[i, 1] < curlin) OR ((lincol^[i, 1] = curlin)
  1364.       AND (lincol^[i, 2] < curcol)) THEN bestfld := i;
  1365.       END
  1366.     ELSE
  1367.       BEGIN
  1368.       IF (lincol^[i, 1] < curlin) OR ((lincol^[i, 1] = curlin)
  1369.       AND (lincol^[i, 2] < curcol)) THEN
  1370.  
  1371.         IF (lincol^[i, 1] > lincol^[bestfld, 1]) THEN
  1372.           bestfld := i
  1373.         ELSE
  1374.           IF (lincol^[i, 1] = lincol^[bestfld, 1]) AND
  1375.           (lincol^[i, 2] > lincol^[bestfld, 2]) THEN
  1376.             bestfld := i;
  1377.       END;
  1378.   IF bestfld <> 0 THEN fieldnum   := bestfld;
  1379.   END;
  1380.  
  1381.   {---------------------------------------------------------------------------}
  1382.   { PROCEDURE getrightfield(lincol: lincolarr  ); }
  1383.   { Gets the fieldnum   to the right on the same line. Uses logic to determine
  1384.   which is the best field to goto. }
  1385.   PROCEDURE getrightfield;
  1386.   VAR
  1387.     bestfld, i : Integer;
  1388.     curcol, curlin : Byte;
  1389.     numfields : Byte;
  1390.   BEGIN
  1391.   curlin := lincol^[fieldnum  , 1]; { Set current field line, col, and len}
  1392.   curcol := lincol^[fieldnum  , 2];
  1393.   numfields := lincol^[0, 1];
  1394.   bestfld := 0;
  1395.   FOR i := 1 TO numfields DO
  1396.     IF (lincol^[i, 1] <> $ff) THEN
  1397.       IF bestfld = 0 THEN
  1398.         BEGIN
  1399.         IF (lincol^[i, 1] > curlin) OR ((lincol^[i, 1] = curlin)
  1400.         AND (lincol^[i, 2] > curcol)) THEN bestfld := i;
  1401.         END
  1402.       ELSE
  1403.         BEGIN
  1404.         IF (lincol^[i, 1] > curlin) OR ((lincol^[i, 1] = curlin)
  1405.         AND (lincol^[i, 2] > curcol)) THEN
  1406.  
  1407.           IF (lincol^[i, 1] < lincol^[bestfld, 1]) THEN
  1408.             bestfld := i
  1409.           ELSE
  1410.             IF (lincol^[i, 1] = lincol^[bestfld, 1]) AND
  1411.             (lincol^[i, 2] < lincol^[bestfld, 2]) THEN
  1412.               bestfld := i;
  1413.         END;
  1414.   IF bestfld <> 0 THEN fieldnum   := bestfld;
  1415.   END;
  1416.  
  1417.   {---------------------------------------------------------------------------}
  1418. BEGIN
  1419. END.
  1420.