pragma TITLE (
    TITLE => "DECforms Sample Application",
    SUBTITLE => "Software Copyright Notice");

--                        COPYRIGHT (c) 1996 BY
--	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
--
-- 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 DIGITAL EQUIPMENT
-- CORPORATION.
--
-- DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS
-- SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
--

-- PROGRAM DESCRIPTION
--
--	This is the Sample Checking Account Application provided
--        with the DECforms V2.2 product.
--
-- AUTHOR:
--
--	Digital Equipment Corporation
--
-- CREATION DATE:	   Nov-1996
--

pragma TITLE (SUBTITLE => "Files associated with DECforms Checking Sample");
pragma PAGE;

--
-- -------------- VMS - Character Cell and Motif Instructions ------------
--
-- If your system manager copied the Sample from the DECforms kit onto your
-- system, you can run the DECforms Sample Checking Application by 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
--
--   To run the Motif version of the Sample Checking Application:
--
--      $ SET DISPLAY/CREATE/NODE=NODE_NAME
--      $ DEFINE FORMS$DEFAULT_DEVICE DECW$DISPLAY
--	$ 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 Ada language consists
-- of four files:
--
--	FORMS$CHECKING_DATA.DAT			A data file for reading by
--						   the program
--	FORMS$CHECKING_FORM.IFDL		The IFDL source form
--	FORMS$CHECKING_ADA.ADA			The application itself
--	FORMS$ADA_DEFINITIONS.ADA		DECforms package definitions
--
-- The first three 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$ADA_DEFINITIONS.ADA file
-- is put into SYS$LIBRARY unconditionally, so that you should be able to
-- use it from all your ADA 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 ADA
-- language can be created in your own directory from these sources by doing
-- the following:
--
--  $! Set the default to your own directory:
--  $ 	SET DEFAULT yourdirectory
--  $
--  $! Copy all the sources files from FORMS$EXAMPLES to your own directory:
--  $   COPY FORMS$EXAMPLES:FORMS$CHECKING_ADA.ADA, -
--  			    FORMS$CHECKING_FORM.IFDL  []
--  $
--  $! Compile and export the Ada source:
--  $   ADA SYS$LIBRARY:FORMS$ADA_DEFINITIONS.ADA
--  $ 	ADA FORMS$EXAMPLES:FORMS$CHECKING_ADA.ADA
--  $	ACS EXPORT FORMS_CHECKING_ADA/MAIN /OBJ=FORMS$CHECKING_ADA.OBJ
--  $
--  $! Translate the IFDL source form:
--  $ 	FORMS TRANSLATE  FORMS$CHECKING_FORM.IFDL
--  $
--  $! Extract a vector module from the binary form:
--  $	FORMS EXTRACT OBJECT/PORTABLE FORMS$CHECKING_FORM.FORM
--  $
--  $! Link the Ada object and the forms vector:
--  $	LINK FORMS$CHECKING_ADA.OBJ, -
--              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_ADA
--
--   To run the Motif executable:
--
--      $ SET DISPLAY/CREATE/NODE=NODE_NAME
--      $ DEFINE FORMS$DEFAULT_DEVICE DECW$DISPLAY
--  	$ RUN FORMS$CHECKING_ADA
--
--
-- 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.
--

pragma TITLE (SUBTITLE => "Application Record Definitions");
pragma PAGE;

with SYSTEM, STARLET;
package CHECKING_RECORDS is
--
-- Record definitions for DECforms Ada Sample Application.
--
-- These record types are used to instantiate DECforms Generic
-- packages and also to declare storage in the main procedure.
--

--
--  The Account Record contains information about the "user's"
--  checking account.
--
    type ACCOUNT_RECORD is record
	    ACCOUNT_NUMBER   : SYSTEM.UNSIGNED_LONGWORD;
	    DATE_ESTABLISHED : STRING (1..8);
	    ZIP_CODE         : SYSTEM.UNSIGNED_LONGWORD;
	    LAST_NAME	     : STRING (1..20);
	    FIRST_NAME       : STRING (1..15);
	    MIDDLE_NAME      : STRING (1..15);
	    STREET  	     : STRING (1..30);
	    CITY    	     : STRING (1..20);
	    STATE   	     : STRING (1..2);
	    HOME_PHONE	     : STRING (1..10);
	    WORK_PHONE	     : STRING (1..10);
	    PASSWORD	     : STRING (1..12);
	    ACCOUNT_PAD	     : STRING (1..2);		-- Padding for VAX/AXP compatibility
			end record;

--
--  A register entry stores information about a check or deposit.
--
    type REGISTER_ENTRY is record
       REG_CHECK_NUM : SYSTEM.UNSIGNED_LONGWORD;
       REG_DATE	     : STRING (1..8);			-- VAX Date
       REG_AMOUNT    : INTEGER;				-- cents
       REG_BALANCE   : INTEGER;				-- cents
       REG_MEM       : STRING(1..35);			-- Memo
       REG_TAX_DED   : SYSTEM.UNSIGNED_BYTE;		-- 0 or 1
			 end record;

--
--  The REGISTER_RECORD_REC is used to store and send
--  the checking register to the Form.
--
    type REG_ARRAY is array (SYSTEM.UNSIGNED_LONGWORD range <>) of REGISTER_ENTRY;

    reg_size	     : constant SYSTEM.UNSIGNED_LONGWORD := 30;	-- Maximum 30 records in register.

    type REGISTER_RECORD_REC is record
	NUMBER_ENTRIES_USED		: SYSTEM.UNSIGNED_LONGWORD;
	ENTRIES				: REG_ARRAY(1..reg_size);
	end record;

--
--  The CHOICE record is the record that comes back with the operator's choice.
--  The first record field, OPERATOR_CHOICE, has the choice type.
--  In the case of a check, a deposit, a withdrawal, or a transfer between
--  accounts, there is also an amount, and possible some subsidiary information
--  (memo and amount). For the other choices, the subsidiary information is
--  not defined.
--
    type CHOICE_RECORD is record
	OPERATOR_CHOICE : SYSTEM.UNSIGNED_LONGWORD;	 -- Action type
	AMOUNT		: INTEGER;		 -- Positive from form, set
	    				         -- negative for some cases
	CURRENT_DATE	: STRING(1..8);		 -- VAX date
	MEMO		: STRING(1..35);	 -- Reminder of transaction
	CHOICE_PAD	: SYSTEM.UNSIGNED_BYTE;	 -- Padding for VAX/AXP compatibility
	end record;

--
-- The Update record is used for updating the checking register.
--
    type UPDATE_RECORD is record
	    CHECKING_BALANCE	: INTEGER; -- passed as pennies
	    SAVINGS_BALANCE	: INTEGER; -- passed as pennies
	    CHECK_NUMBER	: SYSTEM.UNSIGNED_WORD;
	    ROOM_IN_REG		: SYSTEM.UNSIGNED_BYTE;     -- 0 or 1
	    UPDATE_PAD		: SYSTEM.UNSIGNED_BYTE;	    -- Padding for VAX/AXP compatibility
		    end record;

--
-- The MAIL_FORMAT_RECORD is used to refoirmat some of the information
-- in the account record.
--
    type MAIL_FORMAT_RECORD is record
	    MAIL_NAME	: STRING(1..39);
	    MAIL_CSZ	: STRING(1..30);
	end record;

end CHECKING_RECORDS;

pragma TITLE (SUBTITLE => "Procedure FORMS_CHECKING_GETSYSINFO - Get system information");
pragma PAGE;
with LIB, STARLET, SYSTEM;

procedure FORMS_CHECKING_GETSYSINFO (
    USERNAME : out STRING;
    VERSION  : in out STRING) is

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

STATUS		: SYSTEM.UNSIGNED_LONGWORD;
VERSION_LENGTH  : SYSTEM.UNSIGNED_WORD;
SYI_VERSION     : STRING (1..10);
VERSION_PREFIX	: CONSTANT STRING := "VMS Version:  ";

begin

    LIB.GETJPI (STATUS, STARLET.JPI_USERNAME, RESULTANT_STRING => USERNAME);
    LIB.GETSYI (STATUS, STARLET.SYI_VERSION, RESULTANT_STRING => SYI_VERSION,
	              RESULTANT_LENGTH => VERSION_LENGTH);

    VERSION (VERSION'FIRST..VERSION_PREFIX'LENGTH) := VERSION_PREFIX;

    VERSION (VERSION_PREFIX'LENGTH + 1..VERSION_PREFIX'LENGTH + INTEGER(VERSION_LENGTH)) :=
		    SYI_VERSION (1..INTEGER(VERSION_LENGTH));

end FORMS_CHECKING_GETSYSINFO;

pragma EXPORT_PROCEDURE (
    INTERNAL => FORMS_CHECKING_GETSYSINFO,
    EXTERNAL => "FORMS_CHECKING_GETSYSINFO_",
    PARAMETER_TYPES => (STRING, STRING),
    MECHANISM => (DESCRIPTOR (CLASS => S), DESCRIPTOR (CLASS => S)));


pragma TITLE (SUBTITLE => "Main Procedure Declaration");
pragma PAGE;

with	SYSTEM,
	STARLET,
	TEXT_IO,
	SEQUENTIAL_MIXED_IO,
	CONDITION_HANDLING,
	FORMS_DEFINITIONS,
	CHECKING_RECORDS,
	FORMS_CHECKING_GETSYSINFO;

use	SYSTEM,
	TEXT_IO,
	SEQUENTIAL_MIXED_IO,
	CONDITION_HANDLING,
	FORMS_DEFINITIONS,
	CHECKING_RECORDS;

procedure FORMS_CHECKING_ADA is

--
--  Constant Declarations
--

    SAMPLE_DATA_FILE_NAME : constant STRING
					:= "FORMS$EXAMPLES:FORMS$CHECKING_DATA";
    TERMINAL	     : constant STRING  := "FORMS$DEFAULT_DEVICE";
    FORM_FILE_NAME   : constant STRING  := "FORMS$EXAMPLES:FORMS$CHECKING_FORM";

    sample_data_file : SEQUENTIAL_MIXED_IO.FILE_TYPE;

--
--  Instantiate needed I/O routines from SEQUENTIAL_MIXED_IO
--
    procedure GET_ACCOUNT_RECORD  is new GET_ITEM(CHECKING_RECORDS.ACCOUNT_RECORD);
    procedure GET_REGISTER_RECORD is new GET_ITEM(CHECKING_RECORDS.REGISTER_ENTRY);
    procedure GET_SAVINGS_BALANCE is new GET_ITEM(INTEGER);

--
--  SESSION_ID is used to identify the form used on every call to the
--  FORMS$... subroutines.  All Records passed to the form are declared
--  below.
--
    SESSION_ID		: SESSION_ID_TYPE := "                ";
    ACCOUNT_RECORD_NAME : RECORD_NAME_TYPE(1..7)  := "ACCOUNT";
    UPDATE_RECORD_NAME  : RECORD_NAME_TYPE(1..6)  := "UPDATE";
    MAIL_RECORD_NAME    : RECORD_NAME_TYPE(1..11) := "MAIL_FORMAT";
    CHOOSE_RECORD_NAME  : RECORD_NAME_TYPE(1..6)  := "CHOOSE";
    REGISTER_RECORD_NAME: RECORD_NAME_TYPE(1..15) := "REGISTER_RECORD";
    PRINT_FILE_NAME     : RECORD_NAME_TYPE(1..31) := "SYS$SCRATCH:FORMS$CHECKING_FORM";

    FORMS_STATUS	: COND_VALUE_TYPE;             -- Return condition from FORMS calls
    LAST_CHECK_NUM	: SYSTEM.UNSIGNED_LONGWORD;    -- Last used
    CHECKING_BALANCE	: INTEGER;
    SAVINGS_BALANCE	: INTEGER;
    ACCOUNT		: CHECKING_RECORDS.ACCOUNT_RECORD;
    ACCOUNT_DESCR	: RECORD_DESCR_TYPE := build_record_descr(
					account'size/8,account'address);
    REGISTER		: CHECKING_RECORDS.REGISTER_RECORD_REC;
    REGISTER_DESCR	: RECORD_DESCR_TYPE := build_record_descr(
					register'size/8,register'address);

    NULL_ENTRY		: CHECKING_RECORDS.REGISTER_ENTRY
			   := (0,"19850315",0,0,"                                   ",0);
    CHOICE		: CHECKING_RECORDS.CHOICE_RECORD;
    CHOICE_DESCR	: RECORD_DESCR_TYPE := build_record_descr(
					choice'size/8,choice'address);

-- The ITEM_LIST array is used to pass implementation options to the FORMS$xxx
-- calls. It is an array of structures, each structure containing three long
-- words called an item. The last item in the structure has an initial longword
-- of zero. In this program, we never use more than one item so we declare the
-- array of length two.

    type ITEMLIST_ENTRY is record
	LENGTH			: SYSTEM.UNSIGNED_WORD;
	CODE			: SYSTEM.UNSIGNED_WORD;
	BUFF_ADDR		: SYSTEM.ADDRESS;
	ADDR_LENGTH_RETURNED	: SYSTEM.ADDRESS;
	    end record;

    type ITEMLIST_ARRAY is array (SYSTEM.UNSIGNED_WORD range <>) of ITEMLIST_ENTRY;

    UNUSED  : INTEGER;

    ITEM_LIST : ITEMLIST_ARRAY(1..2) :=
		((35,K_PRINTFILE,PRINT_FILE_NAME'address,unused'address),(0,0,unused'address,unused'address));

--  Receive control text is an array of up to five five-character control text
--  items returned by the FORMS$... calls. The call also returns a count.

    RECEIVE_CTL_TXT_CT	: INTEGER;
    RECEIVE_CTL_TXT   	: CONTROL_TEXT := "                         ";

--  Send control text is an array of up to five five-character control text
--  items sent to the FORMS$... calls. The call also requires a count.

    SEND_CTL_TXT_CT	  : INTEGER;
    SEND_CTL_TXT   	  : CONTROL_TEXT := "                         ";

pragma TITLE (SUBTITLE => "External interface definitions");
pragma PAGE;

procedure STR_TRIM (STATUS  : out COND_VALUE_TYPE;
		    DST_STR : out STRING;
		    SRC_STR : in STRING;
		    OUT_LEN : out SYSTEM.UNSIGNED_WORD);

procedure STR_TRIM (STATUS  : out COND_VALUE_TYPE;
		    DST_STR : out STRING;
		    SRC_STR : in STRING);  -- Optional OUT_LEN ommited


pragma INTERFACE (STR, STR_TRIM);

pragma IMPORT_VALUED_PROCEDURE (
    INTERNAL => STR_TRIM,
    EXTERNAL => "STR$TRIM",
    PARAMETER_TYPES => (COND_VALUE_TYPE, STRING, STRING, SYSTEM.UNSIGNED_WORD),
    MECHANISM => (VALUE, DESCRIPTOR, DESCRIPTOR, REFERENCE));

pragma IMPORT_VALUED_PROCEDURE (
    INTERNAL => STR_TRIM,
    EXTERNAL => "STR$TRIM",
    PARAMETER_TYPES => (COND_VALUE_TYPE, STRING, STRING),
    MECHANISM => (VALUE, DESCRIPTOR, DESCRIPTOR));


pragma TITLE (SUBTITLE => "Status Checking Routine");
pragma PAGE;
procedure CHECK_FORMS_STATUS (FORMS_STATUS : in COND_VALUE_TYPE) is

-- Check the parameter for success. If not success, print error
-- message and stop.

begin
    if not SUCCESS(FORMS_STATUS) then
	STOP (FORMS_STATUS);
    end if;

end CHECK_FORMS_STATUS;

pragma TITLE (SUBTITLE => "Procedure ADD_TO_REGISTER");
pragma PAGE;

procedure ADD_TO_REGISTER(
	    CHK_NUM	: SYSTEM.UNSIGNED_LONGWORD;
	    DATE   	: STRING;
	    MEM    	: STRING;
	    AMOUNT 	: INTEGER;
	    BALANCE	: INTEGER;
	    TAX_DED	: UNSIGNED_BYTE) is

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

    begin

    REGISTER.NUMBER_ENTRIES_USED := REGISTER.NUMBER_ENTRIES_USED + 1;

    REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_CHECK_NUM := CHK_NUM;
    REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_DATE      := DATE;
    REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_MEM       := MEM;
    REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_AMOUNT    := AMOUNT;
    REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_BALANCE   := BALANCE;
    REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_TAX_DED   := TAX_DED;

    end ADD_TO_REGISTER;

pragma TITLE (SUBTITLE => "Test for Quit requested routine");
pragma PAGE;
function QUIT_REQUESTED return BOOLEAN is

--
--     	Check the receive control text.
--	Return TRUE if operator requested QUIT, return FALSE otherwise.
--

    CTL_TXT_ITM    	: CONTROL_TEXT;
    SLICE_BEGIN,
    SLICE_END		: INTEGER;

    begin

    for I in 1..RECEIVE_CTL_TXT_CT loop

	--
	-- Get a slice of the control text to look at.
	--
	slice_begin := (INTEGER'VAL(I) - 1) * 5 + 1;
	slice_end   := slice_begin + 4;
	CTL_TXT_ITM(1..5) := RECEIVE_CTL_TXT(SLICE_BEGIN..SLICE_END);

	--
	--  Look at the last three characters of the 5 character slice.
	--
	if CTL_TXT_ITM(3..5) = "QUT" then
	    return TRUE;
	end if;

    end loop;

    return FALSE;

    end QUIT_REQUESTED;

pragma TITLE (SUBTITLE => "Procedure UPDATE - updates form with balances, etc");
pragma PAGE;
procedure UPDATE_FORM is

--
--     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.
--

	UPDATE	: CHECKING_RECORDS.UPDATE_RECORD;
	UPDATE_DESCR : RECORD_DESCR_TYPE := BUILD_RECORD_DESCR(UPDATE'size/8,
								UPDATE'address);

    begin

   	UPDATE.CHECKING_BALANCE := CHECKING_BALANCE;
   	UPDATE.SAVINGS_BALANCE  := SAVINGS_BALANCE;
	UPDATE.CHECK_NUMBER     := SYSTEM.UNSIGNED_WORD(LAST_CHECK_NUM);

	if REGISTER.NUMBER_ENTRIES_USED < REG_SIZE then
	    update.room_in_reg := 1;
	else
	    update.room_in_reg := 0;
	end if;

        FORMS_SEND  (STATUS          => FORMS_STATUS,
		     SESSION_ID      => SESSION_ID,
		     SEND_RECORD_ID  => UPDATE_RECORD_NAME,
		     SEND_RECORD_CNT => 1,
		     DATA_REC_1      => UPDATE_DESCR'address);

	CHECK_FORMS_STATUS( FORMS_STATUS );

end UPDATE_FORM;

pragma TITLE (SUBTITLE => "Procedure ACCOUNT_TRANSFER - performs account transfers");
pragma PAGE;
procedure ACCOUNT_TRANSFER is

--  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.
--
	CHECK_NUMBER : SYSTEM.UNSIGNED_LONGWORD;

    begin

    --  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;

    case CHOICE.OPERATOR_CHOICE is
	when 1 =>
	    null;
	when 2 =>
	    --
	    -- Write a check. The amount gets entered as a checking negative.
	    --
	     CHECK_NUMBER   := LAST_CHECK_NUM;
	     LAST_CHECK_NUM := LAST_CHECK_NUM + 1;
	     CHOICE.AMOUNT  := - CHOICE.AMOUNT;
	when 3 =>
	    --
	    -- Deposit into checking, use amount as it stands.
	    --
	    NULL;
	when 4 =>
	    --
	    -- Cash withdrawal. The amount gets entered as a checking negative.
	    --
	    CHOICE.AMOUNT  := - CHOICE.AMOUNT;
	when 5 =>
	    --
	    -- Transfer from checking to savings.
	    --
	    SAVINGS_BALANCE := SAVINGS_BALANCE + CHOICE.AMOUNT;
	    CHOICE.AMOUNT   := - CHOICE.AMOUNT;
	when 6 =>
	    --
	    -- Transfer from savings to checking.
	    --
	    SAVINGS_BALANCE := SAVINGS_BALANCE - CHOICE.AMOUNT;
	when others =>
	    null;
    end case;

--
--    Now update the checking balance, create new register item, and
--    transfer new values to the form.
--

    CHECKING_BALANCE := CHECKING_BALANCE + CHOICE.AMOUNT;

    ADD_TO_REGISTER(
		CHECK_NUMBER, 		-- REG_CHK_NUM
		CHOICE.CURRENT_DATE, 	-- REG_DATE
		CHOICE.MEMO,		-- REG_MEMO
		CHOICE.AMOUNT,		-- REG_AMOUNT
		CHECKING_BALANCE,      	-- REG_BALANCE
		0 );	      		-- REG_TAX_DED

    UPDATE_FORM;

end ACCOUNT_TRANSFER;

pragma TITLE (SUBTITLE => "Procedure VIEW_REGISTER - allows user to see register");
pragma PAGE;

procedure VIEW_REGISTER is

--
-- 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
--

    begin

	--
	-- Transceive the record (send it and ask to get it back)
	--
	FORMS_TRANSCEIVE  (STATUS		=> FORMS_STATUS,
			   SESSION_ID		=> SESSION_ID,
			   SEND_RECORD_ID	=> REGISTER_RECORD_NAME,
			   SEND_RECORD_CNT	=> 1,
			   DATA_REC_1		=> REGISTER_DESCR'address,
			   RECEIVE_RECORD_ID	=> REGISTER_RECORD_NAME,
			   RECEIVE_RECORD_CNT	=> 1,
			   DATA_REC_2		=> REGISTER_DESCR'address);
	CHECK_FORMS_STATUS (FORMS_STATUS);

    end VIEW_REGISTER;

pragma TITLE (SUBTITLE => "Procedure NAME_AND_ADDRESS - Format the account data");
pragma PAGE;
procedure NAME_AND_ADDRESS is

-- Format the account data name and address and send to the form
--
--      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.
--

	MAIL_FORMAT		: CHECKING_RECORDS.MAIL_FORMAT_RECORD :=
		(MAIL_NAME => "                                       ",
		 MAIL_CSZ  => "                              ");
	MAIL_FORMAT_DESCR : RECORD_DESCR_TYPE :=
			    BUILD_RECORD_DESCR( MAIL_FORMAT'size/8,
						MAIL_FORMAT'address);

	TRIM_LENGTH_LAST	: SYSTEM.UNSIGNED_WORD;
	TRIM_LENGTH_FIRST	: SYSTEM.UNSIGNED_WORD;
	TRIM_LENGTH_CITY	: SYSTEM.UNSIGNED_WORD;
    	STRING_ZIP		: STRING(1..6);  -- One extra char for leading space
						 -- in 'IMAGE attribute
	CHAR_CNT		: INTEGER;
	STATUS			: COND_VALUE_TYPE;

    begin

--
--    Need to trim trailing blanks -- use the VMS RTL routine to find
--    out how long the trimmed strings are, then do explicit concatenations
--    and move.
--
    STR_TRIM (STATUS, ACCOUNT.FIRST_NAME, ACCOUNT.FIRST_NAME, TRIM_LENGTH_FIRST);
    STR_TRIM (STATUS, ACCOUNT.LAST_NAME,  ACCOUNT.LAST_NAME,  TRIM_LENGTH_LAST);
    STR_TRIM (STATUS, ACCOUNT.CITY,       ACCOUNT.CITY,       TRIM_LENGTH_CITY);

--
--      Format the name. Put only middle initial in, not full middle name.
--
    MAIL_FORMAT.MAIL_NAME(1..INTEGER'VAL(TRIM_LENGTH_FIRST))
		    := ACCOUNT.FIRST_NAME(1..INTEGER'VAL(TRIM_LENGTH_FIRST));
    CHAR_CNT := INTEGER'VAL(TRIM_LENGTH_FIRST) + 1;

    MAIL_FORMAT.MAIL_NAME(CHAR_CNT..CHAR_CNT + 3) :=
				    " " & ACCOUNT.MIDDLE_NAME(1) & ". ";
    CHAR_CNT := CHAR_CNT + 4;

    MAIL_FORMAT.MAIL_NAME(CHAR_CNT..CHAR_CNT + INTEGER'VAL(TRIM_LENGTH_LAST) -1)
		:= ACCOUNT.LAST_NAME(1..INTEGER'VAL(TRIM_LENGTH_LAST));

--
-- Format the City, State, Zip line
--

    STRING_ZIP(1..6) := UNSIGNED_LONGWORD'IMAGE(ACCOUNT.ZIP_CODE);
    MAIL_FORMAT.MAIL_CSZ (1..INTEGER'VAL(TRIM_LENGTH_CITY)) :=
			    ACCOUNT.CITY(1..INTEGER'VAL(TRIM_LENGTH_CITY));

    CHAR_CNT := INTEGER'VAL(TRIM_LENGTH_CITY);
    CHAR_CNT := CHAR_CNT + 1;
    MAIL_FORMAT.MAIL_CSZ (CHAR_CNT..CHAR_CNT + 9)
                := ", " & ACCOUNT.STATE(1..2) & " " & STRING_ZIP(2..6);

--
-- Send the formatted information to the Form.
--
    MAIL_FORMAT_DESCR := BUILD_RECORD_DESCR( MAIL_FORMAT'size/8,
					     MAIL_FORMAT'address);
    FORMS_SEND (STATUS		=> FORMS_STATUS,
		SESSION_ID	=> SESSION_ID,
		SEND_RECORD_ID	=> MAIL_RECORD_NAME,
		SEND_RECORD_CNT	=> 1,
		DATA_REC_1	=> MAIL_FORMAT_DESCR'address);
    CHECK_FORMS_STATUS (FORMS_STATUS);

end NAME_AND_ADDRESS;

pragma TITLE (SUBTITLE => "VIEW_ACCOUNT_DATA -  Let operator view and change account data");
pragma PAGE;
procedure VIEW_ACCOUNT_DATA is

--
-- Temporary storage area so ACCOUNT_RECORD doesn't get blasted in case
-- of a cancel in the middle of operator update.
--
    TEMP_ACCOUNT	: CHECKING_RECORDS.ACCOUNT_RECORD;
    TEMP_ACCOUNT_DESCR	: RECORD_DESCR_TYPE := build_record_descr(
					account'size/8,temp_account'address);
--
-- Let the operator view and change the account data.
--

    begin

--
--      Get new information for current account or quit from operator.
--      If it's quit, then just return to menu processing.
--
    FORMS_RECEIVE  (STATUS		=> FORMS_STATUS,
		    SESSION_ID		=> SESSION_ID,
		    RECEIVE_RECORD_ID	=> ACCOUNT_RECORD_NAME,
		    RECEIVE_RECORD_CNT	=> 1,
		    DATA_REC_1		=> TEMP_ACCOUNT_DESCR'address,
		    RECEIVE_CTL_MSG	=> RECEIVE_CTL_TXT,
		    RECEIVE_CTL_CNT	=> RECEIVE_CTL_TXT_CT);
    CHECK_FORMS_STATUS (FORMS_STATUS);

    if not QUIT_REQUESTED then
	begin
	  --
	  -- 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 := TEMP_ACCOUNT;
	  NAME_AND_ADDRESS;
	end;
    else
        begin
        FORMS_SEND (STATUS		=> FORMS_STATUS,
		    SESSION_ID		=> SESSION_ID,
                    SEND_RECORD_ID	=> ACCOUNT_RECORD_NAME,
		    SEND_RECORD_CNT 	=> 1,
                    DATA_REC_1		=> ACCOUNT_DESCR'address);
        CHECK_FORMS_STATUS( FORMS_STATUS );
        end;
    end if;

end VIEW_ACCOUNT_DATA;

pragma TITLE (SUBTITLE => "Procedure INITIALIZE_ACCOUNT - Read in data file and format it");
pragma PAGE;
procedure INITIALIZE_ACCOUNT is

--      Read from file FORMS$CHECKING_DATA.DAT into internal variables.
--      Write the account information to the form.
--      Reformat some account info and send that to the form.

    type SAVINGS_BALANCE_STRING is new STRING (1..4);
    I : SYSTEM.UNSIGNED_LONGWORD;

    begin

    --  Open file, get account data.

    OPEN( FILE  => SAMPLE_DATA_FILE,
	  NAME  => SAMPLE_DATA_FILE_NAME,
	  MODE  => IN_FILE,
	  FORM	=> "FILE; DEFAULT_NAME '.DAT'");

    RESET (FILE => SAMPLE_DATA_FILE, MODE => IN_FILE);

    -- Read the account record and savings balance

    READ (FILE => SAMPLE_DATA_FILE);
    GET_ACCOUNT_RECORD (FILE => SAMPLE_DATA_FILE, ITEM => ACCOUNT);
    READ (FILE => SAMPLE_DATA_FILE);
    GET_SAVINGS_BALANCE (FILE => SAMPLE_DATA_FILE, ITEM => 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;

    while (REGISTER.NUMBER_ENTRIES_USED < REG_SIZE) loop

	REGISTER.NUMBER_ENTRIES_USED := REGISTER.NUMBER_ENTRIES_USED + 1;

	READ (FILE => SAMPLE_DATA_FILE);
	GET_REGISTER_RECORD (FILE => SAMPLE_DATA_FILE,
                             ITEM => REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED));

	if REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_CHECK_NUM /= 0 then
	    LAST_CHECK_NUM := REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_CHECK_NUM;
	end if;

	exit when END_OF_FILE(sample_data_file);

    end loop;

    CLOSE (FILE => SAMPLE_DATA_FILE);
    if REGISTER.NUMBER_ENTRIES_USED = 0 then
	PUT_LINE("Data file in error, no register entries read.");
    end if;

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

    CHECKING_BALANCE := REGISTER.ENTRIES(REGISTER.NUMBER_ENTRIES_USED).REG_BALANCE;
    LAST_CHECK_NUM := LAST_CHECK_NUM + 1;

-- Initialize the remaining reg_mem and reg_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.

	I := REGISTER.NUMBER_ENTRIES_USED + 1;
	while (I <= REG_SIZE) loop
	    REGISTER.ENTRIES(I) := NULL_ENTRY;
	    I := I+1;
	end loop;

--
--  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

    FORMS_SEND (STATUS		=> FORMS_STATUS,
		SESSION_ID	=> SESSION_ID,
                SEND_RECORD_ID	=> ACCOUNT_RECORD_NAME,
		SEND_RECORD_CNT	=> 1,
                DATA_REC_1	=> ACCOUNT_DESCR'address);
    CHECK_FORMS_STATUS( FORMS_STATUS );

    UPDATE_FORM;

    NAME_AND_ADDRESS;

end INITIALIZE_ACCOUNT;

pragma TITLE (SUBTITLE => "Procedure DO_OPERATOR_CHOICE - Function dispatcher");
pragma PAGE;
procedure DO_OPERATOR_CHOICE is

--
--     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
--

    begin

    loop

	FORMS_RECEIVE  (STATUS		    => FORMS_STATUS,
			SESSION_ID	    => SESSION_ID,
			RECEIVE_RECORD_ID   => CHOOSE_RECORD_NAME,
			RECEIVE_RECORD_CNT  => 1,
			DATA_REC_1	    => CHOICE_DESCR'address);
	CHECK_FORMS_STATUS(FORMS_STATUS);

	case CHOICE.OPERATOR_CHOICE is
	    when 1 =>
		null;

	    when 2 | 3 | 4 | 6 | 5 =>
		ACCOUNT_TRANSFER;

	    when 7 =>
		VIEW_REGISTER;

	    when 8 =>
		VIEW_ACCOUNT_DATA;

	    when others =>
		null;

	end case;

	exit when CHOICE.OPERATOR_CHOICE = 1;

    end loop;

end DO_OPERATOR_CHOICE;

pragma TITLE (SUBTITLE => "FORMS_CHECKING_ADA - main procedure");
pragma PAGE;

begin -- procedure FORMS_CHECKING_ADA

PUT_LINE ( "Ada DECforms Sample Checking Account Application starting.");

-- Initialize the DECforms form & check for errors.

    FORMS_ENABLE (STATUS 	  => FORMS_STATUS,
		  VECTOR_ADDRESS  => AR_FORM_TABLE'address,
		  DISPLAY_DEVICE  => TERMINAL,
		  SESSION_ID 	  => SESSION_ID,
		  FORM_FILE_SPEC  => FORM_FILE_NAME,
		  REQUEST_OPTIONS => ITEM_LIST'address);
CHECK_FORMS_STATUS (FORMS_STATUS);

-- Initialize account information

INITIALIZE_ACCOUNT;

-- Process all operator requests

DO_OPERATOR_CHOICE;

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

    FORMS_DISABLE (STATUS     => FORMS_STATUS,
		   SESSION_ID => SESSION_ID);
CHECK_FORMS_STATUS( FORMS_STATUS );

PUT_LINE ( "Ada DECforms Sample Checking Account Application ending.");

end FORMS_CHECKING_ADA;