IDENTIFICATION DIVISION.
PROGRAM-ID. SAMP.
*****************************************************************************
*   The FMS V2 Sample Application                                           *
*****************************************************************************
*
*		        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
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
	SELECT OUTPUT-FILE ASSIGN TO "SYS$DISK:".
	SELECT SAMP-FILE ASSIGN TO "SYS$DISK:".
DATA DIVISION.
FILE SECTION.
*
*	Create a sequential file for writing checks. (a new file per check)
FD	OUTPUT-FILE
	GLOBAL
	LABEL RECORDS ARE STANDARD
	VALUE OF ID IS "SAMPCH.DAT".
01 	POOL			PIC X(80).
FD	SAMP-FILE
	GLOBAL
	LABEL RECORDS ARE STANDARD
	VALUE OF ID IS "FMS$EXAMPLES:SAMP.DAT".
01	TEMP_ACCOUNT		PIC X(151).
WORKING-STORAGE SECTION.
01	SAMP_FORM_LIB		PIC X(21)			VALUE "FMS$EXAMPLES:SAMP.FLB".
01	TERM_CONTROL_AREA	PIC X(12)		GLOBAL.
01	WORKSPACE		PIC X(12)		GLOBAL.
01	CHECK_WORKSPACE		PIC X(12)		GLOBAL.
01	MENU_FORM		PIC X(2000).
01	CHECK_FORM		PIC X(3000).
01	DPOSIT_FORM		PIC X(2000).
01	TOTAL_DEPOSIT		PIC 9(6)		GLOBAL.
01	TOTAL_PAYMENTS		PIC 9(6)		GLOBAL.
01	CURRENT_BALANCE		PIC 9(6)		GLOBAL.
01	MAX_DEPOSIT		PIC 9(6)		GLOBAL	VALUE 999999.
01	MAX_PAYMENT		PIC 9(6)		GLOBAL	VALUE 999999.
01	KEY_PAD_MODE		PIC 9		COMP		VALUE 1.
01	SIGNAL_BELL		PIC 9		COMP		VALUE ZERO.
01	LOGICAL_UNIT		PIC 9(5)	COMP		VALUE 10.
01	LOGICAL_UNIT_TT		PIC 9(5)	COMP		VALUE 2.
01	FMS_STATUS		PIC S9(9)	COMP 	GLOBAL.
01	RMS_STATUS		PIC S9(9)	COMP 	GLOBAL.
01	TERMINATOR		PIC S9(9)	COMP	GLOBAL.
01	TERM_CONTROL_AREA_SIZE	PIC 9(5)	COMP		VALUE 12.
01	WORKSPACE_SIZE		PIC 9(5)	COMP	GLOBAL	VALUE 2000.
01	CHECK_WORKSPACE_SIZE	PIC 9(5)	COMP	GLOBAL	VALUE 2000.
01	MENU_FORM_SIZE		PIC 9(5)	COMP	GLOBAL	VALUE 2000.
01	CHECK_FORM_SIZE		PIC 9(5)	COMP	GLOBAL	VALUE 3000.
01	DPOSIT_FORM_SIZE	PIC 9(5)	COMP	GLOBAL	VALUE 2000.
01	UNUSED_TRUE_SIZE	PIC 9(5)	COMP	GLOBAL.
01	FIELD_INDEX		PIC S9(9)	COMP	GLOBAL.
01	CUR_LINE		PIC 99		COMP	GLOBAL.
01	MIN_WINDOW		PIC 99		COMP	GLOBAL.
01	MAX_WINDOW		PIC 99		COMP	GLOBAL.
*
*	Account Record format of first record in SAMP.DAT
*
01	ACCOUNT						GLOBAL.
	05	ACCT_NUMBER		PIC X(5).
	05				PIC X(7).
	05	ACCT_NAME.
		10	LAST_NAME	PIC X(20).
		10	FIRST_NAME	PIC X(15).
		10	MIDDLE_NAME	PIC X(15).
	05	ACCT_STREET		PIC X(30).
	05	CITY-STATE-ZIP.
		10	CITY		PIC X(20).
		10	STATE		PIC X(2).
		10	ZIP		PIC X(5).
	05	ACCT_HOME_PHONE		PIC X(10).
	05				PIC X(10).
	05	ACCT_PASSWORD		PIC X(12).
*
*	Register data format of 2nd thru n records in SAMP.DAT
*
01	REGISTER					GLOBAL.
	05	REGISTER_ITEM		OCCURS 50 TIMES.
		10	REG_ITEM_NUMBER		PIC 9(4).
		10	REG_ITEM_DATE		PIC X(7).
		10	REG_ITEM_MEMO_PAY_TO	PIC X(35).
		10	REG_ITEM_DEPOSIT_AMT	PIC 9(6).
		10	REG_ITEM_PAY_AMT	PIC 9(6).
		10	REG_ITEM_BALANCE	PIC 9(6).
		10	FILLER			PIC X(87).
				
01	REGISTER_MAX			PIC 9999	GLOBAL	VALUE 50.
01	FOUND-IN-REGISTER				GLOBAL.
	05	LAST_REGISTER_NUM	PIC 9(4).
	05	LAST_CHECK_NUM		PIC 9(4).
	05	ACCT_BALANCE		PIC 9(6).
*
*	Deposit data (READ via FDV$GETAL)
*
01	DEPOSIT						GLOBAL.
	05	DEPOSIT_DATE		PIC X(7).
	05	DEPOSIT_CUR_BAL		PIC 9(6).
	05	DEPOSIT_AMOUNT		PIC 9(6).
	05	DEPOSIT_NEW_BAL		PIC 9(6).
	05	DEPOSIT_MEMO		PIC X(35).
*
*	FMS SYMBOLS
*
COPY "FDVDEF".
*
*	FORM DESCRIPTION STARTS HERE
* NOTE:  The extract from the forms library has been modified to include
*	the GLOBAL declaration.
*
COPY "SAMPCOB".
*
/
PROCEDURE DIVISION.
0.
*+
* Initialize FMS 
*   Attach default terminal
*   Attach normal and check workspaces (order important for help
*       and refresh during CHECK/CHKDON 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)
*-
	CALL "FDV$ATERM" USING	BY DESCRIPTOR	TERM_CONTROL_AREA
			 	BY REFERENCE	TERM_CONTROL_AREA_SIZE
				BY REFERENCE	LOGICAL_UNIT_TT.
	CALL "GETSTAT".
	CALL "FDV$AWKSP" USING	BY DESCRIPTOR	CHECK_WORKSPACE
				BY REFERENCE	CHECK_WORKSPACE_SIZE.
	CALL "GETSTAT".
	CALL "FDV$AWKSP" USING	BY DESCRIPTOR	WORKSPACE
				BY REFERENCE	WORKSPACE_SIZE.
	CALL "GETSTAT".
	CALL "FDV$LOPEN" USING BY DESCRIPTOR	SAMP_FORM_LIB
				BY REFERENCE	LOGICAL_UNIT.
	CALL "GETSTAT".
	CALL "FDV$SPADA" USING	BY REFERENCE	KEY_PAD_MODE.
	CALL "FDV$SSIGQ" USING	BY REFERENCE	SIGNAL_BELL.
*+
* Set all future calls to return status to the two status recording
* variables FMS_STATUS and RMS_STATUS without having to call the 
* the FDV$STAT routine.
*-
	CALL "FDV$SSRV" USING	BY REFERENCE	FMS_STATUS
				BY REFERENCE	RMS_STATUS.
*+
* 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.
*-
	CALL "FDV$READ" USING	BY DESCRIPTOR	FORM-MENU
				BY DESCRIPTOR	MENU_FORM
				BY REFERENCE	MENU_FORM_SIZE
				BY REFERENCE	UNUSED_TRUE_SIZE.

	CALL "FDV$READ" USING	BY DESCRIPTOR	FORM-CHECK
				BY DESCRIPTOR	CHECK_FORM
				BY REFERENCE	CHECK_FORM_SIZE
				BY REFERENCE	UNUSED_TRUE_SIZE.

	CALL "FDV$READ" USING	BY DESCRIPTOR	FORM-DPOSIT
				BY DESCRIPTOR	DPOSIT_FORM
				BY REFERENCE	DPOSIT_FORM_SIZE
				BY REFERENCE	UNUSED_TRUE_SIZE.

*+
* Initialize account information 
*-
	CALL "INACCT".
*+
* Put up welcome form, Wait for response
*-
	CALL "FDV$CDISP" USING	BY DESCRIPTOR	FORM-WELCOM.
	CALL "SRVCHK".
	CALL "FDV$WAIT".
*+
* Process all menu requests
*-
	CALL "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.
*   Delete a form from dynamic mem. res. form list just to show how.
*-
	CALL "FDV$LCLOS".
	MOVE ZERO TO KEY-PAD-MODE.
	CALL "FDV$SPADA" USING	BY REFERENCE	KEY_PAD_MODE.
	CALL "FDV$DEL" 	USING	BY DESCRIPTOR	FORM-MENU.
	CALL "FDV$DWKSP" USING	BY DESCRIPTOR	WORKSPACE.
	CALL "FDV$DWKSP" USING	BY DESCRIPTOR	CHECK_WORKSPACE.
	CALL "FDV$DTERM" USING	BY DESCRIPTOR	TERM_CONTROL_AREA.
	EXIT PROGRAM.
IDENTIFICATION DIVISION.
PROGRAM-ID.	INACCT.
*+
*	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.
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	EOF-FLAG		PIC S9(9)	COMP.
PROCEDURE DIVISION.
0.
*+
* Open file, get account data.  The first record in the file is the
* account data. The 2nd thru n records are the check register data.
* The last record has the current balance data.
*-
	OPEN INPUT SAMP-FILE.
	READ SAMP-FILE INTO ACCOUNT
		AT END	DISPLAY "Error on SAMP.DAT"
			STOP RUN.
*+
* 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).
*-
	MOVE ZERO TO LAST_CHECK_NUM.
	SET EOF-FLAG TO FAILURE.
	PERFORM WITH TEST AFTER VARYING LAST_REGISTER_NUM FROM 1 BY 1 UNTIL	
	    EOF-FLAG IS SUCCESS OR LAST_REGISTER_NUM NOT < REGISTER_MAX
		MOVE SPACES TO TEMP_ACCOUNT
		READ SAMP-FILE NEXT RECORD INTO REGISTER_ITEM(LAST_REGISTER_NUM)
			AT END	SET EOF-FLAG TO SUCCESS END-READ
		IF EOF-FLAG IS FAILURE THEN
			INSPECT REG_ITEM_NUMBER(LAST_REGISTER_NUM) REPLACING ALL SPACE BY ZERO
			INSPECT REG_ITEM_DEPOSIT_AMT(LAST_REGISTER_NUM) REPLACING ALL SPACE BY ZERO
			INSPECT REG_ITEM_PAY_AMT(LAST_REGISTER_NUM) REPLACING ALL SPACE BY ZERO
			INSPECT REG_ITEM_BALANCE(LAST_REGISTER_NUM) REPLACING ALL SPACE BY ZERO
			IF REG_ITEM_NUMBER(LAST_REGISTER_NUM) NOT EQUAL ZERO THEN
				MOVE REG_ITEM_NUMBER(LAST_REGISTER_NUM) TO LAST_CHECK_NUM END-IF
			IF REG_ITEM_BALANCE(LAST_REGISTER_NUM) NOT EQUAL ZERO THEN
				MOVE REG_ITEM_BALANCE(LAST_REGISTER_NUM)
					TO ACCT_BALANCE, CURRENT_BALANCE END-IF
   		END-IF
	END-PERFORM.
	SUBTRACT 1 FROM LAST_REGISTER_NUM.
*+
* Check for data file in error.
* Take balance from last record read.
* Set session sums to zero to say no activity yet.
*-
	EVALUATE	TRUE
		WHEN   LAST_REGISTER_NUM = 1	STOP "SAMP.DAT data error on last_register_num"
		WHEN   LAST_CHECK_NUM	 = ZERO	STOP "SAMP.DAT data error on last_check_num"
		WHEN   ACCT_BALANCE	 = ZERO	STOP "SAMP.DAT data error on ACCT_BALANCE"
		WHEN   CURRENT_BALANCE	 = ZERO	STOP "SAMP.DAT data error on CURRENT_BALANCE"
	END-EVALUATE.
*+
* Set up the check workspace once so we don't have to do it every time.
*-
*
	CALL "FMTCHK".
	CLOSE SAMP-FILE.
	EXIT PROGRAM.
END PROGRAM INACCT.
IDENTIFICATION DIVISION.
PROGRAM-ID.	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
*-
*
DATA DIVISION.
WORKING-STORAGE SECTION.
PROCEDURE DIVISION.
0.
	CALL "FDV$CDISP" USING	BY DESCRIPTOR	FORM-MENU.
	MOVE "2" TO D-MENU-OPTION.
	CALL "FDV$PUT" USING	BY DESCRIPTOR	D-MENU-OPTION
				BY DESCRIPTOR	N-MENU-OPTION.
	CALL "FDV$GET" USING	BY DESCRIPTOR	D-MENU-OPTION
				BY REFERENCE	TERMINATOR
				BY DESCRIPTOR	N-MENU-OPTION.
	CALL "SRVCHK".
	EVALUATE D-MENU-OPTION
		WHEN  "1"	GO TO FINI
		WHEN  "2"	CALL "WRITCH"
		WHEN  "3"	CALL "MAKDEP"
		WHEN  "4"	CALL "VUEREG"
		WHEN  "5"	CALL "VUEACT"
	END-EVALUATE.
	GO TO 0.
FINI.
	EXIT PROGRAM.
IDENTIFICATION DIVISION.
PROGRAM-ID.	MAKDEP.
*+
*	Make a deposit, enter into check register
*	Cancel on keypad period.
*	Note that the form function key UAR allows only kpd period.
*+
DATA DIVISION.
WORKING-STORAGE SECTION.
01	REG_FULL_MSG		PIC X(35)		VALUE "Register full, can't enter deposit".
01	OVERFLOW_MSG		PIC X(35)		VALUE "Overflow, only 6 digits allowed.".
01	TMP			PIC X(80)		VALUE SPACE.
01	LARGE_TMP		PIC 9(9)	COMP.
01	BANK_SHARE		PIC 9(7)		VALUE 1000000.
01	FORM-DONE		PIC X(4)		VALUE "DONE".
PROCEDURE DIVISION.
0.
*+
* Put up deposit form with current balance
*-
	CALL "FDV$CDISP" USING	BY DESCRIPTOR	FORM-DPOSIT.
	CALL "SRVCHK".
	CALL "FDV$PUT" 	USING	BY DESCRIPTOR	CURRENT_BALANCE
				BY DESCRIPTOR	N-DPOSIT-CURBAL.
*+
* Get deposit amount and memo from operator.
* Abort on kpd period.
*-
	CALL "FDV$GETAL" USING	BY DESCRIPTOR	DEPOSIT
				BY REFERENCE	TERMINATOR.
	IF TERMINATOR = FDV$K_KP_PER THEN	GO TO FINI.
*+
* Have deposit information now.
* If no room in check register must abort.
*-
	IF LAST_REGISTER_NUM NOT LESS THAN REGISTER_MAX THEN
		CALL "FDV$PUTL" USING	BY DESCRIPTOR	REG_FULL_MSG
			CALL "FDV$WAIT"
			GO TO FINI.
*+
* Add to balance and session sum.
* Check for overflow (program and form keep only six digits).
* Display new balance.
* Make entry in register.
*-
	INSPECT DEPOSIT_AMOUNT REPLACING ALL SPACE BY ZERO.
	ADD DEPOSIT_AMOUNT TO TOTAL_DEPOSIT.
	ADD DEPOSIT_AMOUNT TO CURRENT_BALANCE ON SIZE ERROR 
		CALL "FDV$PUTL" USING	BY DESCRIPTOR	OVERFLOW_MSG
		ADD DEPOSIT_AMOUNT CURRENT_BALANCE GIVING LARGE_TMP
		SUBTRACT BANK_SHARE FROM LARGE_TMP GIVING CURRENT_BALANCE 
		CALL "FDV$WAIT".
	CALL "FDV$PUT" 	USING	BY DESCRIPTOR	CURRENT_BALANCE
				BY DESCRIPTOR	N-DPOSIT-NEWBAL.
	ADD 1 TO LAST_REGISTER_NUM.
	MOVE ZEROS TO REG_ITEM_NUMBER(LAST_REGISTER_NUM), REG_ITEM_PAY_AMT(LAST_REGISTER_NUM).
	MOVE DEPOSIT_DATE TO REG_ITEM_DATE(LAST_REGISTER_NUM).
	MOVE DEPOSIT_AMOUNT TO REG_ITEM_DEPOSIT_AMT(LAST_REGISTER_NUM).
	MOVE DEPOSIT_CUR_BAL TO REG_ITEM_BALANCE(LAST_REGISTER_NUM).
	MOVE DEPOSIT_MEMO TO REG_ITEM_MEMO_PAY_TO(LAST_REGISTER_NUM).
	CALL "FDV$RET" 	USING	BY DESCRIPTOR	REG_ITEM_BALANCE(LAST_REGISTER_NUM)
				BY DESCRIPTOR	N-DPOSIT-NEWBAL.
*+
* 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."
*-
	CALL "FDV$RETDN" USING	BY DESCRIPTOR	FORM-DONE
				BY DESCRIPTOR	TMP.
	CALL "FDV$PUTL" USING	BY DESCRIPTOR	TMP.
	CALL "FDV$WAIT".
FINI.
	EXIT PROGRAM.
END PROGRAM MAKDEP.
IDENTIFICATION DIVISION.
PROGRAM-ID.	WRITCH.
*+
*	Write one or more checks
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	LED-NUMBER-3		PIC 9		COMP		VALUE 3.
PROCEDURE DIVISION.
0.
*+
* Turn on LED 3 on the VT100 during this routine, just to show how.
*-
	CALL "FDV$LEDON" USING	BY REFERENCE	LED-NUMBER-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
*-
	CALL "FDV$NDISP"
	CALL "FDV$SWKSP" USING	BY DESCRIPTOR	CHECK_WORKSPACE.
	CALL "FDV$DISPW".
	CALL "FDV$PUT" USING	BY DESCRIPTOR	CURRENT_BALANCE
				BY DESCRIPTOR	N-CHECK-BALANC.
*+
* Process checks until a keypad period is read
*-
	PERFORM WITH TEST AFTER UNTIL TERMINATOR = FDV$K_KP_PER
		CALL "ONECHK"
		CALL "ENDCHK"
	END-PERFORM.
*+
* Turn off LED 3 on VT100
*-
*
	CALL "FDV$LEDOF" USING	BY REFERENCE	LED-NUMBER-3.
	CALL "FDV$SWKSP" USING	BY DESCRIPTOR	WORKSPACE.
	EXIT PROGRAM.
IDENTIFICATION DIVISION.
PROGRAM-ID.	ONECHK.
*+
*	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).
*-
*
DATA DIVISION.
WORKING-STORAGE SECTION.
01	REG_FULL_MSG		PIC X(35)		VALUE "Register full, cant't enter check.".
01	TMP			PIC X(207)		VALUE SPACE.
01	TMP_REG_ITEM_PAY_AMT	PIC X(6).
01	NUM_REG_ITEM_PAY_AMT	PIC 9(6)	COMP.
01	NEW_CHECK_NUMBER	PIC 9(4)		VALUE ZERO.
01	NEW_LAST_REGIST_NUM	PIC 9(4)		VALUE ZERO.
PROCEDURE DIVISION.
0.
	ADD 1, LAST_CHECK_NUM 	 GIVING	NEW_CHECK_NUMBER.
	ADD 1, LAST_REGISTER_NUM GIVING NEW_LAST_REGIST_NUM.
	CALL "FDV$PUT" USING	BY DESCRIPTOR	NEW_CHECK_NUMBER
				BY DESCRIPTOR	N-CHECK-NUMBER.
	CALL "FDV$GETAL" USING	BY DESCRIPTOR	TMP
				BY REFERENCE	TERMINATOR.
	IF TERMINATOR = FDV$K_KP_PER THEN
		GO TO FINI.
*+
* If the check wouldn't fit in the register, don't process, just
* give error message, wait for acknowledgement, and return
*-
	IF LAST_REGISTER_NUM NOT LESS THAN REGISTER_MAX THEN
		CALL "FDV$PUTL" USING	BY DESCRIPTOR	REG_FULL_MSG
		CALL "FDV$WAIT"
		GO TO FINI.
*+
* Get amount from check.
* Update balance (in memory and on screen) and session sums.
* Transfer form values to register item.
*-
	CALL "FDV$RET"
		USING	BY DESCRIPTOR	D-REGIST-AMTPAY
			BY DESCRIPTOR	N-CHECK-AMTPAY.
	MOVE D-REGIST-AMTPAY TO TMP_REG_ITEM_PAY_AMT.
	INSPECT TMP_REG_ITEM_PAY_AMT REPLACING ALL SPACE BY ZERO.
	MOVE TMP_REG_ITEM_PAY_AMT TO NUM_REG_ITEM_PAY_AMT.
	SUBTRACT NUM_REG_ITEM_PAY_AMT FROM CURRENT_BALANCE.
	ADD NUM_REG_ITEM_PAY_AMT TO TOTAL_PAYMENTS.
	CALL "FDV$PUT"
		USING	BY DESCRIPTOR	CURRENT_BALANCE
			BY DESCRIPTOR	N-CHECK-BALANC.

* Now collect the register data and then update the register. AMTPAY has
* already been moved by the previous FDV$RET.

	MOVE NEW_CHECK_NUMBER TO D-REGIST-NUMBER.
	CALL "FDV$RET"
		USING	BY DESCRIPTOR	D-REGIST-DATE
			BY DESCRIPTOR	N-CHECK-DATE.
	CALL "FDV$RET"
		USING	BY DESCRIPTOR	D-REGIST-PAYMEM
			BY DESCRIPTOR	N-CHECK-PAYTO.
	CALL "FDV$RET"
		USING	BY DESCRIPTOR	D-REGIST-BALANC
			BY DESCRIPTOR	N-CHECK-BALANC.
	MOVE ZERO TO D-REGIST-DPOSIT.
	MOVE SPACE TO D-REGIST-FAKE.
	MOVE SPACE TO D-REGIST-SUMARY.
*+
* Update register array and counters
*-
	MOVE NEW_LAST_REGIST_NUM TO LAST_REGISTER_NUM.
	MOVE NEW_CHECK_NUMBER TO LAST_CHECK_NUM.
	MOVE D-REGIST TO REGISTER_ITEM(LAST_REGISTER_NUM).
FINI.
	EXIT PROGRAM.	
END PROGRAM ONECHK.
IDENTIFICATION DIVISION.
PROGRAM-ID.	ENDCHK.
*+
*	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
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	START_LINE		PIC 99	   COMP		VALUE 20.
01	LINE_COUNT		PIC 99	   COMP		VALUE 4.
PROCEDURE DIVISION.
0.
*	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.
*-
	IF TERMINATOR NOT = FDV$K_KP_PER THEN 
*+
* 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.
*-
		CALL "FDV$SWKSP" USING	BY DESCRIPTOR	WORKSPACE
		CALL "FDV$DISP" USING	BY DESCRIPTOR	FORM_CHKDON
*+
* 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.
*-
		CALL "FDV$WAIT"	USING	BY REFERENCE	TERMINATOR
		PERFORM WITH TEST BEFORE UNTIL TERMINATOR NOT = FDV$K_KP_0
			CALL "PRICHK"
			CALL "FDV$WAIT" USING	BY REFERENCE	TERMINATOR
		END-PERFORM
*+
* If choice is to quit, 
* then mark check wksp undisplayed so it doesn't appear during refresh,
* else mark normal workspace (occupied by CHKDON form) undisplayed
*   so it doesn't show during refresh and then clear its lines.
*   (Clearing the space occupied by the CHKDON form, lines 20-23
*   is better done by overlaying with a blank form to
*   avoid having to know the lines numbers to clear).
*-
		IF TERMINATOR = FDV$K_KP_PER THEN
			CALL "FDV$SWKSP" USING	BY DESCRIPTOR	CHECK_WORKSPACE
			CALL "FDV$NDISP" 
	   	ELSE
			CALL "FDV$NDISP" 
			CALL "FDV$CLEAR" USING	BY REFERENCE	START_LINE
						BY REFERENCE	LINE_COUNT
			CALL "FDV$SWKSP" USING	BY DESCRIPTOR	CHECK_WORKSPACE
		END-IF
*+
* Going to write another check now or eventually, so:
* Clear out operator entered fields.
*-
		CALL "FDV$PUTD" USING	BY DESCRIPTOR	N-CHECK-AMTPAY
		CALL "FDV$PUTD" USING	BY DESCRIPTOR	N-CHECK-MEMO
		CALL "FDV$PUTD" USING	BY DESCRIPTOR	N-CHECK-PAYTO
	END-IF.
	EXIT PROGRAM.
IDENTIFICATION DIVISION.
PROGRAM-ID.	PRICHK.
*+
* 	Print the check into the file SAMPCH.DAT
*	Use the check workspace, then switch back to the normal wksp
*	to keep things clean.
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	CHK_WRITTEN_MSG		PIC X(35)		VALUE "Check written to file.".
01	TMP_FIELD_NAME		PIC X(6).
01	TMP			PIC XX.
01	FIRSTL			PIC 99.
01	LASTL			PIC 99.
01	LINE_NUMBER		PIC 99   COMP.
01	LINE_LENGTH		PIC 999.
PROCEDURE DIVISION.
0.
*+
* Open check writing file.  Note there's a new version for every check.
* Switch workspaces
*+
	OPEN OUTPUT OUTPUT-FILE.
	CALL "FDV$SWKSP" USING	BY DESCRIPTOR	CHECK_WORKSPACE.
*+
* Get the top and bottom lines of the check from the named data
* (first two characters).
*-
	MOVE "FIRST" TO TMP_FIELD_NAME.
	CALL "FDV$RETDN" USING	BY DESCRIPTOR	TMP_FIELD_NAME
				BY DESCRIPTOR	TMP.
	INSPECT TMP REPLACING ALL SPACE BY ZERO.
	MOVE TMP TO FIRSTL.
	MOVE "LAST" TO TMP_FIELD_NAME.
	CALL "FDV$RETDN" USING	BY DESCRIPTOR	TMP_FIELD_NAME
				BY DESCRIPTOR	TMP.
	INSPECT TMP REPLACING ALL SPACE BY ZERO.
	MOVE TMP TO LASTL.
*+
* Get lines from form.
* Convert to line printer style.
* Write to file.
*-
	PERFORM VARYING LINE_NUMBER FROM FIRSTL BY 1 UNTIL LINE_NUMBER > LASTL
		MOVE SPACES TO POOL
		CALL "FDV$RETFL" USING	BY REFERENCE	LINE_NUMBER
					BY DESCRIPTOR	POOL
					BY REFERENCE	LINE_LENGTH
		WRITE POOL
	END-PERFORM.
	CALL "FDV$PUTL" USING	BY DESCRIPTOR	CHK_WRITTEN_MSG.
	CLOSE OUTPUT-FILE.
	CALL "FDV$SWKSP"	USING	BY DESCRIPTOR	WORKSPACE.
	EXIT PROGRAM.
END PROGRAM PRICHK.
END PROGRAM ENDCHK.
END PROGRAM WRITCH.
IDENTIFICATION DIVISION.
PROGRAM-ID.	VUEACT.
*+
*	View the account data.
*	If operator knows the secret word, let operator change
*	the account data for this session.
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
PROCEDURE DIVISION.
0.
	CALL "FDV$CDISP" USING	BY DESCRIPTOR	FORM-ACTDAT.
	CALL "SRVCHK".
	CALL "FDV$PUTAL" USING	BY DESCRIPTOR	ACCOUNT.
	CALL "SRVCHK".
	CALL "FDV$PUTD"	USING	BY DESCRIPTOR	N-ACTDAT-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 the password, return to menu.
*-
	CALL "FDV$GETAL" USING	BY VALUE 	0,
				BY REFERENCE	TERMINATOR.

	IF TERMINATOR IS NOT = FDV$K_KP_PER
	THEN	CALL "FDV$RET" 	USING	BY DESCRIPTOR	D-ACTDAT-SECRET
					BY DESCRIPTOR	N-ACTDAT-SECRET
		IF D-ACTDAT-SECRET  = ACCT_PASSWORD
*+
* Allow input from other fields and read from them.
* If read is terminated by keypad period, don't change account.
*-
		THEN	CALL "FDV$SPOFF"
			CALL "READAL"
			CALL "FDV$SPON"
			IF TERMINATOR NOT = FDV$K_KP_PER
			THEN	CALL "FDV$RETAL" USING	BY DESCRIPTOR	ACCOUNT
				CALL "FMTCHK"
			END-IF
		END-IF
	END-IF.
	EXIT PROGRAM.
IDENTIFICATION DIVISION.
PROGRAM-ID.	READAL.
*+
* 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.
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	TMP			PIC X(132)		VALUE SPACE.
01	STAR			PIC X			VALUE "*".
01	INPUT_REQ_MSG		PIC X(14)		VALUE "Input Required".
01	FIELD_NAME		PIC X(31)		VALUE SPACE.
01	ESCAPE			PIC S9(9)	COMP.
PROCEDURE DIVISION.
0.
	CALL "FDV$GET" USING	BY DESCRIPTOR	TMP
				BY REFERENCE	TERMINATOR
				BY DESCRIPTOR	STAR.
	CALL "FDV$RETFN" USING	BY DESCRIPTOR	FIELD_NAME
				BY REFERENCE	FIELD_INDEX.
*+
* If status is error, then PFT failed because terminator was 
* a keypad key, which means return to caller.
*-
	SET ESCAPE TO FAILURE.
	PERFORM UNTIL ESCAPE IS SUCCESS
		IF TERMINATOR = FDV$K_KP_PER
		THEN SET ESCAPE TO SUCCESS
		ELSE
			CALL "FDV$PFT" USING	BY REFERENCE	TERMINATOR
			IF FMS_STATUS < ZERO
			THEN	SET ESCAPE TO SUCCESS
		        ELSE
				EVALUATE	TERMINATOR	FMS_STATUS
				WHEN		FDV$K_FT_NTR	NOT FDV$K_INC	SET ESCAPE TO SUCCESS
				WHEN		FDV$K_FT_NTR	FDV$K_INC		CALL "FDV$PUTL"
									      USING	BY DESCRIPTOR INPUT_REQ_MSG
							    		CALL "FDV$BELL"
									CALL "FDV$GETAF"
									      USING	BY DESCRIPTOR	TMP
											BY REFERENCE	TERMINATOR
											BY DESCRIPTOR	FIELD_NAME
											BY REFERENCE	FIELD_INDEX
				WHEN		NOT FDV$K_FT_NTR	   ANY		CALL "FDV$GETAF"
									      USING	BY DESCRIPTOR	TMP
											BY REFERENCE	TERMINATOR
											BY DESCRIPTOR	FIELD_NAME
											BY REFERENCE	FIELD_INDEX
				END-EVALUATE
			END-IF
		END-IF
	END-PERFORM.
	EXIT PROGRAM.
END PROGRAM READAL.
END PROGRAM VUEACT.
IDENTIFICATION DIVISION.
PROGRAM-ID.	VUEREG.
*+
*	View the check register and scroll through it.
*	Also display totals for current session.
*
DATA DIVISION.
WORKING-STORAGE SECTION.
01	OVERFLOW_MSG		PIC X(6)		VALUE "OVRFLO".
01	TMP			PIC X(10).
01	RETURNED_NUM_LINES	PIC XX.
01	NUM_LINES_IN_SCROLL	PIC 99		COMP.
PROCEDURE DIVISION.
0.
* Put up register form.
* Check for current session totals overflow. If so, output 'OVRFLO'
* Put out summary of this session into indexed(4) fields.
*-
	CALL "FDV$CDISP" USING	BY DESCRIPTOR	FORM-REGIST.
	CALL "SRVCHK".
	MOVE 1 TO FIELD_INDEX.
	CALL "FDV$PUT" USING	BY DESCRIPTOR	ACCT_BALANCE
				BY DESCRIPTOR	N-REGIST-SUMARY
				BY REFERENCE	FIELD_INDEX.
	MOVE 2 TO FIELD_INDEX.
	IF TOTAL_DEPOSIT IS NOT GREATER THAN MAX_DEPOSIT
		THEN	CALL "FDV$PUT" USING	BY DESCRIPTOR	TOTAL_DEPOSIT
						BY DESCRIPTOR	N-REGIST-SUMARY
						BY REFERENCE	FIELD_INDEX
		ELSE	CALL "FDV$PUT" USING	BY DESCRIPTOR	OVERFLOW_MSG 
						BY DESCRIPTOR	N-REGIST-SUMARY
						BY REFERENCE	FIELD_INDEX.
	MOVE 3 TO FIELD_INDEX.
	IF TOTAL_PAYMENTS IS LESS THAN MAX_PAYMENT
		THEN	CALL "FDV$PUT" USING	BY DESCRIPTOR	TOTAL_PAYMENTS
						BY DESCRIPTOR	N-REGIST-SUMARY
						BY REFERENCE	FIELD_INDEX
		ELSE	CALL "FDV$PUT" USING	BY DESCRIPTOR	OVERFLOW_MSG 
						BY DESCRIPTOR	N-REGIST-SUMARY
						BY REFERENCE	FIELD_INDEX.
	MOVE 4 TO FIELD_INDEX.
	CALL "FDV$PUT" 	USING	BY DESCRIPTOR	CURRENT_BALANCE
				BY DESCRIPTOR	N-REGIST-SUMARY
				BY REFERENCE	FIELD_INDEX.
*+
* Get number of lines in scroll area from form named data (item 1).
*-
	MOVE 1 TO FIELD_INDEX.
	CALL "FDV$RETDI" USING	BY REFERENCE	FIELD_INDEX
				BY DESCRIPTOR	RETURNED_NUM_LINES.
	CALL "SRVCHK".
	IF RETURNED_NUM_LINES(2:1) = SPACE
		THEN MOVE RETURNED_NUM_LINES(1:1) TO NUM_LINES_IN_SCROLL
		ELSE MOVE RETURNED_NUM_LINES(1:2) TO NUM_LINES_IN_SCROLL.
*+
* Put lines from check register array into scrolled area.
* The window is initially from item 1 up to item 
* min(NUM_LINES_IN_SCROLL,LAST_REGISTER_NUM), 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).
*-
	MOVE FDV$K_FT_SFW TO TERMINATOR.
	PERFORM WITH TEST AFTER VARYING CUR_LINE FROM 1 BY 1
		UNTIL CUR_LINE NOT LESS NUM_LINES_IN_SCROLL OR CUR_LINE NOT LESS LAST_REGISTER_NUM
		IF CUR_LINE NOT = 1 THEN CALL "FDV$PFT" USING	BY REFERENCE	TERMINATOR
								BY DESCRIPTOR	N-CHECK-NUMBER
		END-IF
		CALL "FDV$PUTSC" USING	BY DESCRIPTOR	N-CHECK-NUMBER
					BY DESCRIPTOR	REGISTER_ITEM(CUR_LINE)
	END-PERFORM.
* Set the MIN and MAX window.
	MOVE 1 TO MIN_WINDOW.
	MOVE CUR_LINE TO MAX_WINDOW.
*+
* 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).
*-
	MOVE FDV$K_FT_SBK TO TERMINATOR.
	PERFORM UNTIL TERMINATOR = FDV$K_FT_NTR OR TERMINATOR = FDV$K_KP_PER
		CALL "FDV$GET" USING	BY DESCRIPTOR	TMP
					BY REFERENCE	TERMINATOR
					BY DESCRIPTOR	N-REGIST-FAKE
		EVALUATE	TERMINATOR
			WHEN	FDV$K_FT_SBK
			WHEN	FDV$K_FT_SPR	CALL "SCRBAK"
			WHEN	FDV$K_FT_SFW
			WHEN	FDV$K_FT_SNX	CALL "SCRFWD"
		END-EVALUATE
	END-PERFORM.
	EXIT PROGRAM.
IDENTIFICATION DIVISION.
PROGRAM-ID.	SCRFWD.
*+
*	CUR_LINE is the line in the register that the cursor is on.
*	MIN_WINDOW and MAX_WINDOW delimit the part of the register
*	currently displayed in the scrolled area.
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	END_OF_REG_MSG		PIC X(21)  		VALUE "Last line of register".
PROCEDURE DIVISION.
0.
*+
* If cursor is at the end of the register, report, and return
* 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 CUR_LINE = LAST_REGISTER_NUM
		THEN	CALL "FDV$PUTL" USING	BY DESCRIPTOR	END_OF_REG_MSG
		ELSE	MOVE FDV$K_FT_SFW TO TERMINATOR
			IF CUR_LINE NOT = MAX_WINDOW
				THEN	CALL "FDV$PFT" USING	BY REFERENCE	TERMINATOR
								BY DESCRIPTOR	N-CHECK-NUMBER
				ELSE	ADD 1 TO MIN_WINDOW, MAX_WINDOW
					CALL "FDV$PFT" USING	BY REFERENCE	TERMINATOR
								BY DESCRIPTOR	N-CHECK-NUMBER
								BY DESCRIPTOR	REGISTER_ITEM(MAX_WINDOW)
				END-IF
			ADD 1 TO CUR_LINE
		END-IF.
	EXIT PROGRAM.
END PROGRAM SCRFWD.
IDENTIFICATION DIVISION.
PROGRAM-ID.	SCRBAK.
*+
*	CUR_LINE is the line in the register that the cursor is on.
*	MIN_WINDOW and MAX_WINDOW delimit the part of the register
*	currently displayed in the scrolled area
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	START_OF_REG_MSG	PIC X(22)  		VALUE "First line of register".
PROCEDURE DIVISION.
0.
*+
* If the cursor is at the beginning of the register, report, and return
* 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 CUR_LINE = 1
		THEN	CALL "FDV$PUTL" USING	BY DESCRIPTOR	START_OF_REG_MSG
		ELSE	MOVE FDV$K_FT_SBK TO TERMINATOR
			IF CUR_LINE NOT = MIN_WINDOW
				THEN	CALL "FDV$PFT" USING	BY REFERENCE	TERMINATOR
								BY DESCRIPTOR	N-CHECK-NUMBER
				ELSE	SUBTRACT 1 FROM MIN_WINDOW, MAX_WINDOW
					CALL "FDV$PFT" USING	BY REFERENCE	TERMINATOR
								BY DESCRIPTOR	N-CHECK-NUMBER
								BY DESCRIPTOR	REGISTER_ITEM(MIN_WINDOW)
				END-IF
			SUBTRACT 1 FROM CUR_LINE
		END-IF.
	EXIT PROGRAM.
END PROGRAM SCRBAK.
END PROGRAM VUEREG.
END PROGRAM MENU.
IDENTIFICATION DIVISION.
PROGRAM-ID.	SRVCHK IS COMMON.
*+
* Check FMS status by looking at the status recording variables.
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	TMP			PIC -(8)9.
PROCEDURE DIVISION.
0.
	IF FMS_STATUS LESS THAN ZERO
	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"  USING BY DESCRIPTOR	TERM_CONTROL_AREA
		DISPLAY SPACE
		DISPLAY "FDV ERROR"
		MOVE FMS_STATUS TO TMP
		DISPLAY "FMS STATUS: ",TMP
		MOVE RMS_STATUS TO TMP
		DISPLAY "RMS STATUS: ",TMP
		STOP RUN.
	EXIT PROGRAM.
END PROGRAM SRVCHK.
IDENTIFICATION DIVISION.
PROGRAM-ID.	GETSTAT IS COMMON.
*+
* Check FMS status by calling FDV$STAT. 
* If not success (>0), print and stop
*-
*
DATA DIVISION.
WORKING-STORAGE SECTION.
PROCEDURE DIVISION.
0.
	CALL "FDV$STAT"	USING	BY REFERENCE FMS_STATUS
				BY REFERENCE RMS_STATUS.
	CALL "SRVCHK".
	EXIT PROGRAM.
END PROGRAM GETSTAT.
IDENTIFICATION DIVISION.
PROGRAM-ID.	FMTCHK IS COMMON.
*+
*	Format account data onto check form in the check workspace.
*-
DATA DIVISION.
WORKING-STORAGE SECTION.
01	NAME_CONDENSED		PIC X(39).
01	FIRST_LEN		PIC 9(4)	COMP.
01	CSZ_CONDENSED		PIC X(30).
01	CITY_LEN		PIC 9(4)	COMP.
01	UNUSED_STRING		PIC X(80).
PROCEDURE DIVISION.
0.
	CALL "FDV$SWKSP" USING	BY DESCRIPTOR	CHECK_WORKSPACE.
	CALL "FDV$LOAD" USING	BY DESCRIPTOR	FORM-CHECK.
*+
* Need to trim trailing blanks - use the VMS RTL routine to find out how
* long the trimmed string is, then do explicit moves.
* Put only middle initial in, not full middle name.
*-
	CALL "STR$TRIM"	USING	BY DESCRIPTOR	UNUSED_STRING
				BY DESCRIPTOR	FIRST_NAME
				BY REFERENCE	FIRST_LEN.

	STRING 	FIRST_NAME(1:FIRST_LEN) " "
		MIDDLE_NAME(1:1) ". "
	     	LAST_NAME DELIMITED BY SIZE INTO NAME_CONDENSED.

	CALL "FDV$PUT" USING	BY DESCRIPTOR	NAME_CONDENSED
				BY DESCRIPTOR	N-CHECK-NAME.
	CALL "FDV$PUT" USING	BY DESCRIPTOR	ACCT_STREET
				BY DESCRIPTOR	N-CHECK-STREET.
	CALL "STR$TRIM"	USING	BY DESCRIPTOR	UNUSED_STRING
				BY DESCRIPTOR	CITY
				BY REFERENCE	CITY_LEN.
	STRING 	CITY(1:CITY_LEN) ", "
		STATE " "
		ZIP	     	DELIMITED BY SIZE INTO CSZ_CONDENSED.

	CALL "FDV$PUT" USING	BY DESCRIPTOR	CSZ_CONDENSED
				BY DESCRIPTOR	N-CHECK-CSZ.
	CALL "FDV$PUT" USING	BY DESCRIPTOR	ACCT_HOME_PHONE
				BY DESCRIPTOR	N-CHECK-HOMEPH.
	CALL "FDV$PUT" USING	BY DESCRIPTOR	ACCT_NUMBER
				BY DESCRIPTOR	N-CHECK-ACCTNO.
	CALL "FDV$SWKSP" USING	BY DESCRIPTOR	WORKSPACE.
	EXIT PROGRAM.
END PROGRAM FMTCHK.
END PROGRAM SAMP.
IDENTIFICATION DIVISION.
PROGRAM-ID.	VALID1	INITIAL. 
*******************************************************************************
*   Field completion 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.                                     *
*******************************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
	COPY "FDVDEF".
	COPY "SMPCOBUAR".
*
*   Declarations specific to this UAR.   
*
01	FIELD_VALUE		PIC X(1).
01	COUNTER			PIC 9(2)	COMP	VALUE 0.
01	ILLEGAL_VALUE_MSG	PIC X(13)		VALUE "Illegal value".
PROCEDURE DIVISION GIVING RETURN_STATUS.
0.
*+
* Retrieve context: ignore all but UAR_DATA, and 
* only the initial, non-blank characters of it.
* Retrieve field name and index.
* Retrieve field value.
*-
	CALL "FDV$RETCX"	USING	BY REFERENCE	ADDRESS_TCA,
					BY REFERENCE	ADDRESS_WKSP,
					BY DESCRIPTOR	FORM_NAME,
					BY DESCRIPTOR	UAR_DATA,
					BY REFERENCE	CURSOR_POSITION,
					BY REFERENCE	TERMINATOR,
					BY REFERENCE	INSOVR_STATUS,
					BY REFERENCE	HELP_STRIKES.

	CALL "FDV$RETFN"	USING	BY DESCRIPTOR	FIELD_NAME,
					BY REFERENCE	FIELD_INDEX.

	CALL "FDV$RET"		USING 	BY DESCRIPTOR	FIELD_VALUE,
					BY DESCRIPTOR	FIELD_NAME,
					BY REFERENCE	FIELD_INDEX.
*+
* To be valid, FIELD_VALUE must occur in the string UAR_DATA.
* This INSPECT statement sets COUNTER to the number of characters preceding
* FIELD_VALUE; thus, COUNTER will be 0 if the first character in UAR_DATA
* matched and UAR_DATA_LENGTH if the character is not found.
*-
	INSPECT UAR_DATA TALLYING COUNTER FOR CHARACTERS BEFORE INITIAL FIELD_VALUE.
	IF COUNTER IS LESS THAN UAR_DATA_MAX_LENGTH
	THEN
		MOVE FDV$K_UVAL_SUC TO RETURN_STATUS
	ELSE
		CALL "FDV$PUTL"	USING	BY DESCRIPTOR	ILLEGAL_VALUE_MSG
		MOVE FDV$K_UVAL_FAIL TO RETURN_STATUS
	END-IF.
					
	EXIT PROGRAM.
END PROGRAM VALID1.
IDENTIFICATION DIVISION.
PROGRAM-ID.	TAKE15	INITIAL. 
***********************************************************************
*   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.                *
***********************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
	COPY "FDVDEF".
	COPY "SAMPCOB".
	COPY "SMPCOBUAR".
*
*   Declarations specific to this UAR.   
*
01	FIELD_VALUE		PIC X(1)		VALUE SPACE.
01	ILLEGAL_FUNC_KEY_MSG	PIC X(20)		VALUE "Illegal function key".
PROCEDURE DIVISION	GIVING	RETURN_STATUS.
0.
*+	
* Retrieve context: ignore all but TERMINATOR
*-
	CALL "FDV$RETCX"	USING	BY REFERENCE	ADDRESS_TCA,
					BY REFERENCE	ADDRESS_WKSP,
					BY DESCRIPTOR	FORM_NAME,
					BY DESCRIPTOR	UAR_DATA,
					BY REFERENCE	CURSOR_POSITION,
					BY REFERENCE	TERMINATOR,
					BY REFERENCE	INSOVR_STATUS,
					BY REFERENCE	HELP_STRIKES.
*+
* Do the conversion, displaying the value converted if found.
* Reject if not one of the expected terminators.
*
	EVALUATE TERMINATOR
		WHEN	FDV$K_KP_1	MOVE "1" TO FIELD_VALUE
		WHEN	FDV$K_KP_2 	MOVE "2" TO FIELD_VALUE
		WHEN	FDV$K_KP_3 	MOVE "3" TO FIELD_VALUE
		WHEN	FDV$K_KP_4 	MOVE "4" TO FIELD_VALUE
		WHEN	FDV$K_KP_5 	MOVE "5" TO FIELD_VALUE
		WHEN	FDV$K_KP_PER 	MOVE "1" TO FIELD_VALUE
	END-EVALUATE.
	IF FIELD_VALUE = SPACE THEN
	   CALL "FDV$PUTL"	USING	BY DESCRIPTOR ILLEGAL_FUNC_KEY_MSG
	   CALL "FDV$SIGOP"
*	   Just ignore it now.
	   MOVE FDV$K_UKEY_SUC TO RETURN_STATUS
	ELSE
	   CALL "FDV$PUT"	USING	BY DESCRIPTOR FIELD_VALUE
					BY DESCRIPTOR N-MENU-OPTION
*	   Treat as if it is RETURN.
	   MOVE FDV$K_UKEY_NTR TO RETURN_STATUS
	END-IF.
	EXIT PROGRAM.
END PROGRAM TAKE15.
IDENTIFICATION DIVISION.
PROGRAM-ID. 	PASSKY	INITIAL.
*****************************************************************************
*   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.                                 *
*****************************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
	COPY "FDVDEF".
	COPY "SMPCOBUAR".
*
*   Declarations specific to this UAR.   
*
01	ITEM		PIC 9(4)		VALUE IS ZERO.
01	ITEM_LENGTH	PIC 9(4)	COMP	VALUE IS ZERO.
01	NON_BLANK_PTR	PIC 9(4)	COMP	VALUE 1.
01	DONE		PIC S9(9)	COMP.
PROCEDURE DIVISION	GIVING	RETURN_STATUS.
0.
*+	
* Retrieve context: ignore all but TERMINATOR and UAR_DATA.
*-
	CALL "FDV$RETCX"	USING	BY REFERENCE	ADDRESS_TCA,
					BY REFERENCE	ADDRESS_WKSP,
					BY DESCRIPTOR	FORM_NAME,
					BY DESCRIPTOR	UAR_DATA,
					BY REFERENCE	CURSOR_POSITION,
					BY REFERENCE	TERMINATOR,
					BY REFERENCE	INSOVR_STATUS,
					BY REFERENCE	HELP_STRIKES.
*+
* Break up the list into numbers.  Check each against the actual
* terminator. If terminator found in list, return success.
*-
	SET DONE TO FAILURE.
	MOVE FDV$K_UKEY_ERR TO RETURN_STATUS.
	
	PERFORM WITH TEST AFTER UNTIL DONE IS SUCCESS OR ITEM = ZERO 
		UNSTRING UAR_DATA DELIMITED BY SPACE INTO ITEM 
			WITH POINTER NON_BLANK_PTR
		IF NON_BLANK_PTR IS GREATER THAN UAR_DATA_MAX_LENGTH
		    SET DONE TO SUCCESS
		END-IF
		IF TERMINATOR = ITEM THEN
		    MOVE FDV$K_UKEY_TRM TO RETURN_STATUS
		    SET DONE TO SUCCESS
		END-IF
	END-PERFORM.

	EXIT PROGRAM.
END PROGRAM PASSKY.
IDENTIFICATION DIVISION.
PROGRAM-ID. 	CHKCHK	INITIAL.
*************************************************************************
*   Field completion 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.               *
*************************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
	COPY "FDVDEF".
	COPY "SAMPCOB".
	COPY "SMPCOBUAR".
*
*   Declarations specific to this UAR.   
*
01	CURRENT_BALANCE		PIC 9(6).
01	AMOUNT			PIC 9(6).
01	BLINKBOLD		PIC 9(6)	COMP.
01	OVERDRAFT_MSG		PIC X(53)		VALUE "Your balance doesn't cover that much, reenter amount.".
PROCEDURE DIVISION	GIVING RETURN_STATUS.
0.
	CALL "FDV$RET"	USING	BY DESCRIPTOR	CURRENT_BALANCE,
				BY DESCRIPTOR	N-CHECK-BALANC.
	CALL "FDV$RET"	USING	BY DESCRIPTOR	AMOUNT,
				BY DESCRIPTOR	N-CHECK-AMTPAY.
	INSPECT AMOUNT REPLACING ALL SPACES BY ZERO.

	IF CURRENT_BALANCE IS NOT LESS THAN AMOUNT THEN
		MOVE -1 TO BLINKBOLD
		CALL "FDV$AFVA"	USING	BY REFERENCE	BLINKBOLD,
					BY DESCRIPTOR	N-CHECK-BALANC
		MOVE FDV$K_UVAL_SUC TO RETURN_STATUS 
	ELSE
	    MOVE 3 TO BLINKBOLD
	    CALL "FDV$AFVA" 	USING	BY REFERENCE	BLINKBOLD,
					BY DESCRIPTOR	N-CHECK-BALANC
	    CALL "FDV$PUTL"	USING	BY DESCRIPTOR	OVERDRAFT_MSG
	    MOVE FDV$K_UVAL_FAIL TO RETURN_STATUS
	END-IF.
	EXIT PROGRAM.
END PROGRAM CHKCHK.
IDENTIFICATION DIVISION.
PROGRAM-ID. 	RANGE	INITIAL.
*****************************************************************************
*   General purpose field completion 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 an           *
*   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, COBOL issues a run-time error.          *
*   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.            *
*****************************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
	COPY "FDVDEF".
	COPY "SMPCOBUAR".
*
*   Declarations specific to this UAR.   
*
01	FLD_NUMBER		PIC X(132).
01	FLD_LENGTH		PIC 9(9)	COMP.
01	JUSTIFIED_NUMBER	PIC S9(18).
01	MAX_NUMERIC_CHARS	PIC 9(2)	COMP	VALUE 19.
01	LOWER			PIC S9(18).
01	UPPER			PIC S9(18).
01	LOWER_COUNT		PIC 9(2).
01	UPPER_COUNT		PIC 9(2).
01	BEGIN_MSG_PTR		PIC 9(9)	COMP	VALUE 1.
01	IN_RANGE		PIC S9(9)	COMP.
01	CANNED_MSG		PIC X(45)		VALUE "Field value out of bounds.  Must be in range ".
01	CANNED_PTR		PIC 9(9)	COMP	VALUE 1.
01	BAD_MSG			PIC X(80).
01	MSG_STRING		PIC X(80).
01	MSG_COUNT		PIC 9(3)	COMP.
PROCEDURE DIVISION	GIVING RETURN_STATUS.
0.
*-
* Get context which yields associated data value (ignore other stuff).
* Get current field name and index.
* Get field value.
*-
	CALL "FDV$RETCX"	USING	BY REFERENCE	ADDRESS_TCA,
					BY REFERENCE	ADDRESS_WKSP,
					BY DESCRIPTOR	FORM_NAME,
					BY DESCRIPTOR	UAR_DATA,
					BY REFERENCE	CURSOR_POSITION,
					BY REFERENCE	TERMINATOR,
					BY REFERENCE	INSOVR_STATUS,
					BY REFERENCE	HELP_STRIKES.

	CALL "FDV$RETFN"	USING	BY DESCRIPTOR	FIELD_NAME,
					BY REFERENCE	FIELD_INDEX.

	CALL "FDV$RET"		USING 	BY DESCRIPTOR	FLD_NUMBER,
					BY DESCRIPTOR	FIELD_NAME,
					BY REFERENCE	FIELD_INDEX.

	CALL "FDV$RETLE"	USING	BY REFERENCE	FLD_LENGTH,
					BY DESCRIPTOR	FIELD_NAME.

*+
* COBOL numbers must be no longer than 18 digits plus sign.
* Also, all numbers are assumed to be integers.
*-
	IF FLD_LENGTH IS GREATER THAN MAX_NUMERIC_CHARS THEN
	   SET RETURN_STATUS TO FAILURE
	ELSE
	   INSPECT FLD_NUMBER(1:FLD_LENGTH) REPLACING ALL SPACES BY ZERO
	   MOVE FLD_NUMBER(1:FLD_LENGTH) TO JUSTIFIED_NUMBER
*+
* Find comma and blank delimiters.
*-
	   UNSTRING UAR_DATA DELIMITED BY "," OR SPACE
		   INTO LOWER COUNT IN LOWER_COUNT
			UPPER COUNT IN UPPER_COUNT
		   WITH POINTER BEGIN_MSG_PTR

	   SET IN_RANGE TO SUCCESS
*+
* Check for lower bound.
*-
	   IF LOWER_COUNT IS NOT = ZERO THEN
	      IF JUSTIFIED_NUMBER IS LESS THAN LOWER SET IN_RANGE TO FAILURE
	   END-IF
*+
* Check for upper bound
*-
	   IF UPPER_COUNT IS NOT = ZERO THEN
	      IF JUSTIFIED_NUMBER IS GREATER THAN UPPER SET IN_RANGE TO FAILURE
	   END-IF
	   END-IF
*+
* Passed both tests successfully, return success for UAR value
*-
	   IF IN_RANGE IS SUCCESS THEN
	      MOVE FDV$K_UVAL_SUC TO RETURN_STATUS
	   ELSE
*+
* Error in one of the bounds. 
* Give error message: either from the UARVAL or make one up.
*-
	      UNSTRING UAR_DATA DELIMITED BY "  " 
		 INTO MSG_STRING COUNT IN MSG_COUNT
		 WITH POINTER BEGIN_MSG_PTR
   
	      IF MSG_COUNT IS GREATER THAN ZERO THEN
		 CALL "FDV$PUTL"	USING	BY DESCRIPTOR 	MSG_STRING(1:MSG_COUNT)
	      ELSE
*+
* BEGIN_MSG_PTR is too long since (a) the message begins 2 characters past the end
* of the lower-&-upper-bound string, and (b) the above UNSTRING results in another
* incrementing of 2
*-
		 SUBTRACT 4 FROM BEGIN_MSG_PTR
		 STRING CANNED_MSG UAR_DATA(1:BEGIN_MSG_PTR) "." 
		   DELIMITED BY SIZE INTO
		   BAD_MSG WITH POINTER CANNED_PTR
		 CALL "FDV$PUTL"	USING	BY DESCRIPTOR 	BAD_MSG(1:CANNED_PTR)
	      END-IF
   
	      CALL "FDV$SIGOP"
	      MOVE FDV$K_UVAL_FAIL TO RETURN_STATUS
	   END-IF
       END-IF.
       EXIT PROGRAM.
END PROGRAM RANGE.