[INHERIT ('FDVDEF')] PROGRAM Samp(Sampfile, INPUT, OUTPUT);

{ SAMP -- The FMS V2 Sample Application Program }

{
                          COPYRIGHT (c) 2004 BY
                 HEWLETT PACKARD DEVELOPMENT COMPANY L.P.,

 THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
 ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
 INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER
 COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
 OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
 TRANSFERRED.

 THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE
 AND  SHOULD  NOT  BE   CONSTRUED  AS  A COMMITMENT BY HEWLETT PACKARD.

 HEWLETT PACKARD ASSUMES NO  RESPONSIBILITY FOR  THE USE OR  RELIABILITY 
 OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY HEWLETT PACKARD.

}

{ Author: S.P.Simon }

{ Data definitions }

{ FMS related }

LABEL	9999;	{ End label for error abort }

CONST	Integer_string_length 	= 6;
	Numeric_mode		= 0;
	Application_mode 	= 1;
	Bell_mode		= 0;
	RegisterSize		= 50;
 
TYPE	Integer_string	= PACKED ARRAY[1..Integer_string_length] OF CHAR;
	VAR80		= VARYING [80] OF CHAR;
	Fix80		= PACKED ARRAY [1..80] OF CHAR;

{ Account (read in from file) }

	Account_record =  RECORD
	  acctno :	PACKED ARRAY [1..5] OF CHAR;
	  accdate :	PACKED ARRAY [1..7] OF CHAR;
	  last :	PACKED ARRAY [1..20] OF CHAR;
	  first :	PACKED ARRAY [1..15] OF CHAR;
	  middle :	PACKED ARRAY [1..15] OF CHAR;
	  street :	PACKED ARRAY [1..30] OF CHAR;
	  city :	PACKED ARRAY [1..20] OF CHAR;
	  state :	PACKED ARRAY [1..2] OF CHAR;
	  zip :		PACKED ARRAY [1..5] OF CHAR;
	  homeph :	PACKED ARRAY [1..10] OF CHAR;
	  workph :	PACKED ARRAY [1..10] OF CHAR;
	  opw :		PACKED ARRAY [1..12] OF CHAR;
	  END;

	Account_as_string = PACKED ARRAY [1..151] OF CHAR;

{ Deposit data (Read in via FDV$GETAL) }

	Deposit_record =  RECORD
	  date :	PACKED ARRAY [1..7] OF CHAR;
	  curbal :	PACKED ARRAY [1..6] OF CHAR;
	  amt :		PACKED ARRAY [1..6] OF CHAR;
	  newbal :	PACKED ARRAY [1..6] OF CHAR;
	  memo :	PACKED ARRAY [1..35] OF CHAR;
	  END;

	Deposit_as_string = PACKED ARRAY[1..60] OF CHAR; 
 
{ Money:

 Note that all money is kept internally as integers (in cents).
 It is only when the quantities are output that they look like
 dollars, since all the money fields have periods as field
 markers in the right places and they are right justified or 
 fixed decimal. }

{ Register data }

	Register_record =  RECORD
	  num :		PACKED ARRAY [1..4] OF CHAR;
	  date :	PACKED ARRAY [1..7] OF CHAR;
	  mempayto :	PACKED ARRAY [1..35] OF CHAR;
	  amtdep :	PACKED ARRAY [1..6] OF CHAR;
	  amtpay :	PACKED ARRAY [1..6] OF CHAR;
	  balance :	PACKED ARRAY [1..6] OF CHAR;
	  END;

	Register_as_string = PACKED ARRAY [1..64] OF CHAR;

	Select_Record_Type = (Select_Account, Select_Register);

	Input_Record	= RECORD
	    CASE Select_Record_Type OF
		Select_Account:	(Account: Account_record);
		Select_Register: (Register: Register_record);
	    END;

{ Other variables }

VAR	Sampfile: 	FILE OF Input_Record;
	Sampch:		FILE OF VAR80;

	Workspace :  [VOLATILE] ARRAY [1..3] OF INTEGER; { General workspace }
	Checkwksp :  [VOLATILE] ARRAY [1..3] OF INTEGER; { Check workspace }
	Tca :	     [VOLATILE] ARRAY [1..3] OF INTEGER; { Term Control Area }

	{ Storage for memory resident forms }

	Menu_form :  [VOLATILE] ARRAY [1..500] OF INTEGER;
	Check_form : [VOLATILE] ARRAY [1..750] OF INTEGER;
	Dposit_form :[VOLATILE] ARRAY [1..500] OF INTEGER;

	Terminator :		INTEGER;  { Terminator returned by FDV }
	Current_Balance :	INTEGER;  { Balance in account, numeric }
	Starting_Balance :	INTEGER;  { Starting balance }
	TotalDeposit :		INTEGER;  { Total deposits made this session }
	TotalPayment :		INTEGER;  { Total checks paid this session }
	Fmsstatus :  [VOLATILE]	INTEGER;  { Status for last FDV call }
	Rmsstatus :  [VOLATILE]	INTEGER;  { RMS Status for last FDV call }
	LastRegisterNumber :	INTEGER;  { Last number used in register }
	LastCheckNumber :	INTEGER;  { Last check number used }
	CurrentLine :		INTEGER;  { Register line cursor is now on }
	Minwindow :		INTEGER;  { Lowest reg line in scroll area }
	Maxwindow :		INTEGER;  { Highest reg line in scroll area }
	Line :			Fix80;    { Form image line for check print }
	Password :		Fix80;    { Password from account }
	Size_menu:		INTEGER;  { Gets size of menu form }
	Size_check:		INTEGER;  { Gets size of check form }
	Size_dposit:		INTEGER;  { Gets size of dposit form }

	Account:		Account_record;
 
	Deposit:		Deposit_record; 
 
	Registeritem:		ARRAY [1..RegisterSize] OF Register_record; 

	Sample:			Input_record;

{ FMS terminator codes and FDV entry point definitions are predefined
  in Pascal environment files. }


PROCEDURE Initialize_Account; FORWARD;
PROCEDURE EOF_Cleanup; FORWARD;
PROCEDURE IO_Error_Handler; FORWARD;
PROCEDURE Format_Check; FORWARD;
PROCEDURE MENU; FORWARD;
PROCEDURE EXIT; FORWARD;
PROCEDURE Write_Check; FORWARD;
PROCEDURE Process_Check; FORWARD;
PROCEDURE Finish_Check; FORWARD;
PROCEDURE Print_Check; FORWARD;
PROCEDURE Make_Deposit; FORWARD;
PROCEDURE View_Register; FORWARD;
PROCEDURE Scroll_Forward; FORWARD;
PROCEDURE Scroll_Backward; FORWARD;
PROCEDURE View_Account; FORWARD;
PROCEDURE Verify_Status; FORWARD;
PROCEDURE GETAL; FORWARD;
PROCEDURE Get_Status; FORWARD;
PROCEDURE Error_report; FORWARD;

[GLOBAL] FUNCTION VALID1: INTEGER; FORWARD;
[GLOBAL] FUNCTION Take15: INTEGER; FORWARD;
[GLOBAL] FUNCTION PASSKY: INTEGER; FORWARD;
[GLOBAL] FUNCTION CHKCHK: INTEGER; FORWARD;
[GLOBAL] FUNCTION RANGE: INTEGER; FORWARD;

FUNCTION Integer_to_Text (Arg: INTEGER): Integer_string;
VAR	Text_value:	VARYING [Integer_string_length] OF CHAR;
BEGIN
WRITEV(Text_value, Arg:Integer_string_length);
Integer_to_Text := Text_value;
END;

FUNCTION Text_to_Integer (Arg: PACKED ARRAY[I..J:INTEGER] OF CHAR): INTEGER;
VAR	Integer_value:	INTEGER;
BEGIN
READV(Arg, Integer_value);
Text_to_Integer := Integer_value;
END;

FUNCTION Trim(Arg: PACKED ARRAY[I..J: INTEGER] OF CHAR): VAR80;
TYPE	$WORD	= [WORD] 0..65535;
VAR	LEN:	$WORD;
[EXTERNAL] PROCEDURE STR$TRIM(
			%STDESCR Outstring:	PACKED ARRAY[I..J: INTEGER] OF CHAR;
			%STDESCR Instring:	[READONLY] PACKED ARRAY[K..L: INTEGER] OF CHAR;
			VAR	 Outlen:	$WORD
		     ); EXTERNAL;
BEGIN
STR$TRIM(Arg, Arg, Len);
Trim := SUBSTR(Arg, 1, Len);
END;


PROCEDURE Initialize_Account;

{ Read from file SAMP.DAT into internal variables. 
  Set up the workspace for checks and fill in the check form 
  with the account's name, address, and account number. }

LABEL	1000;

BEGIN

{ Open file, get account data}

OPEN (FILE_VARIABLE := Sampfile, FILE_NAME := 'FMS$EXAMPLES:SAMP.DAT',
	HISTORY := READONLY, ERROR := CONTINUE);
IF STATUS(Sampfile) <> 0 THEN IO_Error_Handler;
RESET (Sampfile, ERROR := CONTINUE);
IF STATUS(Sampfile) <> 0 THEN IO_Error_Handler;
READ (Sampfile, Sample, ERROR := CONTINUE);
Account := Sample.Account;
IF STATUS(Sampfile) <> 0 THEN IO_Error_Handler;

{ Read the remaining records into the check register, counting them.
 The last record has the current balance, and some record has the 
 last check number used (not necessarily the last record).}

LastCheckNumber := 0;
LastRegisterNumber := 0;
WHILE LastRegisterNumber < RegisterSize DO
    BEGIN
    IF STATUS(Sampfile) <> 0 
    THEN
	BEGIN
	IO_Error_Handler;
	GOTO 1000;
	END
    ELSE
	READ (Sampfile, Sample, ERROR := CONTINUE) ;
    LastRegisterNumber := LastRegisterNumber + 1;
    Registeritem[ LastRegisterNumber ] := Sample.Register;
    IF Registeritem[LastRegisterNumber].Num <> '    '
    THEN 
	READV (Registeritem[LastRegisterNumber].Num, LastCheckNumber);
    END;

{ Reached here without hitting end of file.  Ignore remaining records.}

EOF_Cleanup;
1000: END;

PROCEDURE EOF_Cleanup;

{ Reach here as result of end of file--last record tried didn't read.
  Check for data file in error.
  Take balance from last record read.
  Set session sums to zero to say no activity yet. }

BEGIN
IF LastRegisterNumber = 0
THEN 
    BEGIN
    WRITELN ('DATA FILE IN ERROR');
    HALT;
    END;

READV(Registeritem[LastRegisterNumber].Balance, Current_Balance);
Starting_balance := Current_Balance;
TotalDeposit := 0;
TotalPayment := 0;

{ Set up the check workspace once so we don't have to do it every time.}

Format_Check;
END;

PROCEDURE IO_Error_Handler;

{ If EOF, close file and cleanup, otherwise use default error handling. }

BEGIN
IF STATUS(Sampfile) < 0
THEN
    BEGIN
    CLOSE (Sampfile);
    EOF_Cleanup;
    END;
END;

PROCEDURE Format_Check;

{ Format account data onto check form in the check workspace. }



BEGIN
  FDV$SWKSP( WKSP := Checkwksp); 
  FDV$LOAD( FRMNAM := 'CHECK' );
  With Account DO
      BEGIN
      FDV$PUT( FLDVAL := Trim(First) + ' ' + SUBSTR(Middle,1,1) + '. ' + Trim(Last), 
		FLDNAM := 'NAME');
      FDV$PUT( FLDVAL := Street, FLDNAM := 'STREET' );
      FDV$PUT( FLDVAL :=  Trim(City) + ', ' + Trim(State) + ' ' + Trim(Zip), 
	      FLDNAM :=  'CSZ' );
      FDV$PUT( FLDVAL := Homeph, FLDNAM := 'HOMEPH' );
      FDV$PUT( FLDVAL := Acctno, FLDNAM := 'ACCTNO' );
      FDV$SWKSP( WKSP := Workspace);
      END;
END;

PROCEDURE MENU;

{ Accept inputs from the menu form and dispatch to the
  appropriate routine.  Repeat until option 1 (exit) is
  chosen.  The UARs in the form guarantee that we get back
  only inputs '1'-'5' with the correct terminators.
  Options are:
	1 => Exit
	2 => Write checks
	3 => Make deposit
	4 => View register
	5 => View account data	}

VAR	Option: PACKED ARRAY [1..1] OF CHAR;
BEGIN
REPEAT
    FDV$CDISP( FRMNAM := 'MENU' );	Verify_Status;
    FDV$GET( Option, Terminator, 'OPTION' );
    CASE Option::CHAR OF
	'1':	EXIT;
	'2':	Write_Check;
	'3':	Make_Deposit;
	'4':	View_Register;
	'5':	View_Account;
	END;
UNTIL Option = '1';
END;

PROCEDURE EXIT;

{ Processing for EXIT menu choice.
  Do nothing but return. }

BEGIN
END;

PROCEDURE Write_Check;

{ Write one or more checks. }

BEGIN

{ Turn on LED 3 on the VT100 during this routine, just to show how.}

FDV$LEDON( LEDNO := 3 );

{ Mark WORKSPACE not displayed so it doesn't show up during a refresh.
  Put up CHECK form from already loaded workspace
  and display current balance. }

FDV$NDISP;
FDV$SWKSP( WKSP := Checkwksp );
FDV$DISPW;

FDV$PUT( FLDVAL := Integer_to_Text(Current_Balance), FLDNAM := 'BALANCE' );

{ Process checks until a keypad period is read}

Terminator := 0;
WHILE Terminator <> FDV$K_KP_PER DO
    BEGIN
    Process_Check;				{ Process one check}
    Finish_Check;				{ Give options for continuing}
    END;

{ Turn off LED 3 on VT100}

FDV$LEDOF( LEDNO := 3 );
FDV$SWKSP( WKSP := Workspace );

END;

PROCEDURE Process_Check;

{ If input is terminated by kpd period, return with no action
  Else deduct from balance and enter into register.
  Note that a UAR in the form guarantees that the amount of
  the check is always less than or equal to the balance.
  Note that the form function key UAR  allows only kpd period
  as terminator (other than FDV$K_FT_NTR). }

LABEL	1000;
VAR	Amount_paid:	INTEGER;

BEGIN
FDV$PUT( 
FLDVAL := SUBSTR(Integer_to_Text(LastCheckNumber+1),Integer_string_length-1,2),
FLDNAM := 'NUMBER' );
FDV$GETAL( FLDTRM := Terminator );	{ Ignore the field value }
IF Terminator = FDV$K_KP_PER THEN GOTO 1000;

{ If the check wouldn't fit in the register, don't process, just
  give error message, wait for acknowledgement, and return }

IF LastRegisterNumber = RegisterSize
THEN 
    BEGIN
    FDV$PUTL( VAL := 'Register full, cannot enter check' );
    FDV$WAIT;
    GOTO 1000;
    END;



{ Update register array and counters}

LastRegisterNumber := LastRegisterNumber + 1;
LastCheckNumber := LastCheckNumber + 1;

{ Get amount from check.
 Update balance (in memory and on screen) and session sums.
 Transfer form values to register item. }

WITH Registeritem[LastRegisterNumber] DO
    BEGIN
    FDV$RET( FLDVAL := Amtpay, FLDNAM := 'AMTPAY' );
    READV (Amtpay, Amount_paid);
    Current_Balance := Current_Balance - Amount_paid;
    TotalPayment := TotalPayment + Amount_paid;

    FDV$PUT( FLDVAL := Integer_to_Text(Current_Balance), FLDNAM := 'BALANCE' );
    FDV$RET( FLDVAL := Balance, FLDNAM := 'BALANCE');

    Amtdep := '      ';
    FDV$RET( FLDVAL := Num, FLDNAM := 'NUMBER' );
    FDV$RET( FLDVAL := Date, FLDNAM := 'DATE' );
    FDV$RET( FLDVAL := Mempayto, FLDNAM := 'PAYTO' );	{Note: not from check's MEMO}

    END;

1000: END;

PROCEDURE Finish_Check;

{ Finish off check processing by giving operator
  three options:
	RETURN	Write another check
	KPD 0	Print the check into file SAMPCH.DAT
	KPD .	Return to menu
  Check to see if check write was aborted by kpd per.
  If so, then don't give any further choice, just abort.
  Note that form function key UAR allows only the above 
  terminators to get through. }

BEGIN
IF Terminator <> FDV$K_KP_PER 
THEN
    BEGIN
    
    { Tell the operator that the check has been paid by overlaying with
     a new form, using the normal workspace, thereby saving the check 
     workspace in case another check is to be written. }
    
    FDV$SWKSP( WKSP := Workspace );
    FDV$DISP( FRMNAM := 'CHECK_DONE' );	Verify_Status;
    
    { Wait for operator to enter either KPD period, NTR, or KPD zero.
     Print the check as many times as requested.
     (Note that a UAR on the form guarantees that only those terminators
     are accepted).
     Process accordingly. }
    
    FDV$WAIT( FLDTRM := Terminator );
    WHILE Terminator = FDV$K_KP_0 DO
	BEGIN
        Print_Check;				{ Print the check}
        FDV$WAIT( FLDTRM := Terminator );
	END;

    { If choice is to quit,
      then mark check wksp not displayed so it doesn't appear during refresh
      else mark normal workspace (occupied by CHECK_DONE form) not displayed
	so it doesn't show during refresh and then clear its lines.
	(Clearing the space occupied by the CHECK_DONE form, lines 20-23,
	is better done by overlaying a blank form to
	avoid having to know the line numbers to clear.) }

    IF Terminator = FDV$K_KP_PER
    THEN
	BEGIN
	FDV$SWKSP( WKSP := Checkwksp );
	FDV$NDISP;
	END
    ELSE    
	BEGIN    
	FDV$NDISP;
	FDV$CLEAR( LINE := 20, LINECNT := 4 );
	FDV$SWKSP( WKSP := Checkwksp );
	END;

    { Going to write another check now or eventually, so:
      Clear out operator entered fields }

    FDV$PUTD( FLDNAM := 'AMTPAY' );
    FDV$PUTD( FLDNAM := 'MEMO' );
    FDV$PUTD( FLDNAM := 'PAYTO' );
    END;
END;

PROCEDURE Print_Check;

{ Print the check into the file SAMPCH.DAT
  Use the check workspace, then switch back to the normal wksp
  to keep things clean. }



{ Open check writing file.  Note there's a new version for every check.
 Switch workspaces }

VAR	I, Low_index, High_index, Length:	INTEGER;
	Firstl, Lastl:		PACKED ARRAY [1..2] OF CHAR;

BEGIN
OPEN (FILE_VARIABLE := Sampch, FILE_NAME := 'SAMPCH.DAT',
	HISTORY := NEW);
REWRITE (Sampch);
FDV$SWKSP( WKSP := Checkwksp );

{ Get the top and bottom lines of the check from the named data
 (first two characters). }

FDV$RETDN( NMDNAM := 'FIRST', NMDVAL := Firstl ); Verify_Status;
FDV$RETDN( NMDNAM := 'LAST', NMDVAL := Lastl );  Verify_Status;



{ Get lines from form.
 Convert to line printer style.
 Write to file. }

READV (Firstl, Low_index);
READV (Lastl,  High_index);
FOR i := Low_index TO High_index DO
    BEGIN
    FDV$RETFL( LINE := i, VAL := Line, LEN := Length );
    WRITE (Sampch, Line);
    END;
FDV$PUTL( VAL := 'Check written to file' );
CLOSE (Sampch);
FDV$SWKSP( WKSP := Workspace );
END;

PROCEDURE Make_Deposit;

{ Make a deposit, enter into check register
  Cancel on keypad period.
  Note that the form function key UAR allows only kpd period. }

{ Put up deposit form with current balance}

LABEL	1000;
VAR	Amount_deposited:	INTEGER;
	Done:			Fix80;

BEGIN
FDV$CDISP( FRMNAM := 'DEPOSIT' );	Verify_Status;
FDV$PUT( FLDVAL := Integer_to_Text(Current_Balance), FLDNAM := 'CURBAL' );

{ Get deposit amount and memo from operator.
 Abort on kpd period. }

FDV$GETAL( FLDVAL := Deposit::Deposit_as_string, FLDTRM := Terminator );
IF Terminator = FDV$K_KP_PER THEN GOTO 1000;

{ Have deposit information now. If no room in check register, must abort. }

IF LastRegisterNumber = RegisterSize
THEN
    BEGIN
    FDV$PUTL( VAL := 'Register full, can''t enter deposit' );
    FDV$WAIT;
    GOTO 1000;
    END;

{ Add to balance and session sum.
 Check for overflow (program and form keep only six digits).
 Display new balance.
 Make entry in register. }

READV (Deposit.Amt, Amount_Deposited);
Current_Balance := Current_Balance + Amount_Deposited;
TotalDeposit := TotalDeposit + Amount_Deposited;
IF Current_Balance >= 1000000
THEN
    BEGIN
    Current_Balance := Current_Balance - 1000000;
    FDV$PUTL(  'Overflow in bank computer, only 6 digits allowed, we keep the rest of the money');
    FDV$WAIT;
    END;
FDV$PUT( FLDVAL := Integer_to_Text( Current_Balance ), FLDNAM := 'NEWBAL' );
LastRegisterNumber := LastRegisterNumber + 1;

WITH Registeritem[LastRegisterNumber] DO
    BEGIN
    Num := '    ';			{ Blank since it's not a check}
    Date := Deposit.Date;
    Mempayto := Deposit.Memo;
    Amtdep := Deposit.Amt;
    Amtpay := '      ';
    FDV$RET( FLDVAL := Balance, FLDNAM := 'NEWBAL' );
    END;

{ Sample of how to keep message texts stored with the form rather
 than in a program.  This is especially useful for multi-lingual
 environments: only the form text and the form named data must
 be changed and nothing in the program.  The trick is to store the
 response text in named data. This is the only example of how to do
 it in this program, but all messages could be stored like this.
 Message intent is: "Deposit made, press RETURN or ENTER to continue." }

FDV$RETDN( NMDNAM := 'DONE', NMDVAL := Done );
FDV$PUTL( VAL := Done );
FDV$WAIT;
1000: END;

PROCEDURE View_Register;

{ View the check register and scroll through it.
  Also display totals for current session. }

VAR	Deposit_Display, Payment_Display:	Integer_string;
	Nscroll:	PACKED ARRAY [1..2] OF CHAR;
	Nscroll_value:	INTEGER;
	Fake:		PACKED ARRAY [1..1] OF CHAR;

BEGIN

{ Put up register form.
  Check for current session totals overflow. If so, output 'OVRFLO'
  Put out summary of this session into indexed(4) fields. }

FDV$CDISP( FRMNAM := 'REGISTER' );	Verify_Status;
IF TotalDeposit < 1000000 THEN Deposit_Display := Integer_to_Text( TotalDeposit )
		    ELSE Deposit_Display := PAD('OVRFLO', ' ', SIZE(Deposit_Display));
IF TotalPayment < 1000000 THEN Payment_Display := Integer_to_Text( TotalPayment )
		    ELSE Payment_Display := PAD('OVRFLO', ' ', SIZE(Payment_Display));
FDV$PUT( FLDVAL := Integer_to_Text( Starting_balance ), FLDNAM := 'SUMMARY', FLDIDX := 1 );
FDV$PUT( FLDVAL := Deposit_Display, FLDNAM := 'SUMMARY', FLDIDX := 2 );
FDV$PUT( FLDVAL := Payment_Display, FLDNAM := 'SUMMARY', FLDIDX := 3 );
FDV$PUT( FLDVAL := Integer_to_Text( Current_Balance ), FLDNAM := 'SUMMARY', FLDIDX := 4 );

{ Get number of lines in scroll area from form named data (item 1).}

FDV$RETDI( NMDIDX := 1, NMDVAL := Nscroll);	Verify_Status;
READV(Nscroll, Nscroll_Value);

{ Put lines from check register array into scrolled area.
 The window is initially from item 1 up to item 
 min(Nscroll, LastRegisterNumber), that is, up to the size of the scrolled
 area or the size of the register, whichever is less. Assume there
 is at least one line (the initial deposit). }

Minwindow := 1;
FDV$PUTSC( FLDNAM := 'NUMBER', FLDVAL := Registeritem[1]::Register_as_string );	{ First line}
CurrentLine := 1;					{ Reg item cursor is on}
WHILE ( CurrentLine < LastRegisterNumber) AND (CurrentLine < Nscroll_Value ) DO
    BEGIN
    CurrentLine := CurrentLine + 1;
    FDV$PFT( FLDTRM := FDV$K_FT_SFW, FLDNAM := 'NUMBER' );
    FDV$PUTSC( FLDNAM := 'NUMBER', FLDVAL := Registeritem[CurrentLine]::Register_as_string );
    END;
Maxwindow := CurrentLine;

{ Get input from fake field of scrolled line and do what it says:
	kpd . or RETURN/ENTER	=> return to menu
	UPARROW or TAB		=> scroll forward
	DOWNARROW or BACKSPACE	=> scroll backward
	all others	        => ignore
 Note that there is no form function key UAR so this routine
 handles all terminators itself (by ignoring illegal ones). }

FDV$GET( FLDVAL := Fake, FLDTRM := Terminator, FLDNAM := 'FAKE' );
WHILE  (Terminator <> FDV$K_FT_NTR) AND (Terminator <> FDV$K_KP_PER) DO
    BEGIN
    IF (Terminator = FDV$K_FT_SFW) OR (Terminator = FDV$K_FT_SNX) THEN Scroll_Forward;
    IF (Terminator = FDV$K_FT_SBK) OR (Terminator = FDV$K_FT_SPR) THEN Scroll_Backward;
    FDV$GET( FLDVAL := Fake, FLDTRM := Terminator, FLDNAM := 'FAKE' );
    END;
END;

PROCEDURE Scroll_Forward;

{ CurrentLine is the line in the register that the cursor is on.
  MINWINDOW and MAXWINDOW delimit the part of the register
  currently displayed in the scrolled area. }



LABEL 1000;

{ If cursor is at the end of the register, report, and return}

BEGIN
IF CurrentLine = LastRegisterNumber
THEN 
    BEGIN
    FDV$PUTL( VAL := 'Last line of register' );
    GOTO 1000;
    END;

{ If cursor not at the last line of a window, just move down
 If cursor is  at the last line of a window, 
	move window forward one line,
	write the new last line to the last line of the scrolled area
 Move current line pointer forward. }

IF CurrentLine <> Maxwindow
THEN
    FDV$PFT( FLDTRM := FDV$K_FT_SFW, FLDNAM := 'NUMBER' )
ELSE
    BEGIN
    Minwindow := Minwindow + 1;
    Maxwindow := Maxwindow + 1;
    FDV$PFT( FLDTRM := FDV$K_FT_SFW, FLDNAM := 'NUMBER', 
		FLDVAL := Registeritem[Maxwindow]::Register_as_string );
    END;
CurrentLine := CurrentLine + 1;
1000: END;

PROCEDURE Scroll_Backward;

{ CurrentLine is the line in the register that the cursor is on.
  MINWINDOW and MAXWINDOW delimit the part of the register
  currently displayed in the scrolled area. }



LABEL 1000;

BEGIN

{ If the cursor is at the beginning of the register, report, and return}

IF CurrentLine = 1
THEN 
    BEGIN
    FDV$PUTL( VAL := 'First line of register' );
    GOTO 1000;
    END;

{ If cursor not at first line of the window, just move up
 If cursor is  at first line of the window, 
	move window back one line,
	write the new first line to the first line of the scrolled area
 Move current line pointer back. }

IF CurrentLine <> Minwindow
THEN 
    FDV$PFT( FLDTRM := FDV$K_FT_SBK, FLDNAM := 'NUMBER' )
ELSE 
    BEGIN
    Minwindow := Minwindow - 1;
    Maxwindow := Maxwindow - 1;
    FDV$PFT( FLDTRM := FDV$K_FT_SBK, FLDNAM := 'NUMBER', 
		FLDVAL := Registeritem[Minwindow]::Register_as_string );
    END;
CurrentLine := CurrentLine - 1;
1000: END;

PROCEDURE View_Account;

{ View the account data.
  If operator knows the secret word, let operator change
  the account data for this session. }

LABEL	1000;
VAR	Password:	PACKED ARRAY [1..12] OF CHAR;

BEGIN
FDV$CDISP( FRMNAM := 'ACCOUNT_DATA' );
FDV$PUTAL( FRMVAL := Account::Account_as_string );
FDV$PUTD( FLDNAM := 'SECRET');

{ This is not the best way to do protection, just a way of showing
 another FMS feature. At this point, supervisor mode is on, so the 
 only input allowed is to the password field.
 If operator doesn't know password, return to menu. }

FDV$GETAL( FLDTRM := Terminator );	{ Don't care about value now }
IF Terminator = FDV$K_KP_PER THEN GOTO 1000;
FDV$RET( FLDVAL := Password, FLDNAM := 'SECRET' );
IF Account.Opw <> Password THEN GOTO 1000;

{ Allow input from other fields and read from them.
 If read is terminated by keypad period, don't change account. }

FDV$SPOFF;
GETAL;			{ Read all fields}
FDV$SPON;		{ Not really needed, just showing off.}
IF Terminator <> FDV$K_KP_PER
THEN 
    BEGIN
    FDV$RETAL( FRMVAL := Account::Account_as_string );
    Format_Check;			{ Update the check workspace}
    END;
1000: END;

PROCEDURE GETAL;

{ Simulate action of FDV$GETAL, using FDV$GETAF and PFT.  Could
  replace this whole routine with a call on FDV$GETAL, but this shows
  how mainline program can allow same operator freedom of filling in
  fields but still regain control after each or changed field.
  Technique is to read any field, looking only at terminator, then do
  a process field terminator call to do the operator's action.
  This technique can be used with calls on FDV$GET or FDV$GETAF.
  This example starts with a GET on field '*', first field on form. }

LABEL	1000;
VAR	Junk:		PACKED ARRAY [1..132] OF CHAR;
	Fieldname:	PACKED ARRAY [1..6] OF CHAR;
	Fieldindex:	INTEGER;

BEGIN
FDV$GET( FLDTRM := Terminator, FLDNAM := '*' ); { Dont care about field value }
FDV$RETFN( FLDNAM := Fieldname);	{Get first field's name}
WHILE 1=1 DO
    BEGIN
    
    { Do any special processing for field FIELDNAME$ at this point.
     ...
     Go to next or previous field or leave form. }
    
    { Note: PFT call will display error if FDV$DEBUG set thus the
      following check for special field terminators. This could be
      strengthened to (FDV$K_FT_NTR <= TERMINATOR <= FDV$K_FT_HLP)
      else PFT will return an error. }

    IF Terminator = FDV$K_KP_PER THEN GOTO 1000; { Since Pascal has no RETURN }
    FDV$PFT( FLDTRM := Terminator );
    
    { If status is error, then PFT failed because terminator was 
     a keypad key, which means return to caller. }
    
    IF FMSStatus < 0 THEN GOTO 1000;
    IF Terminator = FDV$K_FT_NTR
    THEN 
	IF FMSStatus <> 2
	THEN
	    GOTO 1000
	ELSE 
	    BEGIN
	    FDV$PUTL( VAL := 'INPUT REQUIRED' );
	    FDV$BELL;
	    END;
    
    { Go get any other field, returning its name}
    
    FDV$GETAF( FLDVAL := Junk, FLDTRM := Terminator, 
		FLDNAM := Fieldname, FLDIDX := Fieldindex);
    END;
1000: END;

PROCEDURE Get_Status;

{ Check FMS status by calling FDV$STAT. 
  If not success (>0), print and stop. }



BEGIN
FDV$STAT( STATUS := FMSStatus, IOSTAT := RMSStatus);
IF FMSStatus <= 0 THEN Error_report;	{ and never come back}
END;

PROCEDURE Verify_Status;

{ Check FMS status by looking at the status recording variables.}

BEGIN
IF FMSStatus <= 0 THEN Error_report;
END;

PROCEDURE Error_report;

{ There is an error returned in the status variables. Detach the
  terminal to clean up, then print the errors, and stop. }

BEGIN
FDV$DTERM( TCA := Tca );
WRITELN ('FDV ERROR.');
WRITELN ('', 'FMS STATUS:', FMSStatus);
WRITELN ('', 'RMS STATUS:', RMSStatus);
GOTO 9999;
END;

FUNCTION VALID1;

{ UAR for field validation of any one character field. The
  UAR associated data has in it the legal characters allowed,
  except that blank is not allowed unless it appears before
  the first trailing blank.  For example an assoc. value string
  'aqr' implies that only the letters a, q, and r are allowed.
  A string ' aqr' means that blank is acceptable in addition
  to a, q, and r. Note that this routine is case sensitive
  (that is, it checks for correct case).  You can get around
  case sensitivity by using the force upper case field attribute
  and putting only capitals into the UAR associated value
  string.

  This routine can be used with any form and field since 
  it determines the context for itself. }

VAR	Fldname:	PACKED ARRAY [1..31] OF CHAR;
	FValue:		PACKED ARRAY [1..1] OF CHAR;
	Fieldindex:	INTEGER;
	Atca:		^UNSIGNED;{ Holds TCA address }
	Awksp:		^UNSIGNED; { Holds WKSP address }
	Frmnam:		Fix80;    { Holds form name }
	Uarval:		Fix80;    { Associated data for UAR }
	Curpos:		INTEGER;  { Holds cursor pos. }
	Fldtrm:		INTEGER;  { Field terminator - latest call }
	Insovr:		INTEGER;  { Holds insovr mode }
	Hlpnum:		INTEGER;  { Holds help num. }

BEGIN
	
{ Retrieve context: we will ignore TCA address, WKSP address, FRMNAM, 
	CURPOS, FLDTRM, and INSOVR, using only UARVAL, and only the
	initial, non-blank characters of it.
 Retrieve field name and index.
 Retrieve field value. }

FDV$RETCX( TCA := Atca, WKSP := Awksp, FRMNAM := Frmnam, UARVAL := Uarval,
    CURPOS := Curpos, FLDTRM := Fldtrm, INSOVR := Insovr, HLPNUM := Hlpnum );
FDV$RETFN( FLDNAM := Fldname, FLDIDX := Fieldindex);
FDV$RET( FLDVAL := Fvalue, FLDNAM := Fldname, FLDIDX := Fieldindex);



{ To be valid, FVALUE must occur in the string UARVAL. }

IF INDEX( Uarval, Fvalue) > 0
THEN 
    VALID1 := FDV$K_UVAL_SUC			{Success}
ELSE 
    BEGIN
    FDV$PUTL( VAL := 'Illegal value' );
    VALID1 := FDV$K_UVAL_FAIL;
    END;
END;

FUNCTION Take15;

{ Function key User Action Routine for the MENU form of SAMP.
  Convert keypad 1-5 into field values 1-5.
  Convert keypad period into field value 1.
  Reject all other function keys with error message. }

VAR	Mapping:	PACKED ARRAY [1..1] OF CHAR;
	Atca:		^UNSIGNED;{ Holds TCA address }
	Awksp:		^UNSIGNED; { Holds WKSP address }
	Frmnam:		Fix80;    { Holds form name }
	Uarval:		Fix80;    { Associated data for UAR }
	Curpos:		INTEGER;  { Holds cursor pos. }
	Fldtrm:		INTEGER;  { Field terminator - latest call }
	Insovr:		INTEGER;  { Holds insovr mode }
	Hlpnum:		INTEGER;  { Holds help num. }

BEGIN
	
{ Retrieve context: we will ignore TCA address, WKSP address, FRMNAM,
	UARVAL, CURPOS and INSOVR, using only FLDTRM. }

FDV$RETCX( TCA := Atca, WKSP := Awksp, FRMNAM := Frmnam, UARVAL := Uarval,
    CURPOS := Curpos, FLDTRM := Fldtrm, INSOVR := Insovr, HLPNUM := Hlpnum );

{ Do the conversion, displaying the value converted if found.
 Reject if not one of the expected terminators. }

Mapping := ' ';
IF Fldtrm = FDV$K_KP_1 THEN Mapping := '1';
IF Fldtrm = FDV$K_KP_2 THEN Mapping := '2';
IF Fldtrm = FDV$K_KP_3 THEN Mapping := '3';
IF Fldtrm = FDV$K_KP_4 THEN Mapping := '4';
IF Fldtrm = FDV$K_KP_5 THEN Mapping := '5';
IF Fldtrm = FDV$K_KP_PER THEN Mapping := '1';
IF Mapping <> ' '
THEN
    BEGIN
    FDV$PUT( FLDVAL := Mapping, FLDNAM := 'OPTION' );
	   { Treat as if it is RETURN}
    Take15 := FDV$K_UKEY_NTR;
    END
ELSE 
    BEGIN
    FDV$PUTL( VAL := 'Illegal function key' );
    FDV$SIGOP;
   { Just ignore it now}
    Take15 := FDV$K_UKEY_SUC;
    END;
END;

FUNCTION PASSKY;

{ General function key uar to pass only those from the (small) list
  in the uar associated value string and reject all others.
  The list is of the form: n <oneblank> n <oneblank> ... n <manyblanks>
  For example the string '110 112' would accept keypad period and 
  keypad zero but no other function keys. }

LABEL	1000;
VAR	Nexttrm:	INTEGER;
	NonBlank:	INTEGER;
	NextBlank:	INTEGER;
	Atca:		^UNSIGNED;{ Holds TCA address }
	Awksp:		^UNSIGNED; { Holds WKSP address }
	Frmnam:		Fix80;    { Holds form name }
	Uarval:		Fix80;    { Associated data for UAR }
	Curpos:		INTEGER;  { Holds cursor pos. }
	Fldtrm:		INTEGER;  { Field terminator - latest call }
	Insovr:		INTEGER;  { Holds insovr mode }
	Hlpnum:		INTEGER;  { Holds help num. }

BEGIN
	
{ Retrieve context: we will ignore TCA address, WKSP address, FRMNAM,
	INSOVR, and CURPOS, using only FLDTRM and UARVAL. }

FDV$RETCX( TCA := Atca, WKSP := Awksp, FRMNAM := Frmnam, UARVAL := Uarval,
    CURPOS := Curpos, FLDTRM := Fldtrm, INSOVR := Insovr, HLPNUM := Hlpnum );

{ Break up the list into numbers.  Check each against the actual
 terminator. If terminator found in list, return success. }

Nonblank := 1;		{ Beginning of string}
WHILE (Uarval[Nonblank] <> ' ') AND (Nonblank <= 80) DO
    BEGIN
    Nextblank := INDEX( SUBSTR(Uarval, Nonblank, LENGTH(Uarval) - Nonblank + 1), 
		       ' ');
    IF Nextblank = 0	THEN Nextblank := 80 
			ELSE Nextblank := Nextblank + Nonblank - 1;
    READV (SUBSTR(Uarval, Nonblank, Nextblank-Nonblank), Nexttrm);
    IF Fldtrm = Nexttrm
    THEN 
	BEGIN
	PASSKY := FDV$K_UKEY_TRM;	{Pass key to application}
	GOTO 1000;
	END;
    Nonblank := Nextblank + 1;
    END;
PASSKY := FDV$K_UKEY_ERR;		{Let FDV do the beeping}
1000: END;

FUNCTION CHKCHK;



{ UAR for SAMP CHECK form.  Makes sure that the check amount is
  less than or equal to the current balance.  If not, complain and
  change video attributes on balance field so the potential bouncer
  can see what there is to work with. }

VAR	Balance, Amtpay:	Integer_string;
	BlinkBold:		INTEGER;

BEGIN
FDV$RET( FLDVAL := Balance, FLDNAM := 'BALANCE' );
FDV$RET( FLDVAL := Amtpay, FLDNAM := 'AMTPAY' );
IF Text_to_Integer( Balance )  >= Text_to_Integer( Amtpay )
THEN
    BEGIN
    CHKCHK := FDV$K_UVAL_SUC;
    BlinkBold := -1;			{Restore to original}
    FDV$AFVA( VIDEO := BlinkBold, FLDNAM := 'BALANCE' );
    END
ELSE 
    BEGIN
    CHKCHK := FDV$K_UVAL_FAIL;
    BlinkBold := 3;			{Make it very visible}
    FDV$AFVA( VIDEO := BlinkBold, FLDNAM := 'BALANCE' );
    FDV$PUTL( VAL := 'Your balance doesn''t cover that much, reenter amount');
    END;
END;

FUNCTION RANGE;



{ General purpose UAR to check the range of any numeric item.  The
  associated UAR data must have one of the four forms:
	L,U<space><message>
	,U<space><message>
	L,<space><message>
	,<space><message>
  where L is lower bound, U is upper bound, and <message> is a
  optional error message in case the field value is out of bounds.
  If one of the bounds isn't given, it isn't checked for.  If neither
  bound is given, nothing is checked, everything succeeds.  If the
  UAR value doesn't have a comma, a FDV$_UAR error message is returned
  to the calling program by the FDV so the form designer has to go 
  back and do it right. If no <message> is given, a simple 
  "out of range U:L" message is given to the hapless operator.
  This UAR can work with any form and numeric field since it gets
  context itself.  Care must be taken with fields using field marker
  periods since those periods are not returned to the program. }

LABEL	1000, 2000;
VAR	N, Num:		INTEGER;
	Name:		PACKED ARRAY [1..31] OF CHAR;
	Number:		PACKED ARRAY [1..132] OF CHAR;
	Fieldindex:	INTEGER;
	Comma:		INTEGER;
	Blank:		INTEGER; 
	Atca:		^UNSIGNED;{ Holds TCA address - RETCX call }
	Awksp:		^UNSIGNED; { Holds WKSP address - RETCX call }
	Frmnam:		Fix80;    { Holds form name - RETCX call }
	Uarval:		Fix80;    { Associated data for UAR }
	Curpos:		INTEGER;  { Holds cursor pos. - RETCX call }
	Fldtrm:		INTEGER;  { Field terminator - latest call }
	Insovr:		INTEGER;  { Holds insovr mode - RETCX call }
	Hlpnum:		INTEGER;  { Holds help num. - RETCX call }

BEGIN

{ Get context which yields associated data value (ignore other stuff).
 Get current field name and index.
 Get field value. }

FDV$RETCX( TCA := Atca, WKSP := Awksp, FRMNAM := Frmnam, UARVAL := Uarval,
    CURPOS := Curpos, FLDTRM := Fldtrm, INSOVR := Insovr, HLPNUM := Hlpnum );
FDV$RETFN( FLDNAM := Name, FLDIDX := Fieldindex);
FDV$RET( FLDVAL := Number, FLDNAM := Name, FLDIDX := Fieldindex );
READV (Number, Num);

{ Find comma and blank delimiters.
 Check for lower bound. }

Comma := INDEX( Uarval, ',' );
Blank := INDEX(SUBSTR(Uarval, Comma+1, LENGTH(Uarval)-Comma), ' ');
IF Blank <> 0 THEN Blank := Comma + Blank ELSE Blank := Comma + 1;
IF Comma = 0
THEN 
    BEGIN
    RANGE := 0;		{ Illegal UARVAL string, FDV returns error}
    GOTO 2000;
    END;
IF Comma <> 1
THEN
    BEGIN
    READV ( SUBSTR(Uarval, 1, Comma-1), N);
    IF Num < N THEN GOTO 1000;
    END;

{ Check for upper bound}

IF Blank <> Comma + 1
THEN
    BEGIN
    READV (SUBSTR(Uarval, Comma+1, Blank-Comma-1), N);
    IF Num > N THEN GOTO 1000;
    END;

{ Passed both tests successfully, return success for UAR value}

RANGE := FDV$K_UVAL_SUC;
GOTO 2000;

{ Error in one of the bounds.
 Give error message: either from the UARVAL or make one up. }

1000: IF Uarval[Blank + 1] <> ' '
      THEN
	   FDV$PUTL( VAL := SUBSTR( Uarval, Blank + 1, 80-Blank ) )
      ELSE 
	   FDV$PUTL( VAL := 'Field value out of bounds. Must be in range' {+ ' "' +
			SUBSTR( Uarval, 1, Blank - 1 ) + '".'} );
FDV$SIGOP;		{Beep, too.}
RANGE := FDV$K_UVAL_FAIL;
2000: END;

BEGIN

{ Main routine of SAMP }

{ Initialize FMS 
   Attach default terminal
   Attach normal and check workspaces (order important for help
       and refresh during CHECK/CHECK_DONE time--try switching and see).
   Open form library, attach to channel 1
   Set keypad mode to application
   Set signal mode to bell (default, but it's fun to do). }

FDV$ATERM( TCA := Tca, SIZE := 12, CHANNEL := 2 );	Get_Status;
FDV$AWKSP( WKSP := Checkwksp, SIZE := 2000 );		Get_Status;
FDV$AWKSP( WKSP := Workspace, SIZE := 2000 );		Get_Status;
FDV$LOPEN( 'FMS$EXAMPLES:SAMP', 1 );			Get_Status;
FDV$SPADA( MODE := Application_mode );
FDV$SSIGQ( SIGMD := Bell_mode ); 

{ Set all future calls to return status to the two status recording
 variables FMSStatus and RMSStatus without having to call the 
 the FDV$STAT routine. }

FDV$SSRV( STATUS := FMSStatus, IOSTAT := RMSStatus );

{ Read in a few forms from the form library onto the dynamic
 resident form list.  You may be able to detect the difference
 in the form to form access times for those forms which have to be
 accessed from the form library on disk and those forms which are
 on the dynamic or static memory resident form list.  See the
 installation notes for this program (the LINK command) to see
 which forms are on the static memory resident form list. }
 
FDV$READ( FRMNAM := 'MENU', MEMLOC := Menu_form, SIZE := 2000, FRMSIZ := Size_menu );
FDV$READ( FRMNAM := 'CHECK', MEMLOC := Check_form, SIZE := 3000, FRMSIZ := Size_check );
FDV$READ( FRMNAM := 'DEPOSIT', MEMLOC := Dposit_form, SIZE := 2000, FRMSIZ := Size_dposit );

{ Initialize account information }

Initialize_Account;

{ Put up welcome form, wait for response}

FDV$CDISP( FRMNAM := 'WELCOME' );			Verify_Status;
FDV$WAIT;

{ Process all menu requests}

MENU;

{ Clean up and leave:
   Close form library.
   Reset keypad to numeric.
   Delete a form from dynamic mem. res. form list just to show how.
   Detach workspaces (not really necessary since DTERM would do it).
   Detach terminal. }

FDV$LCLOS;
FDV$SPADA( MODE := Numeric_mode );
FDV$DEL( FRMNAM := 'MENU' );
FDV$DWKSP( WKSP := Workspace );
FDV$DWKSP( WKSP := Checkwksp );
FDV$DTERM( TCA := Tca );
9999:;
END.