Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DER12.ZIP/DER.PAS

Pascal/Delphi Source File | 1993-01-04 | 32.4 KB | 1,192 lines

{$B-,D-,T-,I-,L-,S-,V-}
{ --------------------------------------------------------------------------- }
{  A unit providing a set of tested data entry routines.

  Version 1.20 - 05/05/1988

  Juan M. Vegarra
  I.C.U. Research Unit, George Washington University Medical Center.
  2300 K. St, N.W.
  Washington, D.C. 20037
  <Work Phone> [phone]    <Home Phone> [phone]
  Compuserve 72770,247


{ --------------------------------------------------------------------------- }

Unit DER; { Data Entry Routines }

Interface
Uses
  Crt,
  Dos,
  Dates,   { Scott Bussinger's Dates unit from CIS BORPRO DL2 }
  QWIK,    { Jim LeMay's QWIK41A unit from CIS BORPRO DL2 }
  WNDWVars,
  WNDW;    { Jim LeMay's WNDW40  unit from CIS BORPRO DL2 }

Const
  CursorLeft  = ^S;   { WordStar and Turbo Editor Keys }
  CursorRight = ^D;
  CursorDown  = ^X;
  CursorUp    = ^E;
  CursorHome  = ^A;
  CursorEnd   = ^F;
  PageUp      = ^R;
  PageDown    = ^C;
  DelKey      = ^G;
  TabKey      = #9;
  PlusKey     = '+'; { Use to Set Bit in Multiple Choice }
  MinusKey    = '-'; { Use to Clear Bit in Multiple Choice }
  Return      = ^M;
  Escape      = ^[;
  HelpKey     = #59; { F1 Key }
  UpperCase   : Boolean = False;
  ExtKey      : Boolean = False;
  Filler      : Char =  #32; {#250;}
  AutoWrap    : Boolean = False;

Type
  Str2 = String[2];  { FOR CIS only use str2 str8 }
  Str4 = String[4];
  Str5 = String[5];
  Str6 = String[6];
  Str8 = String[8];
  Str10 = String[10];
  Str15 = String[15];
  Str20 = String[20];
  Str60 = String[60];
  Str80 = String[80];
  Str132 = String[132];
  CharSet = Set of Char;
  ByteSet = Set of Byte;

  Time       = Record
                 Hour  : Byte;
                 Minute: Byte;
               End;

  Phone      = Record
                 Area    : Word;
                 XChange : Word;
                 Number  : Word;
               End;

  SSN        = Record
                 First  : Word; { 000..999   }
                 Middle : Word; { 00..99     }
                 Last   : Word; { 0000..9999 }
               End;

Var
  OLDCursor  : Word;
  NormalAtt  : Byte;
  ReverseAtt : Byte;

Function  UnPack(Param,No:Byte):String;
{ Returns a binary string of length = No in reverse order
  Example: Str := UnPack(56,6);  ==> Str := 000111
  I use this function to unpack a multiple choice response field }

Procedure Pad_With_Blanks(Var Target:String;Len:Byte);
{ Right Pads Target with ' ' }

Procedure BlankToZero(Var Temp:String;Place:Byte);
{ Replaces ' ' with '0' in Target }

{ Left Pad Target with zeros
  Example: if target = 12 and Str := LeftPad_Word(Target,5) Then
           Str := '00012'
 }
Function  LeftPad_Long(Target:LongInt;Len:Byte):String;
Function  LeftPad_Byte(Target,Len:Byte):String;
Function  LeftPad_Word(Target:Word;Len:Byte):String;
Function  LeftPad_Integer(Target:Integer;Len:Byte):String;

Procedure CheckLimit(Var L:Byte;TC:Char;Up,Down:CharSet;LL,HL:Byte);
{ Selects next question in data entry screen }

Procedure CheckCursor;
{ This procedure was copied from Jim LeMay's QWIK40 documentation }

Procedure Beep;
{ Generate Error sound }

Function  UpcaseStr(S : String) : String;
{ Returns the UpperCase version of S }

Procedure Today(Var Date1: Date);
{ Returns Today's date in MM/DD/YY format }

{ These four functions could be used with the database toolbox
  whenever you use numbers as keys }
Function  WordToStr(ID  : Word):Str2;
Function  IntToStr (ID  : Integer):Str2;
Function  StrToWord(Key : Str2):Word;
Function  StrToInt (Key : Str2):Integer;

{ The following group of functions need no explanation, with the exception
  of BooleanToString.  In all my medical applications I need to keep track
  of missing values, therefore I created a pseudo boolean variable:
  0 : Missing;  1 : True;  2 : False.
  You can use this function to store a bunch of dichotomous variables
  Example: (Sex,'M','F') or (YesNo,'Y','N') or (TrueFalse,'T','F') }

Function  LongIntToString(Param : LongInt): String;
Function  IntegerToString(Param : Integer): String;
Function  WordToString(Param : Word): String;
Function  ByteToString(Param : Byte): String;
Function  BooleanToString(Param : Byte;IfTrue,IfFalse : Char): String;
Function  RealToString(Param : Real): String;

Function  AddStrings(S2,S3 : String):String;
{ Returns AddStrings := S2 + S3; }

Procedure ReadKB (Var ExtKey: Boolean; Var Ch: Char);
Function  ReadChar : Char;
Function  ConstStr(C : Char; N : Byte) : String;
{ Returns a string of N C's }

Function  AskStr(Var S:String;Term:CharSet;L,X,Y:Byte;Var TC:Char):String;
{ This function allows you to move left, right, home , end, delete, etc
  in any data entry field.  It automatically wraps to the next data entry
  field, once the limit 'L' has been reached }

{ The following group of functions allow you to enter: strings, booleans,
  words, integers, bytes, etc. with range checking, and field length }
Function  SelectString(Var Param : String; Len, X, Y : Byte) : Char;
Function  SelectBoolean(Var Param:Byte;IfTrue,IfFalse:Char;X,Y:Byte):Char;
Function  SelectLongInt(Var Param:LongInt;Lower,Upper:LongInt;Len,X,Y:Byte):Char;
Function  SelectWord(Var Param:Word;Lower,Upper:Word;Len,X,Y:Byte):Char;
Function  SelectByte(Var Param:Byte;Lower,Upper,Len,X,Y:Byte):Char;
Function  SelectInteger(Var Param:Integer;Lower,Upper:Integer;Len,X,Y:Byte):Char;
Function  SelectReal(Var Param:Real;Lower,Upper:Real;Len,X,Y:Word):Char;
Function  PhoneToString(Param:Phone):String;
Function  SelectPhone(Var Param : Phone; Col,Row: Byte) : Char;
Function  TimeToString(Param:Time) :String;
Function  SelectTime(Var Param : Time; Col,Row: Byte) : Char;

{ If you have applications that require the user to select N options from
  a list of M options (N <= M <= 8) then these routines will allow you to
  pack upto 8 responses into a single byte.
  Example: Record ALL mentioned: [1] Alternative A
                                 [2] Alternative B
                                       ...
                                 [8] Alternative H
  See Demo for a possible use of these routines }
Procedure SetBit(Var Param: Byte;BitNum : Byte);
Procedure ClearBit(Var Param: Byte;BitNum : Byte);
Function  Power(Pos : Byte) : Byte;
Procedure ShowMultipleChoice(Param,Bit:Byte;RowOffset,ColOffset:ShortInt);
Function  SelectMultiple(Var Param:Byte;From,Limit,X,Y:ShortInt):Char;

{ Some Date arithmetic using Scott's DATES Unit }
Function  DateToYear(Julian: Date) : Integer;
Function  DateToMonth(Julian: Date) : Integer;
Function  DateToDay(Julian: Date) : Integer;
Function  DateToStr(Date1:Date):Str8;
Procedure DisplayDate(Date1:Date;X,Y:Byte);
Procedure DisplayNewDate(Date1:Date;X,Y:Byte);
Function  SelectDate(Var Date1:Date;X,Y:Byte): Char;
Function  DaysBtWn(Date1,Date2:Date):Word;
Function  AddDays(Date1:Date;Num:Integer):Date;
Function  AddMonths(Date1:Date;Num:Integer):Date;

{ if you ever need to check for an answer to be in a range, here's some help.
  Example: Assume you allow the answer to be a number in [1..5,8], then you
  can Repeat
        Ch := SelectByte(Param,1,8,1,WhereX,WhereY);
      Until ByteInRange(Param,[1..5,8]); }

Function  ByteInRange(Var Param:Byte;Test:ByteSet):Boolean;
Function  WordInRange(Var Param:Word;Min,Max:Word):Boolean;

Function  SSNToString(Param:SSN) : String;
Function  SelectSSN(Var Param:SSN;X,Y:Byte):Char;

{ New routines }
Function  ColorSelect(RR,CC,DR,DC : Byte) : Byte;
Procedure Wait(On : Boolean);
Function  AreYouSure : Boolean;
Function  SureToDelete(ID : Word) : Boolean;

{ Fast checking routine, do not require you
  to open any file to check for existency }
Function  FileExist(FileName : String) : Boolean;
Function  DirExist(DirName : String) : Boolean;

Function  CopyFile(Source, Dest : String) : Word;
{ CopyFile is much better than FCOPY4.ARC. Extensive IO checking.
  If CopyFile fails then Dest is automatically erased }

Implementation

Function UnPack(Param,No:Byte):String;
Var
  I,N : Word;
Begin
  N := No;
  UnPack[0] := Chr(No);
  For I := Pred(No) downto 0 do
  Begin
    If (Param AND (1 shl I) <> 0) Then UnPack[N] := '1'
    Else UnPack[N] := '0';
    Dec(N);
  End;
End;

Procedure Pad_With_Blanks(Var Target:String;Len:Byte);
Var
  I : Word;
  Actual_Length : Word;
  Temp : String;
Begin
  Temp := Target;
  Actual_Length := Length(Temp);
  If Actual_Length < Len Then
     For I := Actual_Length to Len Do Temp := Temp + ' ';
  Temp[0] := Chr(Len);
  Target := Temp;
End;

Procedure BlankToZero(Var Temp:String;Place:Byte);
Begin
  If Temp[Place] = ' ' Then Temp[Place] := '0';
End;

Function LeftPad_Long(Target:LongInt;Len:Byte):String;
Var
  I : Word;
  Temp : String;
Begin
  Str(Target:Len,Temp);
  For I := 1 to Length(Temp) Do BlankToZero(Temp,I);
  Temp[0] := Chr(Len);
  LeftPad_Long := Temp;
End;

Function LeftPad_Byte(Target,Len:Byte):String;
Var
  I : LongInt;
  Temp : String;
Begin
  I := LongInt(Target);
  LeftPad_Byte := LeftPad_Long(I,Len);
End;

Function LeftPad_Word(Target:Word;Len:Byte):String;
Var
  I : LongInt;
  Temp : String;
Begin
  I := LongInt(Target);
  LeftPad_Word := LeftPad_Long(I,Len);
End;

Function LeftPad_Integer(Target:Integer;Len:Byte):String;
Var
  I : LongInt;
  Temp : String;
Begin
  I := LongInt(Target);
  LeftPad_Integer := LeftPad_Long(I,Len);
End;

Procedure CheckLimit(Var L:Byte;TC:Char;Up,Down:CharSet;LL,HL:Byte);
{ LL = Low Limit,  HL = High Limit }
Begin
  If (TC In Down) Then
     If L = HL Then L := LL
     Else Inc(L)
  Else
     If (TC In Up) Then
        If L = LL Then L := HL
        Else Dec(L)
End;

Procedure CheckCursor;
{ This procedure was copied from Jim LeMay's QWIK40 documentation }
Var
  CursorMode : Integer Absolute $0040:$0060;
Begin
  If ActiveDispDev = MdaMono Then
     If CursorMode = $0607 Then CursorChange($0B0C,OldCursor);
End;

Procedure Beep;
Begin
  Sound(1500); Delay(50);
  Sound(1000); Delay(50);
  NoSound;
End;

Function UpcaseStr(S : String) : String;
Var
  I : Word;
Begin
  For I := 1 to Length(S) Do S[I] := Upcase(S[I]);
  UpcaseStr := S;
End;

Procedure Today(Var Date1: Date);
Var
  DosRegs : Registers;
  Day,Month,Year : Integer;
Begin
  With DosRegs do
  Begin
    AX := $2A00;
    INTR($21,DosRegs);
    Day   := LO(DX);
    Month := HI(DX);
    Year  := CX;
    DMYtoDate(Day,Month,Year,Date1);
  End;
End;

Function WordToStr(ID : Word):Str2;
Begin
  WordToStr := Chr(Hi(ID)) + Chr(Lo(ID));
End;

Function IntToStr(ID : Integer):Str2;
Begin
  IntToStr := Chr(Hi(ID)) + Chr(Lo(ID));
End;

Function StrToWord(Key : Str2):Word;
Begin
  StrToWord := Swap(Ord(Key[1])) + Ord(Key[2]);
End;

Function  StrToInt(Key : Str2):Integer;
Begin
  StrToInt := Swap(Ord(Key[1])) + Ord(Key[2]);
End;

Function LongIntToString(Param : LongInt): String;
Var
  Temp : String;
BEGIN
  Temp[0] := #0;
  REPEAT
    Temp := Chr(Param Mod 10+48)+Temp;
    Param := Param Div 10;
  UNTIL Param = 0;
  LongIntToString := Temp;
END;

Function IntegerToString(Param : Integer): String;
Var
  Temp : String;
  WW   : LongInt;
BEGIN
  WW := LongInt(Param);
  Temp := longIntToString(WW);
  IntegerToString:=Temp;
END;

Function WordToString(Param : Word): String;
Var
  Temp : String;
  WW   : LongInt;
BEGIN
  WW := LongInt(Param);
  Temp := longIntToString(WW);
  WordToString:=Temp;
END;

Function ByteToString(Param : Byte): String;
Var
  Temp : String;
  WW   : LongInt;
BEGIN
  WW := LongInt(Param);
  Temp := longIntToString(WW);
  ByteToString:=Temp;
END;

Function BooleanToString(Param : Byte;IfTrue,IfFalse : Char): String;
Var
  Temp : String;
BEGIN
  Case Param of
    0: Temp := Filler;
    1: Temp := IfTrue;
    2: Temp := IfFalse;
  End;
  BooleanToString:=Temp;
END;

Function RealToString(Param : Real): String;
Var
  Temp : String;
  I    : Word;
Begin
  Str(Param:1:12, Temp);
  I := Length(Temp);
  While Temp[I] = '0' Do Dec(I);
  If Temp[I] = '.' Then Dec(I);
  RealToString := Copy(Temp, 1, I);
End;

Function AddStrings(S2,S3 : String):String;
Begin
  AddStrings := S2 + S3;
End;

Procedure ReadKB (Var ExtKey: Boolean; Var Ch: Char);
begin
  ExtKey := False;
  Ch := ReadKey;
  If Ch = #0 Then
  Begin
    ExtKey := True;
    Ch := ReadKey;
  End;
end;

Procedure ShowEditHelp;
Const Help : Array[6..23] of Str80 = (
'Key Label  Key Name    Usage in Data Entry      ',
'────────────────────────────────────────────────',
'F1         HELP        Provide this screen      ',
^X'          UP          Field above              ',
^Y'          DOWN        Field below              ',
^Z'          RIGHT       Next character           ',
^['          LEFT        Previous character       ',
'Home       HOME        First field in form      ',
'End        END         Last field in form       ',
'PgUp       PREV PAGE   First field on prev. page',
'PgDn       NEXT PAGE   First field on next page ',
'Backspace  BACKSPACE   Delete prev. character   ',
'Enter      RETURN      Next field               ',
'Del        DELETE      Delete character         ',
'Ctrl-Y     CTRLY       Delete characters to end ',
'+          SET FLAG    Select multiple choice   ',
'-          CLEAR FLAG  Clear multiple choice    ',
'Esc        ESCAPE      Return to MAIN MENU      '
);

Var
  Row : Byte;
  TC  : Char;
Begin
  MakeWindow(5,1,20,50,ReverseAtt,ReverseAtt,DoubleBrdr,aWindow);
  TitleWindow(Top,Right,' Editing Keys ');
  TitleWindow(Bottom,Right,' Press Esc to continue ');
  For Row := 6 to 23 Do QWrite(Row,2,ReverseAtt,Help[Row]);
  GotoRC(24,48);
  Repeat
    TC := ReadKey;
  Until TC = Escape;
  RemoveWindow;
End;

Function ReadChar : Char;
Var
  CH : Char;
Begin                                                   { Function ReadChar }
  ReadKb(ExtKey, CH);                  { read character                     }
  If ExtKey Then                       { check for extened scan code        }
  Begin
    Case CH Of
      #75 : CH := CursorLeft;          { Left-Arrow Key                     }
      #77 : CH := CursorRight;         { Right-Arrow Key                    }
      #72 : CH := CursorUp;            { Up-Arrow Key                       }
      #80 : CH := CursorDown;          { Down-Arrow Key                     }
      #73 : CH := PageUp;              { Page Up Key                        }
      #81 : CH := PageDown;            { Page Down Key                      }
      #71 : CH := CursorHome;          { Home-arrow key                     }
      #79 : CH := CursorEnd;           { End-arrow key                      }
      #83 : CH := DelKey;              { Delete key                         }
      #59 : Begin
              ShowEditHelp;            { F1 = Help Key                      }
              CH := #0;
            End;
      Else  CH := #0;                  { invalid key                        }
    End;                                                   { case statement }
    If CH = #9  Then CH := TabKey;
  End;
  ReadChar := CH;
End;                                                    { Function ReadChar }

Function ConstStr(C : Char; N : Byte) : String;
Var
  S : String;
Begin
  If N < 0 Then  N := 0;
  S[0] := Chr(N);
  FillChar(S[1], N, C);
  ConstStr := S;
End;

Function AskStr(Var S:String;Term:CharSet;L,X,Y:Byte;Var TC:Char):String;
Const
  Next : CharSet = [Return,CursorUp,CursorDown,PageUp,PageDown,Escape];
Var
  P    : Byte;    { Cursor Position }
  Ch   : Char;    { Key Pressed }
  Temp : String;
Begin
  CursorOn;
  If S = '0' Then S[0] := #0;
  Temp:=ConstStr(Filler,L-Length(S));
  Temp := AddStrings(S,Temp);
  QWrite(Y,X,ReverseAtt,Temp);
  P := 0;
  If Not UpperCase Then P := Length(S);
  Repeat
    GoToRC(Y,X+P);
    Ch := ReadChar;
    If UpperCase Then CH := UpCase(CH);
    If (CH In Term) Then
    Begin
      If P < L Then
      Begin
        If Length(S) = L Then Delete(S, L, 1);
        Inc(P);
        Insert(CH, S, P);
        Write(Copy(S, P, L));
        If AutoWrap AND (P = L) Then Ch := Return;
      End
      Else If Not(AutoWrap) Then Beep;
    End
    Else
    Case CH Of
        ^H, #127 : If P > 0 Then      { Backspace key }
                   Begin
                     Delete(S, P, 1);
                     Write(^H, Copy(S, P, L), Filler);
                     Dec(P);
                   End
                   Else Beep;
          DelKey : If P < Length(S) Then
                   Begin
                     Delete(S, Succ(P), 1);
                     Write(Copy(S, Succ(P), L), Filler);
                   End;
      CursorLeft : If P > 0 Then Dec(P) { NON-destructive }
                   Else Beep;
      CursorRight: If P < Length(S) Then Inc(P) { NON-destructive }
                   Else Beep;
      CursorHome : P := 0;
       CursorEnd : P := Length(S);
              ^Y : Begin { Delete from current cursor position to end of field }
                     Write(ConstStr(Filler, Length(S)-P));
                     Delete(S, Succ(P), L);
                   End;
    End;
  Until CH In Next;
  P := Length(S);
  QAttr(Y,X,1,L,NormalAtt);
  Qfill(Y,X+P,1,L-P,NormalAtt,' ');
  AskStr := S;
  TC := CH;
  CursorOff;
End;

Function SelectString(Var Param : String; Len, X, Y : Byte) : Char;
Var
  Temp : String;
  TC : Char;
Begin
  Temp := Param;
  Temp := AskStr(Temp, [#32..#126], Len, X, Y, TC);
  Param := Temp;
  SelectString := TC;
End;                                                         { SelectString }

Function SelectBoolean(Var Param:Byte;IfTrue,IfFalse:Char;X,Y:Byte):Char;
Var
  TC    : Char;
  Temp  : String;
  Value : Byte;
Begin
  Value := Param;
  Temp := BooleanToString(Value,IfTrue,IfFalse);
  UpperCase := True;
  Temp := AskStr(Temp,[IfTrue,IfFalse],1,X,Y,TC);
  If Length(Temp) =  0 Then
  Begin
    Param := 0;
    QWrite(Y,X,NormalAtt,BooleanToString(Param,IfTrue,Iffalse));
  End
  Else
  Begin
    If Temp = Filler  Then Param := 0;
    If Temp = IfTrue  Then Param := 1;
    If Temp = IfFalse Then Param := 2;
  End;
  UpperCase := False;
  SelectBoolean := TC;
End;

Function SelectLongInt(Var Param:LongInt;Lower,Upper:LongInt;Len,X,Y:Byte):Char;
Var
  Temp     : String;
  P, Value : LongInt;
  I        : Integer;
  Err      : Boolean;
  TC       : Char;
Begin
  Repeat
    Err := False;
    Str(Param, Temp);  { Add '-' to allow for negative numbers }
    Temp := AskStr(Temp, ['0'..'9'], Len, X, Y, TC);
    Val(Temp, P, I);
    If length(Temp) = 0 Then Value := 0
    Else If I = 0 Then Value := P
         Else
         Begin
           Value := Param;
           Beep;
           Err := True;
         End;
    If (Not((Value >= Lower) And (Value <= Upper))) Then Beep;
  Until (Value >= Lower) And (Value <= Upper) And (Not(Err));
  Param := Value;
  SelectLongInt := TC;
End;                                                            { SelectWord }

Function SelectWord(Var Param:Word;Lower,Upper:Word;Len,X,Y:Byte):Char;
Var
  TC : Char;
  WW,WL,WH : LongInt;
Begin
  WW := LongInt(Param);
  WL := LongInt(Lower);
  WH := LongInt(Upper);
  TC := SelectLongInt(WW,WL,WH,Len,X,Y);
  Param := Word(WW);
  SelectWord := TC;
End;                                                            { SelectWord }

Function SelectByte(Var Param:Byte;Lower,Upper,Len,X,Y:Byte):Char;
Var
  TC : Char;
  WW,WL,WH : LongInt;
Begin
  WW := LongInt(Param);
  WL := LongInt(Lower);
  WH := LongInt(Upper);
  TC := SelectLongInt(WW,WL,WH,Len,X,Y);
  Param := Byte(WW);
  SelectByte := TC;
End;                                                         { SelectByte }

Function SelectInteger(Var Param:Integer;Lower,Upper:Integer;Len,X,Y:Byte):Char;
Var
  TC : Char;
  WW,WL,WH : LongInt;
Begin
  WW := LongInt(Param);
  WL := LongInt(Lower);
  WH := LongInt(Upper);
  TC := SelectLongInt(WW,WL,WH,Len,X,Y);
  Param := Integer(WW);
  SelectInteger := TC;
End;                                                            { SelectWord }

Function SelectReal(Var Param : Real; Lower, Upper : Real; Len, X, Y : Word) : Char;
Var
  Temp : String;
  P, Value : Real;
  I : Word;
  Err : Boolean;
  TC : Char;
Begin
  Repeat
    Err := False;
    Temp := RealToString(Param);
                         { Add 'E' to allow for exponential notation }
    Temp := AskStr(Temp, ['0'..'9', '.','-'], Len, X, Y, TC);
    Val(Temp, P, I);
    If Length(Temp) = 0 Then Value := 0.0
    Else If I = 0 Then Value := P
         Else
         Begin
           Value := Param;
           Beep;
           Err := True;
         End;
     If (Not((Value >= Lower) And (Value <= Upper))) Then Beep;
  Until (Value >= Lower) And (Value <= Upper) And (Not(Err));
  Param := Value;
  SelectReal := TC;
End;                                                           { SelectReal }

Function PhoneToString(Param : Phone) : String;
Var
  AA,XX,NN : String;
Begin
  AA := LeftPad_Word(Param.Area,3);
  XX := LeftPad_Word(Param.XChange,3);
  NN := LeftPad_Word(Param.Number,4);
  PhoneToString := '('+ AA +') '+XX+'-'+NN;
End;

Function SelectPhone(Var Param : Phone; Col,Row: Byte) : Char;
Var
  Temp : String;
  TC   : Char;
  Wrap : Boolean;
Begin
  Wrap := AutoWrap;
  AutoWrap := True;
  TC := SelectWord(Param.Area,0,999,3,Col+1,Row);
  TC := SelectWord(Param.XChange,0,999,3,Col+6,Row);
  AutoWrap := False;
  TC := SelectWord(Param.Number,0,9999,4,Col+10,Row);
  QWrite(Row,Col,NormalAtt,PhoneToString(Param));
  AutoWrap := Wrap;
  SelectPhone := TC;
End;

Function TimeToString(Param : Time) : String;
Var
  HH,MM : String;
Begin
  HH := LeftPad_Byte(Param.Hour,2);
  MM := LeftPad_Byte(Param.Minute,2);
  TimeToString := HH + ':' + MM;
End;

Function SelectTime(Var Param : Time; Col,Row: Byte) : Char;
Var
  Temp : String;
  TC   : Char;
  Wrap : Boolean;
Begin
  Wrap := AutoWrap;
  AutoWrap := True;
  TC := SelectByte(Param.Hour,0,24,2,Col,Row);
  AutoWrap := False;
  TC := SelectByte(Param.Minute,0,59,2,Col+3,Row);
  QWrite(Row,Col,NormalAtt,TimeToString(Param));
  AutoWrap := Wrap;
  SelectTime := TC;
End;

Procedure SetBit(Var Param: Byte;BitNum : Byte);
Begin
  Param := Param OR (1 Shl BitNum);
End;

Procedure ClearBit(Var Param: Byte;BitNum : Byte);
Begin
  Param := Param AND Not (1 Shl BitNum);
End;

Function Power(Pos : Byte) : Byte;
{ Returns Power = 2 ^ Pos }
Begin
  Power := 1 Shl Pred(Pos);
End;

Procedure ShowMultipleChoice(Param,Bit:Byte;RowOffset,ColOffset:ShortInt);
Const
  Mark  = #251; {'√'}
  Space = #32;  {' '}
Begin
  If Param AND Power(Bit) > 0
     Then QWrite(Bit+RowOffset,ColOffSet,NormalAtt,Mark)
     Else QWrite(Bit+RowOffset,ColOffSet,NormalAtt,Space);
End;

Function SelectMultiple(Var Param:Byte;From,Limit,X,Y:ShortInt):Char;
Const
  Len    : Byte = 3; { length of reverse video }
  Next   : CharSet = [PageDown,PageUp,Escape];
Var
  TC     : Char;
  Choice,
  J      : Byte;
  Fin    : Boolean;
  YOffset: Byte;
  XOffset: Byte;
Begin
  CursorOn;
  Fin := False; Choice := From;
  YOffset:=Y;            {display stored values}
  XOffset:=X;
  Repeat
    GotoRC(Choice+YOffset,XOffSet);
    QAttr(Choice+YOffset,Pred(XOffSet),1,Len,ReverseAtt);
    TC := ReadChar;
    Case TC Of
      CursorDown,
      Return:     Begin
                    QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
                    If Choice = Limit Then Fin := True
                    Else Inc(Choice);
                  End;
      CursorUp:   Begin
                    QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
                    If Choice = From Then Fin := True
                    Else Dec(Choice);
                  End;
      PlusKey:    Begin
                    SetBit(Param,Pred(Choice));
                    ShowMultipleChoice(Param,Choice,YOffset,XOffSet);
                    QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
                  End;
      MinusKey:   Begin
                    ClearBit(Param,Pred(Choice));
                    ShowMultipleChoice(Param,Choice,YOffset,XOffSet);
                    QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
                  End;
    End;
  Until Fin OR (TC in Next);
  CursorOff;
  SelectMultiple := TC;
End;

Function DateToYear(Julian: Date) : Integer;
  { Get Year from Date }
Var
  Juliian : Date;
  Day,Month,Year : Integer;
Begin
  DateToDMY(Julian,Day,Month,Year);
  DateToYear := Year;
End;

Function DateToMonth(Julian: Date) : Integer;
  { Get Month from Date }
Var
  Juliian : Date;
  Day,Month,Year : Integer;
Begin
  DateToDMY(Julian,Day,Month,Year);
  DateToMonth := Month;
End;

Function DateToDay(Julian: Date) : Integer;
  { Get Day from Date }
Var
  Juliian : Date;
  Day,Month,Year : Integer;
Begin
  DateToDMY(Julian,Day,Month,Year);
  DateToDay := Day;
End;

Function DateToStr(Date1:Date):Str8;
Var
  Temp : Str8;
  MM,DD,YY : String;
  Day,Month,Year : Integer;
Begin
  DateToDMY(Date1,Day,Month,Year);
  Dec(Year,1900);
  MM := LeftPad_Integer(Month,2);
  DD := LeftPad_Integer(Day,2);
  YY := LeftPad_Integer(Year,2);
  Temp := MM+'/'+DD+'/'+YY;
  DateToStr := Temp;
End;

Procedure DisplayDate(Date1:Date;X,Y:Byte);
Var
  Temp : Str8;
Begin
  Temp:= DateToStr(Date1);
  QWrite(Y,X,NormalAtt,Temp);
End;

Procedure DisplayNewDate(Date1:Date;X,Y:Byte);
Var
  Temp : Str8;
Begin
  Temp:= DateToStr(Date1);
  Temp[0] := Chr(5);        { display first 5 letters }
  QWrite(Y,X,NormalAtt,Temp);
End;

Function SelectDate(Var Date1:Date;X,Y:Byte): Char;
Var
  Ok : Boolean;
  Ch : Char;
  Wrap : Boolean;
  Day,Month,Year : Integer;
Begin
  Wrap := AutoWrap; { Save current value of AutoWrap }
  UpperCase := True;
  DateToDMY(Date1,Day,Month,Year);
  Repeat
    Ok := True;
    DisplayDate(Date1,X,Y);
    Dec(Year,1900);
    AutoWrap := True;
    Ch := SelectInteger(month,1,12,2,X,Y);
    Ch := SelectInteger(day,1,31,2,x+3,y);
    AutoWrap := False;
    Ch := SelectInteger(year,1,99,2,x+6,y);
    Inc(Year,1900);
    Ok := ValidDate(Day,Month,Year);
  Until OK;
  DMYToDate(Day,Month,Year,Date1);
  DisplayDate(Date1,X,Y);
  Selectdate := Ch;
  UpperCase := False;
  AutoWrap := Wrap; { Reset AutoWrap }
End;

Function DaysBtWn(Date1,Date2:Date):Word;
Begin
  DaysBtWn  := Date2 - Date1;
End;

Function AddDays(Date1:Date;Num:Integer):Date;
Begin
  AddDays := BumpDate(Date1,Num,0,0);
End;

Function AddMonths(Date1:Date;Num:Integer):Date;
Begin
  AddMonths := BumpDate(Date1,0,Num,0);
End;

Function ByteInRange(Var Param : Byte; Test : ByteSet):Boolean;
Var
  Temp : Boolean;
Begin
  Temp := True;
  If Not(Param In Test) Then
  Begin
    Param := 0;
    Beep;
    Temp := False;
  End;
  ByteInRange := Temp;
End;

Function WordInRange(Var Param : Word; Min,Max : Word):Boolean;
Var
  Temp : Boolean;
Begin
  Temp := True;
  If Param <> 0 Then
  Begin
    If (Param < Min) OR (Param > Max) Then
    Begin
      Param := 0;
      Beep;
      Temp := False;
    End;
  End;
  WordInRange := Temp;
End;

Function SSNToString(Param : SSN) : String;
Var
  Temp : String;
  SS   : String;
Begin
  SS := LeftPad_Word(Param.First,3);
  Temp := SS + '-';

  SS := LeftPad_Word(Param.Middle,2);
  Temp := Temp + SS + '-';

  SS := LeftPad_Word(Param.Last,4);
  Temp := Temp + SS;

  SSNToString := Temp;
End;

Function SelectSSN(Var Param : SSN; X, Y : Byte):Char;
Var
  TC : Char;
  Wrap : Boolean;
Begin
  Wrap := AutoWrap;
  AutoWrap := True;
  TC := SelectWord(Param.First,0,999,3,X  ,Y);
  TC := SelectWord(Param.Middle,0,99,2,X+4,Y);
  AutoWrap := False;
  TC := SelectWord(Param.Last,0,9999,4,X+7,Y);
  QWrite(Y,X,NormalAtt,SSNToString(Param));
  AutoWrap := Wrap;
  SelectSSN := TC;
End;

Function ColorSelect(RR,CC,DR,DC : Byte) : Byte;
{ No Error checking is done, so make sure RR is in [1..25]
  and CC is in [1..80] }
Const
  Clear : Char = #4;
  Flag  : Char = #15;
Var
  Row,
  Col : Byte;
  Att : Integer;
  TC  : Char;
  TLimit,BLimit,Rlimit,LLimit : Byte;

Begin
  TLimit := RR + 1;
  BLimit := RR + 8;
  LLimit := CC + 1;
  RLimit := CC + 16;

  MakeWindow(RR,CC,10,18,NormalAtt,NormalAtt,SingleBrdr,aWindow);
  TitleWindow(Top,Center,' Colors ');
  For Row := 0 to 7 Do For Col := 0 to 15 Do
  Begin
    Att := Attr(Col,Row);
    QFill(RR + Row + 1,CC + Col + 1,1,1,Att,Clear);
  End;

  Row := RR + DR; { DR = Default Row }
  Col := CC + DC; { DC = Default Column }
  Repeat
    GotoRC(Row,Col);
    QFill(Row,Col,1,1,-1,Flag);
    TC := ReadChar;
    QFill(Row,Col,1,1,-1,Clear);
    Case TC Of
      CursorDown: Begin
                    If Row = BLimit Then Row := Tlimit
                    Else Inc(Row);
                  End;
      CursorUp:   Begin
                    If Row = TLimit Then Row := BLimit
                    Else Dec(Row);
                  End;
     CursorRight: Begin
                    If Col = RLimit Then Col := LLimit
                    Else Inc(Col);
                  End;
      CursorLeft: Begin
                    If Col = LLimit Then Col := RLimit
                    Else Dec(Col);
                  End;
    End;
  Until TC = Return;
  RemoveWindow;
{
  Note:
    ForeGround := Col - CC - 1
    BackGround := Row - RR - 1
}
  ColorSelect := Attr(Col - CC - 1,Row - RR - 1);
End;

Procedure Wait(On : Boolean);
Begin
  If On Then
  Begin
    MakeWindow(1,70,3,8,ReverseAtt,ReverseAtt,SingleBrdr,aWindow);
    QWrite(2,71,ReverseAtt+Blink,' WAIT ');
  End
  Else RemoveWindow;
End;

Function AreYouSure : Boolean;
Var
  TC  : Char;
  Yes : Byte;
Begin
  MakeWindow(10,30,3,19,ReverseAtt,ReverseAtt,SingleBrdr,aWindow);
  QWrite(11,31,ReverseAtt,' Are You Sure? ');
  Yes := 2;
  TC := SelectBoolean(Yes,'Y','N',46,11);
  Case Yes of
    0,2 : AreYouSure := False;
    1   : AreYouSure := True;
  End;
  If TC = Escape Then AreYouSure := False;
  RemoveWindow;
End;

Function SureToDelete(ID : Word) : Boolean;
Var
  TC  : Char;
  Yes : Byte;
  TS  : String[5];
Begin
  Str(ID:5,TS);
  MakeWindow(10,20,4,41,ReverseAtt,ReverseAtt,SingleBrdr,aWindow);
  QWrite(11,21,ReverseAtt,' You are about to delete record: ');
  QWrite(11,54,ReverseAtt,TS);
  QWrite(12,21,ReverseAtt,' Are You Sure? ');
  Yes := 2;
  TC := SelectBoolean(Yes,'Y','N',36,12);
  Case Yes of
    0,2 : SureToDelete := False;
    1   : SureToDelete := True;
  End;
  If TC = Escape Then SureToDelete := False;
  RemoveWindow;
End;

Function FileExist(FileName : String) : Boolean;
Var
   F    : File;
   fAttr : Word;
Begin
   Assign(F,FileName);
   GetFAttr(f,fAttr);
   FileExist := (fAttr <> 0) And ((fAttr AND Directory) = 0)
End; { FileExist }

Function DirExist(DirName : String) : Boolean;
Var
   F    : File;
   fAttr : Word;
Begin
   Assign(F,DirName);
   GetFAttr(f,fAttr);
   DirExist := (fAttr AND Directory) <> 0
End; { DirExist }

Function CopyFile(Source, Dest : String) : Word;
{ Copies a file to another file }
Type
  FileBuffer = array[1..65521] of byte;
Var
  Buf              : ^Byte;
  InF,OutF         : File;
  ErrorCode,
  BlocksRead,
  BlocksWritten    : Word;
  Time             : LongInt;
  BufferSize       : Word;
Begin
  BufferSize := SizeOf(FileBuffer);
  If (BufferSize > MaxAvail) Then BufferSize := MaxAvail;
  GetMem(Buf,BufferSize); { allocate memory for the buffer }
  Assign(InF,Source);
  Reset(InF,1);           { open the source file }
  ErrorCode := IOResult;
  GetFTime(InF,Time);     { get time/date stamp from source file }
  If ErrorCode = 0 then
  Begin
    Assign(OutF,Dest);
    Rewrite(OutF,1);      { Create destination file }
    ErrorCode := IOResult;
    { copy loop }
    If ErrorCode = 0 Then
    Begin
      Repeat
        BlockRead(InF,Buf^,BufferSize,BlocksRead);      { read a buffer full from source }
        BlockWrite(OutF,Buf^,BlocksRead,BlocksWritten); { write it to destintion }
        If BlocksWritten < BlocksRead Then ErrorCode := 81; { Insufficient disk space }
      Until ((ErrorCode <> 0) OR (BlocksRead < BufferSize));
      SetFTime(OutF,Time);     { Set time/date stamp of dest to that of source }
      Close(OutF); { Close destination file }
      If ErrorCode <> 0 Then Erase(OutF); { Copy was unsuccessful }
    End;
    Close(InF);       { close source file }
  End;
  CopyFile := ErrorCode;
  FreeMem(Buf,BufferSize); { deallocate heap space for buffer }
End; { CopyFile }

Begin { program body }
  NormalAtt  := 15;
  ReverseAtt := 112;
End.