forms$checking_pli : PROCEDURE OPTIONS(MAIN); /* * COPYRIGHT (c) 1988, 1989, 1995 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.0 product. * * AUTHOR: * * Digital Equipment Corporation * * CREATION DATE: Jan-1989 * * MODIFIED: Jan-1991 * Sep-1993 * Mar-1995 * */ /* * --------------- 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 PL/I 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_PLI.PLI The application itself * FORMS$PLI_DEFINITIONS.PLI An include file with DECforms * 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$PLI_DEFINITIONS.PLI file is put into SYS$LIBRARY * unconditionally, so that you should be able to use it from all your PL/I * 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 PL/I * 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_PLI.PLI, - * FORMS$PLI_DEFINITIONS.PLI, - * FORMS$CHECKING_FORM.IFDL [] * $ * $! Compile the PLI source: * $ PLI FORMS$EXAMPLES:FORMS$CHECKING_PLI.PLI * $ * $! Translate the IFDL source form: * $ FORMS TRANSLATE FORMS$EXAMPLES:FORMS$CHECKING_FORM.IFDL * $ * $! Extract a vector module from the binary form: * $ FORMS EXTRACT OBJECT/PORTABLE FORMS$CHECKING_FORM.FORM * $ * $! Link the PLI object and the forms vector: * $ LINK FORMS$CHECKING_PLI.OBJ, - * FORMS$CHECKING_FORM.OBJ - * SYS$INPUT/OPTIONS * SYS$LIBRARY:VAXCRTL.EXE/SHARE * * 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_PLI * * To run the Motif executable: * * $ SET DISPLAY/CREATE/NODE=NODE_NAME * $ DEFINE FORMS$DEFAULT_DEVICE DECW$DISPLAY * $ RUN FORMS$CHECKING_PLI * * * 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. * */ DCL LIB$SIGNAL ENTRY (FIXED BIN(31)); %INCLUDE $STSDEF; %INCLUDE 'FORMS$PLI_DEFINITIONS'; /* Data definitions */ %REPLACE TRUE BY '1'B; %REPLACE FALSE BY '0'B; %REPLACE terminal BY 'FORMS$DEFAULT_DEVICE'; %REPLACE form_file BY 'FORMS$EXAMPLES:FORMS$CHECKING_FORM'; %REPLACE reg_size BY 30; /* Maximum 30 records in register. */ /* The ACCOUNT record is stored in the data file. It is sent to the form at the beginning of the program to set the form storage variables. It is received when account updating is to be done. */ DCL 1 account, 2 account_number FIXED BINARY, 2 date_established CHAR(8), 2 zip_code FIXED BINARY, 2 last_name CHAR(20), 2 first_name CHAR(15), 2 middle_name CHAR(15), 2 street CHAR(30), 2 city CHAR(20), 2 state CHAR(2), 2 home_phone CHAR(10), 2 work_phone CHAR(10), 2 password CHAR(12), 2 account_pad CHAR(2); DCL 1 account_string CHAR(SIZE(account)) BASED(ADDR(account)); /* The REGISTER keeps track of all checks written and all deposits made, one entry for each check or deposit. For simplicity in the application, we keep only 30 register records. A real application would be much more complex. */ DCL 1 register, 2 number_entries_used FIXED BIN(31), 2 entry( reg_size ), 3 reg_check_num FIXED BIN(31), /*Check number if a check, zero else*/ 3 reg_date CHAR(8), /*Date of action*/ 3 reg_amount FIXED BIN, /*Amount of action*/ 3 reg_balance FIXED BIN, /*Balance after action*/ 3 reg_mem CHAR(35), /*Payto if check, memo if deposit*/ 3 reg_tax_ded FIXED BIN(7); DCL 1 register_string CHAR(SIZE(register)) BASED(ADDR(register)); /* 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. */ DCL 1 choice, 2 operator_choice FIXED BIN(31), /* Action type */ 2 amount FIXED BIN, /* Positive from form, set negative for some cases */ 2 current_date CHAR(8), /* VAX date */ 2 memo CHAR(35), /* Reminder of transaction */ 2 choice_pad CHAR(1); /* Padding for VAX/AXP compatibility */ DCL 1 choice_string CHAR(SIZE(choice)) BASED(ADDR(choice)); /* Session_id is used to identify the form used on every call to the FORMS$... subroutines. */ DCL session_id CHAR(16) INIT(' '); DCL last_check_num FIXED BIN(31); /* Last used */ DCL checking_balance FIXED BIN; DCL savings_balance FIXED BIN; /* 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. */ DCL receive_ctl_txt_ct FIXED BIN; DCL receive_ctl_txt_string CHAR(25); /* For ease in passing by descriptor */ DCL receive_ctl_txt (5) CHAR(5) DEFINED( receive_ctl_txt_string ); /* 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. */ DCL send_ctl_txt_ct FIXED BIN; DCL send_ctl_txt_string CHAR(25); /* For ease in passing by descriptor */ DCL send_ctl_txt (5) CHAR(5) DEFINED( send_ctl_txt_string ); /***************************************************************************** /* Main Routine of Checking Sample /*****************************************************************************/ DCL 1 item_list(2), 2 length FIXED BIN(15), 2 code FIXED BIN(15), 2 buff_addr POINTER, 2 addr_length_returned POINTER; DCL print_file_name CHAR(31) INIT('SYS$SCRATCH:FORMS$CHECKING_FORM'); /* 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 -- we have to set the two words to zero to make the long word zero. */ item_list(1).length = 35; item_list(1).code = forms$k_printfile; item_list(1).buff_addr = ADDR(print_file_name); item_list(2).length = 0; item_list(2).code = 0; /* Initialize account information */ PUT LIST( 'PL/I DECforms Sample Checking Account Application starting.'); /* Initialize the DECforms form & check for errors. */ sts$value = forms$enable( forms$ar_form_table, /* Needed for procedural escapes*/ terminal, session_id, form_file, ,,,,,,,item_list); CALL check_forms_status; /* Initialize account information */ CALL initialize_account; /* Process all operator requests */ CALL do_operator_choice; /* Clean up, Print ending message on console, leave. */ sts$value = forms$disable( session_id ); CALL check_forms_status; PUT LIST( 'PL/1 DECforms Sample Checking Account Application ending.'); check_forms_status: PROCEDURE; /***************************************************************************** /* Check sts$value (a VMS return code) for success. /* If not success, print error message and stop. /*****************************************************************************/ IF ^sts$success THEN DO; CALL LIB$SIGNAL( sts$value ); STOP; END; END check_forms_status; initialize_account: PROCEDURE; /***************************************************************************** /* 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. /*****************************************************************************/ /* Open file, get account data */ DCL accountfile RECORD INPUT; DCL eof BIT INITIAL('0'B); DCL i FIXED BIN; ON ENDFILE( accountfile ) BEGIN; CLOSE FILE( accountfile ); eof = '1'B; END; OPEN FILE( accountfile ) TITLE( 'FORMS$EXAMPLES:FORMS$CHECKING_DATA.DAT' ); /* Read the account record and savings balance */ READ FILE (accountfile) INTO (account); READ FILE (accountfile) INTO (savings_balance); /* 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). /* */ last_check_num = 0; register.number_entries_used = 0; DO WHILE (register.number_entries_used < reg_size & ^eof); register.number_entries_used = register.number_entries_used + 1; READ FILE (accountfile) INTO (register.entry(register.number_entries_used)); IF ^eof & register.entry(register.number_entries_used).reg_check_num ^= 0 THEN last_check_num = register.entry(register.number_entries_used).reg_check_num; END; /* Reach here as result of end of file or filled register. Check for data file in error. */ IF register.number_entries_used > 0 THEN DO; IF register.number_entries_used > reg_size THEN PUT SKIP LIST( 'Data file probably too big, only using ', reg_size, ' records.'); ELSE register.number_entries_used = register.number_entries_used - 1; END; ELSE DO; PUT SKIP LIST( 'Data file in error, no register entries read.'); STOP; END; /* Initialize the remaining 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. */ DO i = register.number_entries_used + 1 TO reg_size; register.entry(i).reg_check_num = 0; register.entry(i).reg_date = '19850315'; register.entry(i).reg_amount = 0; register.entry(i).reg_balance = 0; register.entry(i).reg_mem = ' '; register.entry(i).reg_tax_ded = 0; END; /* Take balance from last record read. Update check number to be the next check number to use. */ checking_balance = register.entry(register.number_entries_used).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 */ sts$value = forms$send( session_id, /* session id */ 'account', /* record name in form */ 1, /* Number of records sent */ ,, /* Receive ctl text msg/count */ ,, /* Send ctl text msg/count */ , /* timeout */ , /* parent request id */ , /* request options item list */ account_string, /* the record */ ); /* shadow record */ CALL check_forms_status; CALL update_form; CALL name_and_address; END initialize_account; name_and_address: PROCEDURE; /*****************************************************************************/ /* 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. */ DCL 1 mail_format, 2 mail_name CHAR(39), 2 mail_csz CHAR(30); DCL 1 mail_format_string CHAR(SIZE(mail_format)) BASED(ADDR(mail_format)); DCL string_zip PICTURE '99999'; mail_name = TRIM( first_name ) || ' ' || SUBSTR( middle_name, 1, 1 ) || '. ' || TRIM( last_name ); string_zip = account.zip_code; mail_csz = TRIM( city ) || ', ' || state || ' ' || string_zip; sts$value = forms$send( session_id, /* session id */ 'mail_format', /* record name in form */ 1, /* Number of records sent */ ,, /* Receive ctl text msg/count */ ,, /* Send ctl text msg/count */ , /* timeout */ , /* parent request id */ , /* request options item list */ mail_format_string, /* the record */ ); /* shadow record */ CALL check_forms_status; END name_and_address; update_form: PROCEDURE; /*****************************************************************************/ /* 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. /*****************************************************************************/ DCL 1 update, 2 check_balance FIXED BIN, 2 save_balance FIXED BIN, 2 check_number FIXED BIN(15), 2 room_in_reg BIT (1)ALIGNED, 2 memo CHAR(1); /* Padding for VAX/AXP compatibility */ DCL update_string CHAR(SIZE(update)) BASED(ADDR(update)); update.check_balance = checking_balance; update.save_balance = savings_balance; update.check_number = last_check_num; update.room_in_reg = register.number_entries_used < reg_size; sts$value = forms$send( session_id, /* session id */ 'update', /* record name in form */ 1, /* Number of records sent */ ,, /* Receive ctl text msg/count */ ,, /* Send ctl text msg/count */ , /* timeout */ , /* parent request id */ , /* request options item list */ update_string, /* the record */ ); /* shadow record */ CALL check_forms_status; END update_form; quit_requested: PROCEDURE RETURNS(BIT(1)); /*****************************************************************************/ /* Check the receive control text. /* Return TRUE if operator requested QUIT, return FALSE otherwise. /*****************************************************************************/ DCL i FIXED BIN; DCL result BIT(1); /* Assume false till proven otherwise. */ result = FALSE; DO i = 1 TO receive_ctl_txt_ct; IF SUBSTR( receive_ctl_txt(i), 3, 3) = 'QUT' THEN result = TRUE; END; RETURN(result); END quit_requested; do_operator_choice: PROCEDURE; /***************************************************************************** /* 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 /*****************************************************************************/ DO UNTIL (choice.operator_choice = 1); sts$value = forms$receive( session_id, /* session id */ 'choose', /* record name in form */ 1, /* Number of records sent */ ,, /* Receive ctl text msg/count */ ,, /* Send ctl text msg/count */ , /* timeout */ , /* parent request id */ , /* request options item list */ choice_string, /* the record */ ); /* shadow record */ CALL check_forms_status; SELECT (choice.operator_choice); WHEN (1) ; WHEN (2,3,4,5,6) CALL account_transfer; WHEN (7) CALL view_register; WHEN (8) CALL view_account_data; END; END; END do_operator_choice; account_transfer: PROCEDURE; /***************************************************************************** /* 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. /*****************************************************************************/ DCL check_number FIXED BIN; /* 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); WHEN (2) /* Write a check. The amount gets entered as a checking negative.*/ DO; check_number = last_check_num; last_check_num = last_check_num + 1; choice.amount = - choice.amount; END; WHEN (3) /* Deposit into checking, use amount as it stands. */ ; WHEN (4) /* Cash withdrawal. The amount gets entered as a checking negative.*/ choice.amount = - choice.amount; WHEN (5) /* Transfer from checking to savings. */ DO; savings_balance = savings_balance + choice.amount; choice.amount = - choice.amount; END; WHEN (6) /* Transfer from savings to checking. */ savings_balance = savings_balance - choice.amount; END; /* Now update the checking balance, create new register item, and transfer new values to the form. */ checking_balance = checking_balance + choice.amount; CALL 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 */ CALL update_form; END account_transfer; add_to_register: PROCEDURE( chk_num, date, mem, amount, balance, tax_ded); /***************************************************************************** /* Add an entry to the check register /* Assume that there is room in the register. /****************************************************************************/ DCL chk_num FIXED BIN, date CHAR(8), mem CHAR(35), amount FIXED BIN, balance FIXED BIN, tax_ded FIXED BIN(7); register.number_entries_used = register.number_entries_used+1; register.entry(register.number_entries_used).reg_check_num = chk_num; register.entry(register.number_entries_used).reg_date = date; register.entry(register.number_entries_used).reg_mem = mem; register.entry(register.number_entries_used).reg_amount = amount; register.entry(register.number_entries_used).reg_balance = balance; register.entry(register.number_entries_used).reg_tax_ded = tax_ded; END add_to_register; view_register: PROCEDURE; /***************************************************************************** /* 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 /****************************************************************************/ /* Transceive the record (send it and ask to get it back) */ sts$value = forms$transceive( session_id, /* session id */ 'register_record', /* send record name in form */ 1, /* Number of records sent */ 'register_record', /* receive record name in form */ 1, /* Number of records sent */ receive_ctl_txt_string, /* Receive ctl text msg */ receive_ctl_txt_ct, /* Receive ctl text count */ ,, /* Send ctl text msg/count */ , /* timeout */ , /* parent request id */ , /* request options item list */ register_string, /* the send record */ , /* send shadow record */ register_string, /* the receive record */ ); /* receive shadow record */ CALL check_forms_status; END view_register; view_account_data: PROCEDURE; /***************************************************************************** /* Let the operator view and change the account data. /*****************************************************************************/ DCL 1 account_temp LIKE account; DCL 1 account_temp_string CHAR(SIZE(account_temp)) BASED(ADDR(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. */ sts$value = forms$receive( session_id, /* session id */ 'account', /* record name in form */ 1, /* Number of records sent */ receive_ctl_txt_string, /* Receive ctl text msg */ receive_ctl_txt_ct, /* Receive ctl text count */ ,, /* Send ctl text msg/count */ , /* timeout */ , /* parent request id */ , /* request options item list */ account_temp_string, /* the record */ ); /* shadow record */ CALL check_forms_status; IF quit_requested() THEN DO; /*account data in form may have changed despite quit, change it back*/ sts$value = forms$send( session_id, /* session id */ 'account', /* record name in form */ 1, /* Number of records sent */ ,, /* Receive ctl text msg/count */ ,, /* Send ctl text msg/count */ , /* timeout */ , /* parent request id */ , /* request options item list */ account_string, /* the record */ ); /* shadow record */ CALL check_forms_status; END; ELSE; DO; /* 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; /*make changes permanent*/ CALL name_and_address; END; END; END forms$checking_pli; forms_checking_getsysinfo_: PROCEDURE (username, version); /****************************************************************************** / * Get the user name and the operating system version number. /*****************************************************************************/ %include $jpidef; %include $syidef; %include lib$getjpi; %include lib$getsyi; declare username char(*), version char(*); declare status fixed bin(31); status = lib$getjpi (JPI$_USERNAME,,,, username); status = lib$getsyi (SYI$_VERSION,, version); version = 'VMS version: ' || version; end forms_checking_getsysinfo_;