PROGRAM SAMPLE
	IMPLICIT NONE

C	SAMP -- The FMS Sample Application Program
C
C
C		      COPYRIGHT (c) 2004   BY
C	      HEWLETT PACKARD DEVELOPMENT COMPANY L.P.,   .
C
C THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
C ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
C INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER
C COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
C OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
C TRANSFERRED.
C
C THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE
C AND  SHOULD  NOT  BE   CONSTRUED  AS  A COMMITMENT  BY HEWLETT PACKARD. 
C 
C
C HEWLETT PACKARD  ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  
C OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY HEWLETT PACKARD.
C
C Author: S.P.Simon
C
C Data definitions
C
C FMS related
C

C
C	in the text module WORK_AREA in library SMPFORTXT, there are some
C	variables the declaration of which should be verified:
C		
C	INTEGER  WORKSPACE( 3 ),	!General workspace
C	1	 CHECKWKSP( 3 ),	!Check workspace
C	2	 TCA( 3 ),		!Terminal Control Area
C    	3	 MENU_FORM(500),	!Storage for memory resident form
C    	4	 CHECK_FORM(750),	!Storage for memory resident form
C    	5	 DPOSIT_FORM(500),	!Storage for memory resident form
C
	INCLUDE 'SMPFORTXT(WORK_AREA)'
	INCLUDE 'SMPFORTXT(STATUS_AREA)'
C
C	Money.
C	Note that all money is kept internally as integers (in cents).
C	It is only when the quantities are output that they look like
C	dollars, since all the money fields have periods as field
C	markers in the right places and they are right justified or 
C	fixed decimal.
C
C	Register data.
C	It would be most convenient to be able to define an array
C	of structures for the register, but it can't be done
C	in FORTRAN (it can be done for some other languages).  What's one
C	instead is to define a single structure into which to put data via
C	structure names and also an array of strings.  After data has been
C	be put into the structure, it is copied to the array for convenience
C	in scrolling.

C
C	Initialize FMS 
C	Attach default terminal
C	Attach normal and check workspaces (order inportant for help
C	  and refresh during CHECK/CHECK_DONE time--try switching and see).
C	Open form library, attach to channel 1
C	Set keypad mode to application
C	Set signal mode to bell (default, but it's fun to do)
C



	CALL FDV$ATERM( %DESCR(TCA),12 ,2 )
	CALL GET_AND_CHECK_FMSSTATUS
	CALL FDV$AWKSP( %DESCR(CHECKWKSP), 2000 )
	CALL GET_AND_CHECK_FMSSTATUS()
	CALL FDV$AWKSP( %DESCR(WORKSPACE), 2000 )
	CALL GET_AND_CHECK_FMSSTATUS()
	CALL FDV$LOPEN( 'FMS$EXAMPLES:SAMP', 1 )
	CALL GET_AND_CHECK_FMSSTATUS()
	CALL FDV$SPADA( 1 )
	CALL FDV$SSIGQ( 0 )
C
C	Set all future calls to return status to the two status recording
C	variables FMSSTATUS and RMSSTATUS without having to call the 
C	the FDV$STAT routine.
C
	CALL FDV$SSRV( FMSSTATUS, RMSSTATUS )
C
C	Read in a few forms from the form library onto the dynamic
C	resident form list.  You may be able to detect the difference
C	in the form to form access times for those forms which have to be
C	accessed from the form library on disk and those forms which are
C	on the dynamic or static memory resident form list.  See the
C	installation notes for this program (the LINK command) to see
C	which forms are on the static memory resident form list.
C
	CALL FDV$READ( 'MENU', %DESCR(MENU_FORM), 2000, SIZE_MENU)
	CALL FDV$READ( 'CHECK', %DESCR(CHECK_FORM), 3000, SIZE_CHECK)
	CALL FDV$READ( 'DEPOSIT', %DESCR(DPOSIT_FORM), 2000, SIZE_DPOSIT)
C
C	Initialize account information 
C
	CALL INIT_ACCOUNT()
C	
C	 Put up welcome form, wait for response
C	
	CALL FDV$CDISP( 'WELCOME' )
	CALL CHECK_FMSSTATUS()

	CALL FDV$WAIT
C	
C	 Process all menu requests
C	

	CALL MENU()

C	
C	 Clean up and leave:
C	   Close form library.
C	   Reset keypad to numeric.
C	   Delete a form from dynamic mem. res. form list just to show how.
C	   Detach workspaces (not really necessary since DTERM would do it).
C	   Detach terminal.
C	
	CALL FDV$LCLOS
	CALL FDV$SPADA( 0 )
	CALL FDV$DEL( 'MENU' )
	CALL FDV$DWKSP( %DESCR(WORKSPACE) )
	CALL FDV$DWKSP( %DESCR(CHECKWKSP) )
	CALL FDV$DTERM( %DESCR(TCA))
	END

	SUBROUTINE INIT_ACCOUNT
C	
C		Read from file SAMP.DAT into internal variables.
C		Set up the workspace for checks and fill in the check form 
C		with the account's name, address, and account number.
C	
	IMPLICIT NONE

	INCLUDE 'SMPFORTXT(REGISTER_COMMON)'
	INCLUDE 'SMPFORTXT(ACCOUNT_COMMON)'
C	
C	 Open file, get account data
C	
	OPEN(UNIT=5, STATUS='OLD', READONLY, FILE='FMS$EXAMPLES:SAMP.DAT')
	READ (UNIT=5, FMT=10, END=100) ACCOUNT
10	FORMAT(A)
	
C	 Read the remaining records into the check register, counting them.
C	 The last record has the current balance, and some record has the 
C	 last check number used (not necessarily the last record).
C	 Note that in FORTRAN the record is read into the array and reference
C	 to the check number is via a substring rather than symbolically.
C	 Other languages may access differently.
	
	LASTCHNUM = 0
	LASTREGNUM = 0 
	DO WHILE (LASTREGNUM .LT.  REGSIZE)
	    READ (UNIT=5, FMT=20, END=100) REGARRAY(LASTREGNUM+1)
20	    FORMAT(A)
	    LASTREGNUM = LASTREGNUM + 1
	    IF ( REGARRAY(LASTREGNUM)(1:4) .NE. '    ' ) THEN
		READ(REGARRAY(LASTREGNUM)(1:4),'(I4)') LASTCHNUM
	    ENDIF
	ENDDO
	
C	 Reached here without hitting end of file, should probably print
C	 message or something, except that this is just a l'il ol' demo.
C	 As it is, just fall through and ignore remaining records.

100	CLOSE(5)

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

	IF (LASTREGNUM .EQ. 0) THEN
	    PRINT *,'DATA FILE IN ERROR'
	    STOP ' '
	ENDIF

	READ(REGARRAY(LASTREGNUM)(59:64),'(I6)') BALANCE
	SBALANCE = BALANCE
	TOTDEP = 0
	TOTPAY = 0

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

	CALL FORMAT_CHECK()
	RETURN
	END

	SUBROUTINE FORMAT_CHECK
    	INTEGER TRIM_LENGTH_FIRST, TRIM_LENGTH_CITY
C	
C		Format account data onto check form in the check workspace.
C	
	INCLUDE 'SMPFORTXT(ACCOUNT_COMMON)'
	INCLUDE 'SMPFORTXT(WORK_AREA)'
C
C		Call the system routine STR$TRIM to trim trailing blanks
C		from the first name and the city name.
C
    	CALL STR$TRIM (TRIM_FIRST, FIRST, TRIM_LENGTH_FIRST)
    	CALL STR$TRIM (TRIM_CITY, CITY, TRIM_LENGTH_CITY)
C
C		Format the check.
C
	CALL FDV$SWKSP( %DESCR(CHECKWKSP) )
	CALL FDV$LOAD( 'CHECK' )
	CALL FDV$PUT( 
	1	TRIM_FIRST(1:TRIM_LENGTH_FIRST) // ' ' // 
	1	MIDDLE(1:1) // '. ' // LAST, 'NAME' )
	CALL FDV$PUT( STREET, 'STREET' )
	CALL FDV$PUT( TRIM_CITY(1:TRIM_LENGTH_CITY) // ', ' 
	1	// STATE // ' ' // ZIP , 'CSZ' )
	CALL FDV$PUT( HOMEPH, 'HOMEPH' )
	CALL FDV$PUT( ACCTNO, 'ACCTNO' )
	CALL FDV$SWKSP( %DESCR(WORKSPACE) )
	RETURN
	END

	SUBROUTINE MENU
C	
C		Accept inputs from the menu form and dispatch to the
C		appropriate routine.  Repeat until option 1 (exit) is
C		chosen.  The UARs in the form guarantee that we get back
C		only inputs '1'-'5' with the correct terminators.
C		Options are:
C			1 => Exit
C			2 => Write checks
C			3 => Make deposit
C			4 => View register
C			5 => View account data
C	
	IMPLICIT NONE
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*1 OPTION
	INTEGER TRANSFER_CONTROL
	OPTION = ' '

	DO WHILE (OPTION .NE. '1')
	    CALL FDV$CDISP( 'MENU' )
	    CALL CHECK_FMSSTATUS()
	    CALL FDV$GET( OPTION, TERMINATOR, 'OPTION' )
	    CALL CHECK_FMSSTATUS()

	    READ (OPTION,'(I1)') TRANSFER_CONTROL
	    GOTO (100,20,30,40,50) TRANSFER_CONTROL

C
20	    CALL WRITE_CHECK()
	    GOTO 100
C
30	    CALL MAKE_DEPOSIT()
	    GOTO 100
C
40	    CALL VIEW_REGISTER()
	    GOTO 100
C
50	    CALL VIEW_ACCOUNT_DATA()

100	ENDDO
	RETURN
	END

	SUBROUTINE WRITE_CHECK
C	
C		Write one or more checks
C	
	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(REGISTER_COMMON)'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*6 BALANCE_STRING

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

	CALL FDV$LEDON( 3 )

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

	CALL FDV$NDISP
	CALL FDV$SWKSP( %DESCR(CHECKWKSP) )
	CALL FDV$DISPW

	WRITE(BALANCE_STRING, '(I6)') BALANCE
	CALL FDV$PUT( BALANCE_STRING, 'BALANCE' )

C	 Process checks until a keypad period is read

	TERMINATOR = 0
	DO WHILE (TERMINATOR .NE. FDV$K_KP_PER)
	    CALL PROCESS_ONE_CHECK()
	    CALL GIVE_CONTINUE_OPTIONS()
	ENDDO

C	 Turn off LED 3 on VT100

	CALL FDV$LEDOF( 3 )
        CALL FDV$SWKSP( %DESCR(WORKSPACE) )
	RETURN
	END

	SUBROUTINE PROCESS_ONE_CHECK

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

	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(REGISTER_COMMON)'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*4 CHECK_NUM_STRING

	INTEGER AMTPAY

	WRITE(CHECK_NUM_STRING, '(I4)') LASTCHNUM+1
	CALL FDV$PUT( CHECK_NUM_STRING, 'NUMBER' )

	CALL FDV$GETAL( , TERMINATOR )
	IF (TERMINATOR .EQ. FDV$K_KP_PER) RETURN

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

	IF (LASTREGNUM .EQ. REGSIZE) THEN
	    CALL FDV$PUTL( 'Register full, can''t enter check' )
	    CALL FDV$WAIT
	    RETURN
	ENDIF

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

	CALL FDV$RET( RI_AMTPAY, 'AMTPAY' )
	READ(RI_AMTPAY,'(I6)') AMTPAY
	BALANCE = BALANCE - AMTPAY
	TOTPAY  = TOTPAY  + AMTPAY

	WRITE(RI_BALANCE, '(I6)') BALANCE
	CALL FDV$PUT( RI_BALANCE, 'BALANCE' )

	RI_AMTDEP = ' '
	CALL FDV$RET( RI_NUM, 'NUMBER' )
	CALL FDV$RET( RI_DATE, 'DATE' )
	CALL FDV$RET( RI_MEMPAYTO, 'PAYTO' )	! Note: not from check's MEMO

C	 Update register array and counters
C	 (Note that the two step update (form->regitem->regarray)
C	 is necessary in FORTRAN not necessarily in every language).

	LASTREGNUM = LASTREGNUM + 1
	LASTCHNUM  = LASTCHNUM  + 1
	REGARRAY( LASTREGNUM ) = REGITEM
	RETURN								
	END

	SUBROUTINE GIVE_CONTINUE_OPTIONS

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

	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	IF (TERMINATOR .EQ. FDV$K_KP_PER) RETURN

C	 Tell the operator that the check has been paid by overlaying with
C	 a new form, using the normal workspace, thereby saving the check 
C	 workspace in case another check is to be written.

	CALL FDV$SWKSP( %DESCR(WORKSPACE) )
	CALL FDV$DISP( 'CHECK_DONE' )
	CALL CHECK_FMSSTATUS()

C	 Wait for operator to enter either KPD period, NTR, or KPD zero.
C	 Print the check as many times as requested.
C	 (Note that a UAR on the form guarantees that only those terminators
C	 are accepted).
C	 Process accordingly.

	CALL FDV$WAIT( TERMINATOR )
	DO WHILE (TERMINATOR .EQ. FDV$K_KP_0)
	    CALL PRINT_THE_CHECK()
	    CALL FDV$WAIT( TERMINATOR )
	ENDDO

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

	IF (TERMINATOR .EQ. FDV$K_KP_PER) THEN
	    CALL FDV$SWKSP( %DESCR(CHECKWKSP) )
	    CALL FDV$NDISP
    	ELSE
	    CALL FDV$NDISP
	    CALL FDV$CLEAR( 20, 4 )
	    CALL FDV$SWKSP( %DESCR(CHECKWKSP) )
    	ENDIF

C	  Going to write another check now or eventually, so:

	CALL FDV$PUTD( 'AMTPAY' )
	CALL FDV$PUTD( 'MEMO' )
	CALL FDV$PUTD( 'PAYTO' )
	RETURN
	END

	SUBROUTINE PRINT_THE_CHECK

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

	IMPLICIT NONE
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*80	LINE
	CHARACTER*2	FIRSTL,
	1		LASTL

	INTEGER		FIRST_LINE_NUMBER,
	1		LAST_LINE_NUMBER,
	2		I,
    	3		LINELENGTH

C	 Open check writing file.  Note there's a new version for every check.
C	 Switch workspaces
C
	OPEN(UNIT=2, FILE='SAMPCH.DAT', STATUS='NEW', CARRIAGECONTROL='LIST',
	1	RECORDSIZE=80 )
	CALL FDV$SWKSP( %DESCR(CHECKWKSP) )

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

	CALL FDV$RETDN( 'FIRST', FIRSTL )
	CALL CHECK_FMSSTATUS()
	CALL FDV$RETDN( 'LAST', LASTL )
	CALL CHECK_FMSSTATUS()

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

	READ (FIRSTL, '(I2)') FIRST_LINE_NUMBER
	READ (LASTL,  '(I2)') LAST_LINE_NUMBER

	DO I = FIRST_LINE_NUMBER, LAST_LINE_NUMBER
	    CALL FDV$RETFL( I, LINE, LINELENGTH )
	    WRITE(2,'(A)') LINE(1:LINELENGTH)		!## , 1, LINELENGTH
	ENDDO
	CALL FDV$PUTL( 'Check written to file' )
	CLOSE (2)
        CALL FDV$SWKSP( %DESCR(WORKSPACE) )
	RETURN
	END

	SUBROUTINE MAKE_DEPOSIT

C		Make a deposit, enter into check register
C		Cancel on keypad period.
C		Note that the form function key UAR allows only kpd period.
C	
C	 Put up deposit form with current balance

	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(REGISTER_COMMON)'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

C	 Deposit data (Read via FDV$GETAL)

	CHARACTER*60	DEPOSIT
	CHARACTER*7	DEP_DATE
	EQUIVALENCE (DEPOSIT(1:), DEP_DATE)
	CHARACTER*6	DEP_CURBAL
	EQUIVALENCE (DEPOSIT(8:), DEP_CURBAL)
	CHARACTER*6	DEP_AMT
	EQUIVALENCE (DEPOSIT(14:), DEP_AMT)
	CHARACTER*6	DEP_NEWBAL
	EQUIVALENCE (DEPOSIT(20:), DEP_NEWBAL)
	CHARACTER*35	DEP_MEMO
	EQUIVALENCE (DEPOSIT(26:), DEP_MEMO)



	INTEGER DEP_AMT_VALUE
	CHARACTER*6	BALANCE_STRING
	CHARACTER*80	DONE

	CALL FDV$CDISP( 'DEPOSIT' )
	CALL CHECK_FMSSTATUS()

	WRITE (BALANCE_STRING, '(I6)') BALANCE

	CALL FDV$PUT( BALANCE_STRING, 'CURBAL' )

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

	CALL FDV$GETAL( DEPOSIT, TERMINATOR )
	IF (TERMINATOR .EQ. FDV$K_KP_PER) RETURN

C	 Have deposit information now. If no room in check register
C	 must abort.

	IF (LASTREGNUM .EQ. REGSIZE) THEN
	    CALL FDV$PUTL( 'Register full, can''t enter deposit' )
	    CALL FDV$WAIT
	    RETURN
	ENDIF

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

	READ (DEP_AMT, '(I6)') DEP_AMT_VALUE
	BALANCE = BALANCE + DEP_AMT_VALUE
	TOTDEP  = TOTDEP  + DEP_AMT_VALUE
	IF (BALANCE .GT. 999999) THEN
	    BALANCE = BALANCE - 1000000
	    CALL FDV$PUTL( 'Overflow in bank computer, only 6 digits '
	1		   //'allowed, we keep the rest of the money')
	    CALL FDV$WAIT
	ENDIF

	WRITE(RI_BALANCE, '(I6)') BALANCE
	CALL FDV$PUT( RI_BALANCE, 'NEWBAL' )
	RI_NUM 	= ' '				! Blank since it's not a check
	RI_DATE = DEP_DATE
	RI_MEMPAYTO = DEP_MEMO
	RI_AMTDEP = DEP_AMT
	RI_AMTPAY = ' '
	LASTREGNUM = LASTREGNUM + 1
	REGARRAY( LASTREGNUM ) = REGITEM

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

	CALL FDV$RETDN( 'DONE', DONE )
	CALL FDV$PUTL( DONE )
	CALL FDV$WAIT
	RETURN
	END

	SUBROUTINE VIEW_REGISTER

C		View the check register and scroll through it.
C		Also display totals for current session.
C	
C	 Put up register form.
C	 Check for current session totals overflow. If so, output 'OVRFLO'
C	 Put out summary of this session into indexed(4) fields.

	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(REGISTER_COMMON)'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*6 DEPDSP, PAYDSP, BALANCE_STRING
	CHARACTER*2 NSCROL
	INTEGER NSCROL_VALUE

	CHARACTER*100 FAKE

	CALL FDV$CDISP( 'REGISTER' )
	CALL CHECK_FMSSTATUS()

	IF (TOTDEP .LT. 1000000) THEN 
	    WRITE(DEPDSP, '(I6)') TOTDEP
	ELSE
	    DEPDSP = 'OVRFLO'
	ENDIF

	IF (TOTPAY .LT. 1000000) THEN
	    WRITE(PAYDSP, '(I6)') TOTPAY
	ELSE
	    PAYDSP = 'OVRFLO'
	ENDIF

	WRITE(BALANCE_STRING, '(I6)') SBALANCE
	CALL FDV$PUT( BALANCE_STRING,	'SUMMARY', 1 )
	CALL FDV$PUT( DEPDSP,   	'SUMMARY', 2 )
	CALL FDV$PUT( PAYDSP, 		'SUMMARY', 3 )
	WRITE(BALANCE_STRING, '(I6)') BALANCE
	CALL FDV$PUT( BALANCE_STRING,	'SUMMARY', 4 )

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

	CALL FDV$RETDI( 1, NSCROL )
	CALL CHECK_FMSSTATUS()

	READ (NSCROL, '(I2)') NSCROL_VALUE

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

	MINWINDOW = 1
	CALL FDV$PUTSC( 'NUMBER', REGARRAY(1) )		! First line
	CURLINE = 1					!  Reg item cursor is on

	DO WHILE (CURLINE .LT. LASTREGNUM .AND. CURLINE .LT. NSCROL_VALUE)
	    CURLINE = CURLINE + 1
	    CALL FDV$PFT( FDV$K_FT_SFW, 'NUMBER' )
	    CALL FDV$PUTSC( 'NUMBER', REGARRAY( CURLINE ) )
	ENDDO
	MAXWINDOW = CURLINE

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

	CALL FDV$GET( FAKE, TERMINATOR, 'FAKE' )

	DO WHILE (TERMINATOR .NE. FDV$K_FT_NTR .AND.
	1	  TERMINATOR .NE. FDV$K_KP_PER )

		IF (TERMINATOR .EQ. FDV$K_FT_SFW .OR.
	1	    TERMINATOR .EQ. FDV$K_FT_SNX)  THEN
		      CALL SCROLL_FORWARD()
		ELSE IF (TERMINATOR .EQ. FDV$K_FT_SBK .OR.
	1		 TERMINATOR .EQ. FDV$K_FT_SPR)  THEN
		      CALL SCROLL_BACKWARD()
		ENDIF
	    CALL FDV$GET( FAKE, TERMINATOR, 'FAKE' )
	ENDDO
	RETURN
	END

	SUBROUTINE SCROLL_FORWARD

C		CURLINE is the line in the register that the cursor is on.
C		MINWINDOW and MAXWINDOW delimit the part of the register
C		currently displayed in the scrolled area

	IMPLICIT NONE
	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(REGISTER_COMMON)'

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

	IF (CURLINE .EQ. LASTREGNUM) THEN
	    CALL FDV$PUTL( 'Last line of register' )
	    RETURN
	ENDIF

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

	IF (CURLINE .NE. MAXWINDOW) THEN
	    CALL FDV$PFT( FDV$K_FT_SFW, 'NUMBER' )
	ELSE
	    MINWINDOW = MINWINDOW + 1
	    MAXWINDOW = MAXWINDOW + 1
	    CALL FDV$PFT( FDV$K_FT_SFW, 'NUMBER', REGARRAY( MAXWINDOW ) )
	ENDIF
	CURLINE = CURLINE + 1
	RETURN
	END

	SUBROUTINE SCROLL_BACKWARD

C		CURLINE is the line in the register that the cursor is on.
C		MINWINDOW and MAXWINDOW delimit the part of the register
C		currently displayed in the scrolled area

	IMPLICIT NONE
	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(REGISTER_COMMON)'

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

	IF (CURLINE .EQ. 1) THEN
	    CALL FDV$PUTL( 'First line of register' )
	    RETURN
	ENDIF
	
C	 If cursor not at first line of the window, just move up
C	 If cursor is  at first line of the window, 
C		move window back one line,
C		write the new first line to the first line of the scrolled area
C	 Move current line pointer back
	
	IF (CURLINE .NE. MINWINDOW) THEN
	    CALL FDV$PFT( FDV$K_FT_SBK, 'NUMBER' )
	ELSE
	    MINWINDOW = MINWINDOW - 1
	    MAXWINDOW = MAXWINDOW - 1
	    CALL FDV$PFT( FDV$K_FT_SBK, 'NUMBER', REGARRAY( MINWINDOW ) )
	ENDIF
	CURLINE = CURLINE - 1
	RETURN
	END

	SUBROUTINE VIEW_ACCOUNT_DATA

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

	IMPLICIT NONE
	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(ACCOUNT_COMMON)'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*12 PASSWORD

	CALL FDV$CDISP( 'ACCOUNT_DATA' )
	CALL CHECK_FMSSTATUS()

	CALL FDV$PUTAL( ACCOUNT )
	CALL FDV$PUTD( 'SECRET')

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

	CALL FDV$GETAL( , TERMINATOR )		! Don't care about value now
	IF (TERMINATOR .EQ. FDV$K_KP_PER) RETURN
	CALL FDV$RET( PASSWORD, 'SECRET' )
	IF (OPW .NE. PASSWORD) RETURN

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

	CALL FDV$SPOFF
	CALL READ_ALL_FIELDS()
	CALL FDV$SPON			! Not really needed, just showing off.
	IF (TERMINATOR .NE. FDV$K_KP_PER) THEN
	    CALL FDV$RETAL( ACCOUNT )
	    CALL FORMAT_CHECK()
	ENDIF

	RETURN
	END

	SUBROUTINE READ_ALL_FIELDS

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

	IMPLICIT NONE
	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(WORK_AREA)'
	INCLUDE 'SMPFORTXT(STATUS_AREA)'

	CHARACTER*31	FIELDNAME
	INTEGER		FIELDINDEX

	CHARACTER*132	JUNK

	CALL FDV$GET( , TERMINATOR, '*' )		! Ignore the field value
	CALL FDV$RETFN( FIELDNAME, FIELDINDEX )		! Get first field's name

	DO WHILE (.TRUE.)

	    ! 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 .EQ. FDV$K_KP_PER) RETURN	! User wants out.
	    CALL FDV$PFT( TERMINATOR )	! Process action user desired.

	    ! If status is error, then PFT failed because terminator was 
	    ! a keypad key, which means return to caller.

	    IF (FMSSTATUS .LT. 0) RETURN

	    IF (TERMINATOR .EQ. FDV$K_FT_NTR) THEN
		IF (FMSSTATUS .NE. 2) THEN
			RETURN
		ELSE
			CALL FDV$PUTL( 'INPUT REQUIRED' )
			CALL FDV$BELL
		ENDIF
	    ENDIF

	    ! Go get any other field, returning its name

	    CALL FDV$GETAF( JUNK, TERMINATOR, FIELDNAME, FIELDINDEX )
	ENDDO
	RETURN
	END

	SUBROUTINE GET_AND_CHECK_FMSSTATUS

C	 Get the FMS status by calling FDV$STAT. 
C	 call the routine that checks the status

	IMPLICIT NONE
	INCLUDE 'SMPFORTXT(STATUS_AREA)'

	CALL FDV$STAT( FMSSTATUS, RMSSTATUS )

	CALL CHECK_FMSSTATUS()
	RETURN
	END

	SUBROUTINE CHECK_FMSSTATUS

C	 Check FMS status by looking at the status recording variables.

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(STATUS_AREA)'

	IF (FMSSTATUS .LE. 0) THEN 
	    !
	    ! There is an error returned in the status variables. Detach the
	    ! terminal to clean up, then print the errors, and STOP.
	    !
	    CALL FDV$DTERM( %DESCR(TCA))
	    PRINT *,'FDV ERROR.'
	    PRINT *,'FMS STATUS:',FMSSTATUS
	    IF (FMSSTATUS .EQ. FDV$K_IOL		.OR.
	1	FMSSTATUS .EQ. FDV$K_IOR) PRINT *,'RMS STATUS:',RMSSTATUS
	    STOP ' '
	    ENDIF

	RETURN
	END

	INTEGER FUNCTION VALID1

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

	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*31	FRMNAM, FLDNAME
	CHARACTER*82	UARVAL
	CHARACTER*1	FVALUE
	INTEGER 	ATCA, AWORKSPACE
	INTEGER		CURPOS, FLDTRM, INSOVR, FINDEX, HELPNUM

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

	CALL FDV$RETCX(ATCA,AWORKSPACE,
	1		%DESCR(FRMNAM), %DESCR(UARVAL), CURPOS, FLDTRM, INSOVR, HELPNUM )
        CALL GET_AND_CHECK_FMSSTATUS
	CALL FDV$RETFN( FLDNAME, FINDEX )
        CALL GET_AND_CHECK_FMSSTATUS
	CALL FDV$RET( FVALUE,  FLDNAME, FINDEX )
        CALL GET_AND_CHECK_FMSSTATUS
C	
C	 To be valid, FVALUE must occur in the string UARVAL
C	
	IF ( INDEX(UARVAL, FVALUE) .GT. 0) THEN
		VALID1 = FDV$K_UVAL_SUC			! Success
	ELSE
		CALL FDV$PUTL( 'Illegal value' )
        	CALL GET_AND_CHECK_FMSSTATUS
		VALID1 = FDV$K_UVAL_FAIL
	ENDIF
	RETURN
	END

	INTEGER FUNCTION TAKE15

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

	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*31	FRMNAM
	CHARACTER*1	UARVAL, VALUE
	INTEGER 	ATCA, AWORKSPACE
	INTEGER 	CURPOS, FLDTRM, INSOVR, HELPNUM

C	 Retrieve context: we will ignore TCA address, WKSP address, FRMNAM,
C		UARVAL, CURPOS and INSOVR, using only FLDTRM
	CALL FDV$RETCX( ATCA, AWORKSPACE,
	1		%DESCR(FRMNAM), %DESCR(UARVAL), CURPOS, FLDTRM, INSOVR, HELPNUM)



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

	IF (FLDTRM .EQ. FDV$K_KP_1) 	THEN
						VALUE = '1'
	ELSE IF (FLDTRM .EQ. FDV$K_KP_2) THEN
						VALUE = '2'
	ELSE IF (FLDTRM .EQ. FDV$K_KP_3) THEN
						VALUE = '3'
	ELSE IF (FLDTRM .EQ. FDV$K_KP_4) THEN
						VALUE = '4'
	ELSE IF (FLDTRM .EQ. FDV$K_KP_5) THEN
						VALUE = '5'
	ELSE IF (FLDTRM .EQ. FDV$K_KP_PER) THEN
						VALUE = '1'

	ELSE
	    CALL FDV$PUTL( 'Illegal function key' )
	    CALL FDV$SIGOP
	    ! Just ignore it now
	    TAKE15 = FDV$K_UKEY_SUC
	    RETURN
	ENDIF

C	VALUE was legal
C
	CALL FDV$PUT( VALUE, 'OPTION' )
	! Treat as if it is RETURN
	TAKE15 = FDV$K_UKEY_NTR
	RETURN
	END

	INTEGER FUNCTION PASSKY

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

	IMPLICIT NONE

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*31	FRMNAM
	CHARACTER*82	UARVAL
	INTEGER 	ATCA, AWORKSPACE
	INTEGER 	CURPOS, FLDTRM, INSOVR, HELPNUM
	INTEGER		NONBLANK, NEXTBLANK, NUMBER_ENTERED

C	 Retrieve context: we will ignore TCA address, WKSP address, FRMNAM,
C		INSOVR, and CURPOS, using only FLDTRM and UARVAL.
	CALL FDV$RETCX( ATCA, AWORKSPACE,
	1		%DESCR(FRMNAM), %DESCR(UARVAL), CURPOS, FLDTRM, INSOVR, HELPNUM )

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

	NONBLANK = 1		!  Beginning of string

	DO WHILE (UARVAL(NONBLANK:NONBLANK) .NE. ' ')
	    NEXTBLANK = INDEX( UARVAL(NONBLANK:), ' ') + NONBLANK - 1
	    READ (UARVAL(NONBLANK:), 10) NUMBER_ENTERED
10	    FORMAT(I<NEXTBLANK-NONBLANK>)

	    IF (FLDTRM .EQ. NUMBER_ENTERED) THEN
		PASSKY = FDV$K_UKEY_TRM 	! Pass key to application
	        RETURN
	    ENDIF
	    NONBLANK = NEXTBLANK + 1
	ENDDO
	PASSKY = FDV$K_UKEY_ERR			! Let FDV do the beeping
	RETURN
	END

	INTEGER FUNCTION CHKCHK

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

	IMPLICIT NONE

	INCLUDE 'FDVDEF'

	CHARACTER*6	BALANCE, AMTPAY
	INTEGER		BLINKBOLD, BALANCE_VALUE, AMTPAY_VALUE

	CALL FDV$RET( BALANCE, 'BALANCE' )
	CALL FDV$RET( AMTPAY, 'AMTPAY' )
	READ (BALANCE, '(I6)') BALANCE_VALUE
	READ (AMTPAY,  '(I6)') AMTPAY_VALUE

	IF (BALANCE_VALUE .GE. AMTPAY_VALUE) THEN
	    CHKCHK = FDV$K_UVAL_SUC
	    BLINKBOLD = -1			! Restore to original
	    CALL FDV$AFVA( BLINKBOLD, 'BALANCE' )
	ELSE
	    CHKCHK = FDV$K_UVAL_FAIL
	    BLINKBOLD = 3			! Make it very visible
	    CALL FDV$AFVA( BLINKBOLD, 'BALANCE' )
	    CALL FDV$PUTL( 'Your balance doesn''t cover that much, '
	1		    // 'reenter amount' )
	ENDIF
	RETURN
	END

	INTEGER FUNCTION RANGE

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

	INCLUDE 'FDVDEF'
	INCLUDE 'SMPFORTXT(WORK_AREA)'

	CHARACTER*31	FRMNAM, NAME
	CHARACTER*82	UARVAL
	CHARACTER*132	NUMBER
	INTEGER 	ATCA, AWORKSPACE
	INTEGER		CURPOS,	FLDTRM,	INSOVR,	INDEX_VAL, HELPNUM,
	1		COMMA,	BLANK,	NUMBER_VALUE,	TMP_VALUE

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

	CALL FDV$RETCX( ATCA, AWORKSPACE,
	1		%DESCR(FRMNAM),%DESCR(UARVAL), CURPOS, FLDTRM, INSOVR, HELPNUM )
	CALL FDV$RETFN( NAME, INDEX_VAL )
	CALL FDV$RET( NUMBER, NAME, INDEX_VAL )
	READ (NUMBER, '(I6)') NUMBER_VALUE
C	
C	 Find comma and blank delimiters.
C	 Check for lower bound.
C	
	COMMA = INDEX(UARVAL, ',')
	BLANK = INDEX(UARVAL(COMMA+1:), ' ') + COMMA

	IF (COMMA .EQ. 0) THEN
	    RANGE = 0		! Illegal UARVAL string, FDV returns error
	    RETURN
	ENDIF

	IF (COMMA.NE. 1) THEN
		READ (UARVAL, 10) TMP_VALUE
10		FORMAT (I <COMMA-1>)
		IF (NUMBER_VALUE .LT. TMP_VALUE) GOTO 200
	ENDIF

C	Check for upper bound

	IF (BLANK .NE. COMMA + 1) THEN
		READ (UARVAL(COMMA+1:), 20) TMP_VALUE
20		FORMAT( I <BLANK-COMMA-1>)
		IF (NUMBER_VALUE .GT. TMP_VALUE) GOTO 200
	ENDIF

C	 Passed both tests successfully, return success for UAR value

	RANGE = FDV$K_UVAL_SUC
	RETURN

200	CONTINUE

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

	IF (UARVAL(BLANK+1:BLANK+1) .NE. ' ') THEN
		CALL FDV$PUTL( UARVAL(BLANK+1:80) )
	ELSE
		CALL FDV$PUTL( 'Field value out of bounds.  Must be in'
	1		// ' range "' // UARVAL(1:BLANK-1) // '".')
	ENDIF

	CALL FDV$SIGOP			! Beep, too.
	RANGE = FDV$K_UVAL_FAIL
	RETURN
	END