***************************************************************************** * The DECforms V4.0 Sample Checking Account Application * ***************************************************************************** * * © 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. * * * *++ * * PROGRAM DESCRIPTION: * * This is the Sample Checking Account Application provided with the * DECforms V4.0 product. * * AUTHOR: * Hewlett-Packard Development Company, L.P. * * CREATION DATE: Jan-1986 * * MODIFIED: Jan-1991 * Sep-1993 * Mar-1995 * *-- / * --------------- 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 COBOL 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_COBOL.COB The application itself * FORMS$COB_DEFINITIONS.LIB A copy 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$COB_DEFINITIONS.LIB file * is put into SYS$LIBRARY unconditionally, so that you should be able to * use it from all your COBOL 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 COBOL * 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_COBOL.COB, - * FORMS$CHECKING_FORM.IFDL [] * $ * $! Compile the COBOL source: * $ COBOL FORMS$CHECKING_COBOL.COB * $ * $! 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 COBOL object and the forms vector: * $ LINK FORMS$CHECKING_COBOL.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_COBOL * * 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. * * / IDENTIFICATION DIVISION. PROGRAM-ID. forms$checking_cobol. DATA DIVISION. WORKING-STORAGE SECTION. *+ * The DECforms definitions *- COPY "sys$library:forms$cob_definitions.lib". *+ * Information that is transferred between this program and DECforms *- 01 session_id PIC X(16) GLOBAL. *+ * 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. *- 01 receive_ctl_txt_count PIC S9(9) COMP GLOBAL. 01 receive_ctl GLOBAL. 05 receive_ctl_txt OCCURS 5 INDEXED BY receive_ctl_txt_index. 10 receive_ctl_txt_severity PIC X. 10 receive_ctl_txt_source PIC X. 10 receive_ctl_txt_value PIC XXX. 01 receive_ctl_txt_string REDEFINES receive_ctl GLOBAL. 05 FILLER PIC X(25). *+ * 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. * This program doesn't treat it as an array, but as a string since it only * uses the first position in the array. *- 01 send_ctl_txt_ct PIC S9(9) COMP GLOBAL. 01 send_ctl_txt PIC X(25) GLOBAL. *+ * Records passed to DECforms and/or the data file. * * 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. *- 01 account GLOBAL. 05 account_number PIC 9(9) COMP. 05 date_established PIC X(8). 05 zip_code PIC 9(9) COMP. 05 last_name PIC X(20). 05 first_name PIC X(15). 05 middle_name PIC X(15). 05 street PIC X(30). 05 city PIC X(20). 05 state PIC X(2). 05 home_phone PIC 9(10). 05 work_phone PIC 9(10). 05 password PIC X(12). 05 account_pad PIC X(2). *+ * The account register and related variables * * 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. *- 01 reg_size PIC 9999 COMP VALUE 30 GLOBAL. 01 register GLOBAL. 03 number_entries_used PIC S9(9) COMP. 03 reg_items OCCURS 30 TIMES. 05 reg_check_num PIC 9(9) COMP. 05 reg_date PIC X(8). 05 reg_amount PIC 9(9) COMP. 05 reg_balance PIC 9(9) COMP. 05 reg_mem PIC X(35). 05 reg_tax_ded PIC X. * 01 last_check_num PIC 9(9) COMP GLOBAL. 01 checking_balance PIC 9(9) COMP GLOBAL. 01 savings_balance PIC 9(9) COMP GLOBAL. *+ * Miscellaneous *- 01 forms_status PIC S9(9) COMP GLOBAL. 01 form_file PIC X(37) VALUE "FORMS$EXAMPLES:forms$checking_form". 01 device_name PIC X(25) VALUE "FORMS$DEFAULT_DEVICE:". 01 no_form_name PIC S9(9) COMP VALUE 0 GLOBAL. 01 one_record PIC S9(9) COMP VALUE 1 GLOBAL. 01 no_send_ctl_txt_string PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_send_ctl_txt_count PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_receive_ctl_txt_string PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_receive_ctl_txt_count PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_timeout PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_parent_request_id PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_request_options PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_shadow_record PIC S9(9) COMP VALUE 0 GLOBAL. *+ * 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. *- 01 choice GLOBAL. 03 operator_choice PIC S9(9) COMP. 03 amount PIC S9(9) COMP. 03 current_date PIC X(8). 03 memo PIC X(35). 03 choice_pad PIC X. 01 item_list. 02 item_list_entry OCCURS 2. 03 item_length PIC S9(4) COMP. 03 item_code PIC S9(4) COMP. 03 buff_addr USAGE IS POINTER. 03 addr_length_returned USAGE IS POINTER. 01 print_file_name PIC X(31) VALUE 'SYS$SCRATCH:FORMS$CHECKING_FORM'. 01 print_file_name_addr USAGE IS POINTER VALUE IS REFERENCE print_file_name. / PROCEDURE DIVISION. 0. DISPLAY "COBOL 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 -- we have to set the two words to zero the make the * long word zero. MOVE 31 TO item_length OF item_list(1). MOVE forms$k_printfile TO item_code OF item_list(1). MOVE print_file_name_addr TO buff_addr OF item_list(1). MOVE ZERO TO item_length OF item_list(2). MOVE ZERO TO item_code OF item_list(2). *+ * Initialize the DECforms form & check for errors * Note that the "no_" trailing parameters can be left off *- CALL "forms$enable" USING BY VALUE forms$ar_form_table BY DESCRIPTOR device_name session_id form_file BY VALUE no_form_name no_receive_ctl_txt_string no_receive_ctl_txt_count no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id BY REFERENCE item_list GIVING forms_status. CALL "check_forms_status" USING forms_status. *+ * Initialize account information *- CALL "initialize_account". *+ * Process all operator requests *- CALL "do_operator_choice". *+ * Clean up, Print ending message on console, leave. *- CALL "forms$disable" USING BY DESCRIPTOR session_id GIVING forms_status. CALL "check_forms_status" USING forms_status. DISPLAY "COBOL DECforms Sample Checking Account Application ending.". STOP RUN. / IDENTIFICATION DIVISION. * ****************** PROGRAM-ID. check_forms_status COMMON. * ****************** *+ * If parameter is success, return; else print error message and stop. *- DATA DIVISION. WORKING-STORAGE SECTION. LINKAGE SECTION. 01 forms_status PIC S9(9) COMP. PROCEDURE DIVISION USING forms_status. 0. IF forms_status IS FAILURE THEN CALL "LIB$SIGNAL" USING BY VALUE forms_status STOP RUN END-IF. END PROGRAM check_forms_status. / IDENTIFICATION DIVISION. * ******************* PROGRAM-ID. initialize_account. * ******************* *+ * Read from data file into internal variables. *- ENVIRONMENT DIVISION. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT SAMP-FILE ASSIGN TO "FORMS$EXAMPLES:". DATA DIVISION. FILE SECTION. FD SAMP-FILE GLOBAL LABEL RECORDS ARE STANDARD VALUE OF ID IS "FORMS$EXAMPLES:FORMS$CHECKING_DATA". 01 temp-account. 05 account_number PIC 9(9) COMP. 05 date_established PIC X(8). 05 zip_code PIC 9(9) COMP. 05 last_name PIC X(20). 05 first_name PIC X(15). 05 middle_name PIC X(15). 05 street PIC X(30). 05 city PIC X(20). 05 state PIC X(2). 05 home_phone PIC 9(10). 05 work_phone PIC 9(10). 05 password PIC X(12). 05 account_pad PIC X(2). 01 temp-savings PIC S9(9) COMP. 01 temp-reg-item. 05 reg_check_num PIC 9(9) COMP. 05 reg_date PIC X(8). 05 reg_amount PIC 9(9) COMP. 05 reg_balance PIC 9(9) COMP. 05 reg_mem PIC X(35). 05 reg_tax_ded PIC X. WORKING-STORAGE SECTION. 01 eof-flag PIC S9(9) COMP. 01 remaining PIC S9(9) COMP. PROCEDURE DIVISION. 0. *+ * Open file. The first record in the file is the account data. * The second is the savings balance. *- OPEN INPUT samp-file. READ samp-file AT END DISPLAY "Error on FORMS$CHECKING_DATA.DAT" STOP RUN. MOVE temp-account TO account. READ samp-file AT END DISPLAY "Error on FORMS$CHECKING_DATA.DAT" STOP RUN. MOVE temp-savings TO savings-balance. *+ * The 3rd thru n records are the register data. * The last record has the current checking_balance data. * 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. MOVE ZERO TO number_entries_used. SET eof-flag TO FAILURE. PERFORM WITH TEST AFTER VARYING number_entries_used FROM 1 BY 1 UNTIL eof-flag IS SUCCESS OR number_entries_used NOT < reg_size READ samp-file AT END SET eof-flag TO SUCCESS END-READ IF eof-flag IS FAILURE THEN MOVE temp-reg-item TO reg_items(number_entries_used) IF reg_check_num NOT EQUAL ZERO THEN MOVE reg_check_num TO last_check_num END-IF END-IF END-PERFORM. *+ * NOTE: We now explicitly initialize the remaining reg_mem and reg_date fields * because we send the entire register and we shouldn't send binary * zeros as character strings -- if they were to be displayed it * would be confusing. *- PERFORM WITH TEST BEFORE VARYING remaining FROM number_entries_used BY 1 UNTIL remaining > reg_size MOVE "19850315" TO reg_date OF reg_items(remaining) MOVE SPACES TO reg_mem OF reg_items(remaining) END-PERFORM. SUBTRACT 1 FROM number_entries_used. *+ * Take balance from last record read. *- IF reg_balance NOT EQUAL ZERO THEN MOVE reg_balance TO checking_balance END-IF. *+ * Check for data file in error. *- EVALUATE TRUE WHEN number_entries_used < 1 STOP "Data error on NUMBER_ENTRIES_USED" WHEN number_entries_used = reg_size DISPLAY "Data file too big, using only part" WHEN last_check_num = ZERO STOP "Data error on LAST_CHECK_NUM" WHEN checking_balance = ZERO STOP "Data error on CHECKING_BALANCE" END-EVALUATE. CLOSE samp-file. *+ * Update check number to be the next check number to use. *- ADD 1 TO last_check_num. *+ * Tell the form all the account-derived information: * The account record * The current balance, next available check number, register status * Blank parameter means initial write. *- The edited version of name and address CALL "forms$send" USING BY DESCRIPTOR session_id "account" BY REFERENCE one_record BY VALUE no_receive_ctl_txt_string no_receive_ctl_txt_count no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id no_request_options BY DESCRIPTOR account BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. CALL "update_form". CALL "name_and_address". EXIT PROGRAM. END PROGRAM initialize_account. / IDENTIFICATION DIVISION. * **************** PROGRAM-ID. name_and_address COMMON. * **************** *+ * Format the account data name and address and send to the form *- DATA DIVISION. WORKING-STORAGE SECTION. 01 trim_length_first PIC 9(4) COMP. 01 trim_length_city PIC 9(4) COMP. 01 unused_string PIC X(80). 01 string_zip PIC 9(5). *+ * 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. *- 01 mail_format. 02 mail_name PIC X(39). 02 mail_csz PIC X(30). PROCEDURE DIVISION. 0. *+ * 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. * Put only middle initial in, not full middle name. *- CALL "str$trim" USING BY DESCRIPTOR unused_string first_name BY REFERENCE trim_length_first. STRING first_name(1:trim_length_first) " " middle_name(1:1) ". " last_name DELIMITED BY SIZE INTO mail_name. CALL "str$trim" USING BY DESCRIPTOR unused_string BY DESCRIPTOR city BY REFERENCE trim_length_city. MOVE zip_code TO string_zip. STRING city(1:trim_length_city) ", " state " " string_zip DELIMITED BY SIZE INTO mail_csz. CALL "forms$send" USING BY DESCRIPTOR session_id "mail_format" BY REFERENCE one_record BY VALUE no_receive_ctl_txt_string no_receive_ctl_txt_count no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id no_request_options BY DESCRIPTOR mail_format BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. EXIT PROGRAM. END PROGRAM name_and_address. / IDENTIFICATION DIVISION. * *********** PROGRAM-ID. update_form COMMON. * *********** *+ * 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 binary zero, else 1. *- DATA DIVISION. WORKING-STORAGE SECTION. *+ * UPDATE_REC is sent whenever the register is changed. This means * the account balance and the check number might also change. * It is used only by a SEND from the program. *- 01 update_rec. 05 update_checking_balance PIC 9(9) COMP. 05 update_savings_balance PIC 9(9) COMP. 05 check_number PIC 9(4) COMP. 05 room_in_reg PIC X. 05 update_pad PIC X. PROCEDURE DIVISION. 0. MOVE checking_balance TO update_checking_balance. MOVE savings_balance TO update_savings_balance. MOVE last_check_num TO check_number. IF number_entries_used < reg_size THEN MOVE HIGH-VALUE TO room_in_reg ELSE MOVE LOW-VALUE TO room_in_reg END-IF. CALL "forms$send" USING BY DESCRIPTOR session_id "update" BY REFERENCE one_record BY VALUE no_receive_ctl_txt_string no_receive_ctl_txt_count no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id no_request_options BY DESCRIPTOR update_rec BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. EXIT PROGRAM. END PROGRAM update_form. / IDENTIFICATION DIVISION. * ************** PROGRAM-ID. quit_requested COMMON. * ************** *+ * Check the receive control text in the COMMON area. * Return SUCCESS if operator requested the quit option (string QUT), * return FAILURE otherwise. *- DATA DIVISION. WORKING-STORAGE SECTION. 01 return_value PIC S9(9) COMP. PROCEDURE DIVISION GIVING return_value. 0. *+ * Search the receive_ctl_txt array, but only receive_ctl_txt_count entries. *- SET receive_ctl_txt_index TO 1. SET return_value TO FAILURE. SEARCH receive_ctl_txt WHEN receive_ctl_txt_index > receive_ctl_txt_count NEXT SENTENCE WHEN receive_ctl_txt_value (receive_ctl_txt_index) = "QUT" SET return_value TO SUCCESS. EXIT PROGRAM. END PROGRAM quit_requested. / IDENTIFICATION DIVISION. * ******************* PROGRAM-ID. 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 *- PROCEDURE DIVISION. 0. PERFORM WITH TEST AFTER, UNTIL operator_choice = 1 CALL "forms$receive" USING BY DESCRIPTOR session_id "choose" BY REFERENCE one_record BY VALUE no_receive_ctl_txt_string no_receive_ctl_txt_count no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id no_request_options BY DESCRIPTOR choice BY VALUE no_shadow_record GIVING forms_status CALL "check_forms_status" USING forms_status EVALUATE operator_choice WHEN 2 THROUGH 6 CALL "account_transfer" WHEN 7 CALL "view_register" WHEN 8 CALL "view_account_data" END-EVALUATE END-PERFORM. EXIT PROGRAM. END PROGRAM do_operator_choice. / IDENTIFICATION DIVISION. * *********** PROGRAM-ID. account_transfer COMMON. * *********** *+ * 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. * *- DATA DIVISION. WORKING-STORAGE SECTION. 01 check_number PIC 9(4) COMP. 01 no_tax_deduction PIC X VALUE LOW-VALUE. PROCEDURE DIVISION. 0. *+ * 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. *- MOVE ZERO TO check_number. EVALUATE operator-choice *+ * Write a check. Balance and generate a new check number. *- WHEN 2 MOVE last_check_num TO check_number ADD 1 TO last_check_num COMPUTE amount OF choice = - amount OF choice *+ * Cash withdrawal. *- WHEN 4 COMPUTE amount OF choice = - amount OF choice *+ * Transfer from checking to savings *- WHEN 5 ADD amount OF choice TO savings_balance COMPUTE amount OF choice = - amount OF choice *+ * Transfer from savings to checking *- WHEN 6 SUBTRACT amount OF choice FROM savings_balance END-EVALUATE. *+ * Now update the checking account *- ADD amount OF choice TO checking_balance. CALL "add_to_register" USING check_number current_date OF choice memo OF choice amount OF choice checking_balance no_tax_deduction. CALL "update_form". EXIT PROGRAM. END PROGRAM account_transfer. / IDENTIFICATION DIVISION. * *************** PROGRAM-ID. add_to_register COMMON. * *************** *+ * Add an entry to the check register * Assume that there is room in the register. *- DATA DIVISION. WORKING-STORAGE SECTION. LINKAGE SECTION. 01 date_par PIC X(8). 01 mem PIC X(35). 01 chk_num PIC 9(9) COMP. 01 amount PIC 9(9) COMP. 01 balance PIC 9(9) COMP. 01 tax_ded PIC X. PROCEDURE DIVISION USING chk_num date_par mem amount balance tax_ded. 0. ADD 1 TO number_entries_used. MOVE date_par TO reg_date OF reg_items(number_entries_used). MOVE chk_num TO reg_check_num OF reg_items(number_entries_used). MOVE amount TO reg_amount OF reg_items(number_entries_used). MOVE balance TO reg_balance OF reg_items(number_entries_used). MOVE mem TO reg_mem OF reg_items(number_entries_used). MOVE tax_ded TO reg_tax_ded OF reg_items(number_entries_used). EXIT PROGRAM. END PROGRAM add_to_register. / IDENTIFICATION DIVISION. * ************* PROGRAM-ID. view_register COMMON. * ************* *+ * 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 *- DATA DIVISION. WORKING-STORAGE SECTION. PROCEDURE DIVISION. 0. *+ * Transceive the record (send it and ask to get it back) *- CALL "forms$transceive" USING BY DESCRIPTOR session_id BY DESCRIPTOR "register_record" BY REFERENCE one_record BY DESCRIPTOR "register_record" BY REFERENCE one_record BY VALUE no_receive_ctl_txt_string no_receive_ctl_txt_count no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id no_request_options BY DESCRIPTOR register BY VALUE no_shadow_record BY DESCRIPTOR register BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. END PROGRAM view_register. / IDENTIFICATION DIVISION. * ***************** PROGRAM-ID. view_account_data COMMON. * ***************** *+ * Get new information for current account or quit from operator. * If it's quit, then just return to menu processing. *- DATA DIVISION. WORKING-STORAGE SECTION. 01 quit_was_requested PIC S9(9) COMP. 01 account_temp. 05 account_number PIC 9(9) COMP. 05 date_established PIC X(8). 05 zip_code PIC 9(9) COMP. 05 last_name PIC X(20). 05 first_name PIC X(15). 05 middle_name PIC X(15). 05 street PIC X(30). 05 city PIC X(20). 05 state PIC X(2). 05 home_phone PIC 9(10). 05 work_phone PIC 9(10). 05 password PIC X(12). 05 account_pad PIC X(2). PROCEDURE DIVISION. 0. * Note that the Forms Manager always returns a record, even when the * operator cancels. That record might have junk in it, so we we * protect ourselves by providing a dummy record until we're sure the * data returned is okay. CALL "forms$receive" USING BY DESCRIPTOR session_id "account" BY REFERENCE one_record BY DESCRIPTOR receive_ctl_txt_string BY REFERENCE receive_ctl_txt_count BY VALUE no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id no_request_options BY DESCRIPTOR account_temp BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. CALL "quit_requested" GIVING quit_was_requested. IF quit_was_requested IS SUCCESS THEN *+ * Update the form with the old name and city information, just in * case the operator changed some of the form information before quitting *- CALL "forms$send" USING BY DESCRIPTOR session_id "account" BY REFERENCE one_record BY VALUE no_receive_ctl_txt_string no_receive_ctl_txt_count no_send_ctl_txt_string no_send_ctl_txt_count no_timeout no_parent_request_id no_request_options BY DESCRIPTOR account BY VALUE no_shadow_record GIVING forms_status CALL "check_forms_status" USING forms_status ELSE *+ * 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. *- MOVE account_temp TO account CALL "name_and_address" END-IF. EXIT PROGRAM. END PROGRAM view_account_data. END PROGRAM forms$checking_cobol. IDENTIFICATION DIVISION. * ************************** PROGRAM-ID. forms_checking_getsysinfo_. * ************************** DATA DIVISION. WORKING-STORAGE SECTION. 01 user_length PIC 9(9) COMP. 01 version_length PIC 9(9) COMP. 01 vms_version PIC X(20). 01 null_param PIC S9(9) COMP VALUE 0. 01 jpi$_username PIC S9(9) COMP VALUE 514. 01 syi$_version PIC S9(9) COMP VALUE 4096. 01 username PIC X(30). 01 version PIC X(30). LINKAGE SECTION. 01 username_rec. 02 first_part PIC S9(9) USAGE COMP. 02 ptr USAGE POINTER. 01 version_rec. 02 first_part PIC S9(9) USAGE COMP. 02 ptr USAGE POINTER. PROCEDURE DIVISION USING username_rec version_rec. 0. CALL "lib$getjpi" USING BY REFERENCE JPI$_USERNAME BY VALUE null_param BY VALUE null_param BY VALUE null_param BY DESCRIPTOR username. CALL "lib$getsyi" USING BY REFERENCE SYI$_VERSION BY VALUE 0 BY DESCRIPTOR vms_version BY REFERENCE version_length. STRING "VMS version: " vms_version(1:version_length) DELIMITED BY SIZE INTO version. CALL "lib$cvt_dx_dx" USING BY DESCRIPTOR username BY REFERENCE username_rec. CALL "lib$cvt_dx_dx" USING BY DESCRIPTOR version BY REFERENCE version_rec. END PROGRAM forms_checking_getsysinfo_.