1000    PROGRAM FORMS$CHECKING_BASIC
1005	%TITLE "DECforms Sample Checking Account Application"
	%SBTTL "Main Program"
	%IDENT "V4.0"

!        © Copyright 2005 Hewlett-Packard Development Company, L.P.
!
! Consistent with FAR 12.211 and 12.212, Commercial Computer Software,
! Computer Software Documentation, and Technical Data for Commercial
! Items are licensed to the U.S. Government under vendor's standard
! commercial license.
!

!+
! FACILITY:
!
!    DECforms
!
! PROGRAM DESCRIPTION:
!
!    This is the Sample Checking Application provided with the DECforms
!                   V4.0 product for the BASIC language.
!
! AUTHOR:
!
!    Hewlett-Packard Development Company, L.P.
!
! CREATION DATE:		Nov-1996
!
!--


! ------------- VMS - Character Cell Instructions --------------
!
! If your system manager copied the Sample from the DECforms kit onto your
! system, you can run the DECforms Sample Checking Application doing the
! following:
!
!   To run the Character Cell version of the Sample Checking Application:
!
!      $ DEFINE FORMS$DEFAULT_DEVICE SYS$INPUT
!      $ RUN FORMS$EXAMPLES:FORMS$CHECKING
!
! Any printing you do while running the checking sample will end up in your
! SYS$SCRATCH directory (usually your login directory).
!
!
! The DECforms Sample Checking Application in the BASIC language consists
! of five files:
!	FORMS$CHECKING_DATA.DAT			A data file for reading by
!						   the program
!	FORMS$CHECKING_FORM.IFDL		The IFDL source form
!	FORMS$CHECKING_BASIC.BAS		The application itself
!	FORMS$CHECKING_BASIC_COMMON.BAS		An include file containing
!						   common definitions for
!						   all the BASIC subroutines
!	FORMS$BAS_DEFINITIONS.BAS		An include file with DECforms
!						   definitions
!
! The first four files are copied from the DECforms kit to the FORMS$EXAMPLES
! directory and the last is put into SYS$LIBRARY. Putting the files in
! FORMS$EXAMPLES is an installation option; talk to your system manager if they
! aren't there. The FORMS$BAS_DEFINITIONS.BAS file is put into SYS$LIBRARY
! unconditionally, so that you should be able to use it from all your BASIC
! programs using DECforms.
!
! In addition, the binary form file, FORMS$CHECKING_FORM.FORM is also in the
! FORMS$EXAMPLES directory.
!
! A working version of the DECforms Sample Checking Application in the BASIC
! language can be created in your own directory from these sources by doing
! the following:
!
REM   $! Set the default to your own directory:
REM   $ 	SET DEFAULT yourdirectory
REM   $
REM   $ Copy all the sources files from FORMS$EXAMPLES to your own directory:
REM   $       COPY FORMS$EXAMPLES:FORMS$CHECKING_BASIC.BAS, -
REM                                FORMS$CHECKING_BASIC_COMMON.BAS, -
REM                                FORMS$CHECKING_FORM.IFDL []
REM   $
REM   $ Compile the BASIC source:
REM   $ 	BASIC FORMS$CHECKING_BASIC.BAS
REM   $
REM   $! Translate the IFDL source form:
REM   $ 	FORMS TRANSLATE FORMS$CHECKING_FORM.IFDL
REM   $
REM   $! Extract a vector module from the binary form:
REM   $	        FORMS EXTRACT OBJECT/PORTABLE FORMS$CHECKING_FORM.FORM
REM   $
REM   $! Link the BASIC object and the forms vector:
REM   $	LINK FORMS$CHECKING_BASIC.OBJ, -
REM		FORMS$CHECKING_FORM.OBJ
!
!   You can then run the executable in your own directory by doing the
!   following:
!
!   To run the Character Cell executable:
!
!      $ DEFINE FORMS$DEFAULT_DEVICE SYS$INPUT
!      $ RUN FORMS$CHECKING_BASIC
!
!  Note that the program expects the form file as well as the data file to
!  be in the FORMS$EXAMPLES directory, or in the current directory.  By
!  copying these files to your local directory you can change the form if
!  you wish and retranslate it.
!
!

!
! BASIC NOTES
! -----------
!
! Note on passing your records to DECforms:
!
! Three DECforms calls (FORMS$SEND, FORMS$RECEIVE, and FORMS$TRANSCEIVE)
! require record arguments to be passed as if they were characters strings;
! this is so DECforms can get the length of the record, which is used to
! verify that both your program and DECforms are talking about the same
! record; it will also be used for distributing calls in a future version.
!
! BASIC does not normally pass a record by descriptor.  There are two
! methods you can use to cause records to be passed by descriptor.  The
! first is to declare your records with variants, where one of the variants
! is a character string equal to the length of the entire record; then pass
! the name of that variant as the argument to DECforms -- Basic passes the
! character string by descriptor. This is the method used throughout this
! program. The other method is to build a descriptor yourself.  This might
! be preferable if you are copying records from the CDD and the CDD record
! doesn't have the variant. What you must do is declare a structure for a
! descriptor and fill in each field appropriately. For example, to create a
! descriptor for the account record, you could do the following:
!
!	%INCLUDE "$DSCDEF" %FROM %LIBRARY
!
!	RECORD descriptor_type
!	    WORD  length
!	    BYTE  desc_type
!	    BYTE  class
!	    LONG  address
!       END RECORD
!
!	DECLARE descriptor_type descriptor
!
!	descriptor::desc_type = DSC$K_DTYPE_T
!	descriptor::class =     DSC$K_CLASS_S
!	descriptor::length= 	152
!	descriptor::address=	LOC(account)
!
! This does have the unfortunate requirement that you must count the length
! of the record.


1010	OPTION TYPE = EXPLICIT

    !+
    ! Get the definitions for DECforms and for the Sample application.
    !-

1020	%INCLUDE "sys$library:forms$bas_definitions"
1030    %INCLUDE "forms$examples:forms$checking_basic_common"


    !
    ! Miscellaneous
    !
	DECLARE STRING CONSTANT form_file = "FORMS$EXAMPLES:forms$checking_form"
	DECLARE STRING CONSTANT device_name = "FORMS$DEFAULT_DEVICE"

        RECORD item_list_entry_type
	    VARIANT
		CASE
		    WORD	length
		    WORD	code
		    LONG	buff_addr
                    LONG	addr_length_returned
		CASE
                    INTEGER	end_list
            END VARIANT
	END RECORD item_list_entry_type

	DECLARE item_list_entry_type item_list(1)
	MAP (fixed_length_strings) STRING print_file_name = 35
        print_file_name = 'SYS$SCRATCH:FORMS$CHECKING_FORM'

    ! Print startup message on console

	PRINT "BASIC DECforms Sample Checking Account Application starting."

    ! Set up printing to go to the operator's scratch directory. This involves
    ! passing a request_options parameter in the enable request, which in turn
    ! requires setting up an item list. This item list has one item and is ended
    ! with a zero longword. Note that the print_file_name variable is put into
    ! a map so that it is a fixed length string; this is not because DECforms
    ! needs fixed length strings, but because an item list requires the address
    ! of the string. If print_file_name were simply declared STRING data type,
    ! BASIC would make it a dynamic string and the LOC function would return the
    ! address of the string's descriptor. Since print_file_name is fixed, LOC
    ! now returns the address of the string itself.

	item_list(0)::length = LEN(print_file_name)
	item_list(0)::code   = forms$k_printfile
	item_list(0)::buff_addr = LOC(print_file_name)
	item_list(1)::end_list = 0


    ! Initialize the DECforms form & check for errors
    ! The parameters are:
    !	Vector address for procedural escape
    !   Name of terminal
    !   Session_id returned by FORMS$ENABLE for use on later calls
    ! The following trailing pars can be omitted:
    !   File to find form in   } One of these two must be
    !	Name of form           }   specified
    !   Receive ctl msg
    !   Receive ctl ct
    !   Send ctl msg
    !   Send ctl ct
    !   Timeout
    !   Parent request id
    !   Request options item list


1040	forms_status = forms$enable(	forms$ar_form_table, 	&
	    	 			device_name,		&
					session_id,		&
					form_file,		&
                                        ,,,,,,,item_list(0))
	CALL check_forms_status( forms_status )

    ! Initialize account information


1050	CALL initialize_account

    ! Process all operator requests

	CALL do_operator_choice

    ! Clean up, Print ending message on console, leave.


1060	forms_status = forms$disable( session_id )
	CALL check_forms_status( forms_status )

	PRINT "BASIC DECforms Sample Checking Account Application ending."

	END


1090	SUB check_forms_status( INTEGER forms_status )

    ! Check the parameter for success status. If not successful, print
    ! the error and stop.

	OPTION TYPE = EXPLICIT

	IF (forms_status AND 1%) = 0 THEN
	    CALL LIB$SIGNAL( forms_status BY VALUE )
	    STOP
	END IF
	SUBEND


1100	SUB initialize_account

    ! Read from file FORMS$EXAMPLES:FORMS$CHECKING_DATA.DAT
    ! Write the account information to the form.
    ! Reformat some account info and send that to the form.

1110	OPTION TYPE = EXPLICIT
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'

  	DECLARE INTEGER remaining
	MAP (smp_map) account_rec        input_account
	MAP (smp_map) INTEGER            input_savings_balance
	MAP (smp_map) register_entry_rec input_reg_entry

    ! Open file, get account data and savings balance.

      	OPEN "forms$examples:forms$checking_data.dat" FOR INPUT AS FILE #1, &
		       MAP smp_map,			 &
		       ORGANIZATION SEQUENTIAL VARIABLE, &
	       	       RECORDTYPE ANY, 			 &
		       ALLOW READ,			 &
		       ACCESS READ

	GET #1
	account = input_account
	GET #1
	savings_balance = input_savings_balance

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

	last_check_num = 0
	register::number_entries_used = 0

	ON ERROR GOTO read_error
	WHILE register::number_entries_used < reg_max_sub
	    GET #1
	    register::reg(register::number_entries_used) = input_reg_entry
	    IF register::reg(register::number_entries_used)::reg_check_num <> 0 THEN
   	 	last_check_num = register::reg(register::number_entries_used)::reg_check_num
	    END IF
	    register::number_entries_used = register::number_entries_used + 1
    	NEXT

    ! Reached here without hitting end of file, reading exactly reg_size
    ! records. There's something wrong with the data file.

	PRINT 'Data file probably too big, only using ';REG_SIZE;' records.'
	GOTO end_read

    ! Get here in case of error in file read. Continue if it was an
    ! end-of-file error, end otherwise.
    read_error:
	IF ERR = 11% THEN
	    RESUME 1150
	ELSE
	    ON ERROR GOTO 0
	END IF

    ! Check for data file in error.


1150
    end_read:
	CLOSE(5)
	ON ERROR GOTO 0
	IF register::number_entries_used = 0 THEN
	    PRINT 'Data file in error, no register entries read'
	    STOP
	END IF

    !  Initialize the remaining the memo and date fields because we send
    !  the whole register to the form, and we really shouldn't
    !  send illegal strings, i.e. strings with non printing characters.

	FOR remaining = register::number_entries_used TO reg_max_sub
	    register::reg(remaining)::reg_date = '19850315'
	    register::reg(remaining)::reg_mem = ' '
	NEXT remaining

    ! Take checking balance from last record read
    ! Update check number to be the next check number to use.

	checking_balance = register::reg(register::number_entries_used-1)::reg_balance
	last_check_num = last_check_num + 1

    ! Tell the form all the account-derived information:
    !	The account record
    ! 	The balances, next available check number,
    !		register status
    ! 	The edited version of name and address

	! The parameters for a FORMS$SEND occur in the following order:
	! 	session id
	!	form record name
	!	number of records sent
	!	receive ctl text msg, receive ctl text cnt
	!	send ctl text msg, send ctl text cnt
	!	timeout
	!	parent request id
        !	request options item list
	!	record info sent to form
	!	shadow rec
	forms_status = forms$send(  session_id,			&
				    'account',			&
				    1%,				&
				    ,,				&
				    ,,				&
				    ,				&
				    ,				&
				    ,				&
				    account::account_string,	&
				    )
	CALL check_forms_status( forms_status )

	CALL update_form
	CALL name_and_address

	SUBEND


1200	SUB name_and_address

    ! Format the account data name and address and send to the form

	OPTION TYPE = EXPLICIT
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'

    ! MAIL_FORMAT is a reformatting of the name and last address line
    ! as they would appear on a mailing label, with extra spaces
    ! squeezed out. This record is used only by a SEND from the program.

	RECORD mail_format_type
	    VARIANT
		CASE
		    STRING mail_name =39
		    STRING mail_csz  =30
		CASE
                    STRING mail_string =69
            END VARIANT
	END RECORD mail_format_type

	DECLARE mail_format_type mail_format

    ! Format the name and address.
    ! Put only middle initial in, not full middle name.

	mail_format::mail_name = TRM$(account::first_name) + ' ' +	&
		    SEG$(account::middle_name,1,1) + '. ' + account::last_name
	mail_format::mail_csz =  TRM$(account::city)  + ', ' +		&
		    account::state + ' ' + 				&
		    FORMAT$( account::zip_code, '<0>####')

	forms_status = forms$send(  session_id,			&
				    'mail_format',		&
				    1%,				&
				    ,,				&
				    ,,				&
				    ,				&
				    ,				&
				    ,				&
				    mail_format::mail_string,	&
				    )
	CALL check_forms_status( forms_status )
	SUBEND


1300	SUB update_form

    ! Update the balances, next check number, and room_in_reg flag in the form.
    ! If there's no room for more entries in the register, then
    !   the room_in_reg flag is sent as zero, else 1.

	OPTION TYPE = EXPLICIT
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'

    ! UPDATE is sent whenever the register is changed. This means
    ! the account balances and the check number might also change.
    ! It is used only by a SEND from the program.

	RECORD update_type
	    VARIANT
		CASE
		    INTEGER	checking_balance! unsigned, passed as pennies
		    INTEGER	savings_balance	! unsigned, passed as pennies
		    WORD	check_number    ! unsigned
		    BYTE	room_in_reg
		    BYTE	update_pad	! padding for VAX/AXP compatibility
		CASE
                    STRING	update_string =12
	    END VARIANT
	END RECORD

	DECLARE update_type update_rec

   	update_rec::checking_balance = checking_balance
   	update_rec::savings_balance  = savings_balance
	update_rec::check_number     = last_check_num
	IF register::number_entries_used < reg_size
	THEN
	    update_rec::room_in_reg = 1
	ELSE
	    update_rec::room_in_reg = 0
	END IF

	forms_status = forms$send(  session_id,			&
				    'update',			&
				    1%,				&
				    ,,				&
				    ,,				&
				    ,				&
				    ,				&
				    ,				&
				    update_rec::update_string,	&
				    )
	CALL check_forms_status( forms_status )
	SUBEND


1400
    FUNCTION INTEGER quit_requested

    ! Check the receive control text in the COMMON area.
    ! Return 1 if operator requested QUIT, return 0 otherwise.

 	OPTION TYPE = EXPLICIT
  	%INCLUDE 'forms$examples:forms$checking_basic_common'
  	DECLARE INTEGER i

    ! Assume false till proven otherwise.

  	quit_requested = 0
 	FOR i=0 TO receive_ctl_txt_ct-1
 	    IF (SEG$(receive_ctl::receive_ctl_txt(i),3,5) = 'QUT') THEN
  		quit_requested = 1
  	    END IF
  	NEXT i

    END FUNCTION   ! End of FUNCTION quit_requested


1500  	SUB do_operator_choice

    ! Accept inputs from the operator and dispatch to the appropriate
    ! routine.  Repeat until option 1 (exit) is chosen.  The validation
    ! in the form guarantees that we get back only inputs 1-8.
    ! Options are:
    !	1 => Exit
    !	2 => Write check (comes back from form only if there's room in the reg)
    !	3 => Make deposit                            (")
    !	4 => Cash withdrawal                         (")
    !	5 => Transfer money from checking to savings (")
    !	6 => Transfer money from savings to checking (")
    !	7 => View register
    !	8 => View account data

	OPTION TYPE = EXPLICIT
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'


	WHILE 0=0

	    ! The format for FORMS$RECEIVE parameters is exactly the same as
            ! for the FORMS$SEND, except that the record is received.

	    forms_status = forms$receive(			&
            			    session_id,			&
				    'choose',			&
				    1%,				&
				    ,,				&
				    ,,				&
				    ,				&
				    ,				&
				    ,				&
				    choice::choice_string,	&
				    )
	    CALL check_forms_status( forms_status )

	    SELECT choice::operator_choice

		CASE 1
		    EXIT SUB

	    	CASE 2,3,4,5,6
		    CALL account_transfer

		CASE 7
		    CALL view_register

		CASE 8
		    CALL view_account_data

	    END SELECT

	NEXT

	SUBEND


1600  	SUB account_transfer

    ! The transaction is a checking account transfer, found in global CHOICE:
    !	2 => Write check
    !	3 => Make deposit
    !	4 => Cash withdrawal
    !	5 => Transfer money from checking to savings
    !	6 => Transfer money from savings to checking
    !
    ! Perform the indicated arithmetic on the checking account balance and enter
    !   the transaction into the register.
    ! The amount in the choice record is always positive, even for withdrawals
    !   so that arithmetic must be done with the proper sign.
    ! The memo in the choice record is set to the appropriate string so nothing
    !   special has to be done with it.
    ! In the case of a check, a new check number is generated.
    !
    ! Note that validation in the form guarantees that the amount of the transfer
    !   is always greater than zero and less than or equal to the respective
    !   balance.
    ! Form validation also guarantees that none of these options is chosen if no
    !   room is left in the register.

	OPTION TYPE = EXPLICIT
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'
	EXTERNAL INTEGER FUNCTION quit_requested

	DECLARE LONG check_number

    ! Update balances in memory.
    !   The general idea is to do the specific thing needed for each choice and
    !   then always do the checking account update. This also changes the sign
    !   for checking withdrawals so that the register is updated properly.

	check_number = 0

	SELECT choice::operator_choice
	    CASE 1 ! Shouldn't ever happen
		SUBEXIT

	    CASE 2 ! Write a check.
		check_number   = last_check_num
		last_check_num = last_check_num + 1
		choice::amount = - choice::amount

	    CASE 3 ! Make a deposit.
		! Do nothing, use amount as is.

	    CASE 4 ! Cash withdrawal
		choice::amount = - choice::amount

	    CASE 5 ! Transfer from checking to savings
		savings_balance  = savings_balance + choice::amount
		choice::amount = - choice::amount

	    CASE 6 ! Transfer from savings to checking
		savings_balance  = savings_balance - choice::amount

	END SELECT

    ! Now update the checking account, transfer form values to new
    ! register item, and transfer updated values to the form.

	checking_balance = checking_balance + choice::amount

	CALL add_to_register(					&
 			check_number,     			&
			choice::current_date, 			&
			choice::memo,				&
			choice::amount,    			&
			checking_balance,          		&
			0)

	CALL update_form
	SUBEND


1800	SUB add_to_register(	LONG	chk_num,	&
				STRING	date,		&
				STRING	mem,		&
				INTEGER	amount,		&
				INTEGER	balance,	&
				BYTE	tax_ded)

    ! Add an entry to the check register
    ! Assume that there is room in the register.

	OPTION TYPE = EXPLICIT
	%INCLUDE 'forms$examples:forms$checking_basic_common'

	register::reg(register::number_entries_used)::reg_check_num = chk_num
	register::reg(register::number_entries_used)::reg_date      = date
	register::reg(register::number_entries_used)::reg_mem       = mem
	register::reg(register::number_entries_used)::reg_amount    = amount
	register::reg(register::number_entries_used)::reg_balance   = balance
	register::reg(register::number_entries_used)::reg_tax_ded   = tax_ded
	register::number_entries_used = register::number_entries_used+1

	SUBEND


1900  	SUB view_register

    ! View the check register, with the option of changing the tax-ded status.

    ! For the sake of a simple application (the form doesn't really care),
    ! we're dealing only with a fixed size register. We send the entire thing
    ! to the form and let it worry about scrolling or whatever. We get the entire
    ! register back, again for simplicity -- we really should get back just the
    ! tax deduction array, but that's more work and this is just a sample.

    ! Part of the record sent to the form is number_entries_used, which tells the
    ! number of meaningful entries, that is, how many are not blank.

    ! There are two possible returns from the form:
    !   1. No  control text => TRANSMIT pressed: update has already happened
    !      because the record came back; return to menu
    !   2. QUT control text => QUIT pressed: No update, return to menu
    ! In both cases, the routine doesn't really have to do anything

    	OPTION TYPE = EXPLICIT
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'

    ! Transceive the record (send it and ask to get it back)

    ! The transceive parameter are as follows:
    !		session id
    !		send record name
    !		number of records sent
    !		receive record name
    !		number of records received
    !		receive ctl text msg
    !		receive ctl text count
    !		send ctl text msg / send ctl text cnt
    !		timeout
    !		parent request id
    !		info sent to form
    !		shadow rec
    !		info sent to form
    !		shadow rec
    !		request options item list

	    forms_status = forms$transceive(				&
            			    session_id,				&
				    'register_record',			&
				    1%,					&
				    'register_record',			&
				    1%,					&
				    receive_ctl::receive_ctl_txt_string, &
				    receive_ctl_txt_ct,			&
				    ,,					&
				    ,					&
				    ,					&
				    ,					&
				    register::register_string,          &
				    ,					&
				    register::register_string,          &
				    )
	    CALL check_forms_status( forms_status )

	SUBEND


2000	SUB view_account_data

    ! Let the operator view and change the account data.

	OPTION TYPE = EXPLICIT
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'
	EXTERNAL INTEGER FUNCTION quit_requested
	DECLARE	account_rec account_temp

    ! Get new information for account record.  If termination was quit,
    ! then the operator might have changed a few things that the quit is
    ! supposed to ignore, so send the original account record back to the
    ! form and return to menu processing.

	forms_status = forms$receive(				&
				session_id,			&
				'account',			&
				1%,				&
				receive_ctl::receive_ctl_txt_string, &
				receive_ctl_txt_ct,		&
				,,				&
				,				&
				,				&
				,				&
				account_temp::account_string,	&
				)
	CALL check_forms_status( forms_status )

	IF quit_requested = 1 THEN
	    forms_status = forms$send(				&
            			    session_id,			&
				    'account',			&
				    1%,				&
				    ,,				&
				    ,,				&
				    ,				&
				    ,				&
				    ,				&
				    account::account_string,	&
				    )
	    CALL check_forms_status( forms_status )
	    EXIT SUB
	END IF

    ! This is where we would ordinarily update the account on the disk.
    ! We don't do that because this is just a demo.  The new information
    ! is available only during this session.

    ! Update the form with new name and city information.
	account = account_temp
	CALL name_and_address

	SUBEND

2100	SUB forms_checking_getsysinfo_(STRING username, STRING version)

	OPTION TYPE = EXPLICIT
	%INCLUDE "$JPIDEF" %FROM %LIBRARY
	%INCLUDE "$SYIDEF" %FROM %LIBRARY
	%INCLUDE 'sys$library:forms$bas_definitions'
	%INCLUDE 'forms$examples:forms$checking_basic_common'
	EXTERNAL LONG FUNCTION lib$getjpi(LONG, LONG, STRING, ANY, STRING)
	EXTERNAL LONG FUNCTION lib$getsyi(LONG, ANY, STRING)

	! Get the user name and the operating system version number.

	    CALL lib$getjpi ( &
		    JPI$_USERNAME,,,, &
		    username)
	    CALL lib$getsyi ( &
		    SYI$_VERSION,, &
		    version)

	    version = "VMS version:  " + version

	END SUB	! End of SUB forms_checking_getsysinfo_