PROGRAM forms$checking_fortran C COPYRIGHT (c) 1986, 1987, 1988, 1989, 1990, 1991 BY C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. C C THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED C ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE C INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER C COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY C OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY C TRANSFERRED. C C THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE C AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT C CORPORATION. C C DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS C SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. C C PROGRAM DESCRIPTION: C C This is the Sample Checking Application provided with the C DECforms V2.0 product. C C AUTHORS: C C Digital Equipment Corporation C C CREATION DATE: Jan-1986 C C MODIFIED: Jan-1991 C Sep-1993 C C C -------------- VMS - Character Cell and Motif Instructions ------------- C C If your system manager copied the Sample from the DECforms kit onto your C system, you can run the DECforms Sample Checking Application by doing the C following: C C To run the Character Cell version of the Sample Checking Application: C C $ DEFINE FORMS$DEFAULT_DEVICE SYS$INPUT C $ RUN FORMS$EXAMPLES:FORMS$CHECKING C C To run the Motif version of the Sample Checking Application: C C $ SET DISPLAY/CREATE/NODE=NODE_NAME C $ DEFINE FORMS$DEFAULT_DEVICE DECW$DISPLAY C $ RUN FORMS$EXAMPLES:FORMS$CHECKING C C Any printing you do while running the checking sample will end up in your C SYS$SCRATCH directory (usually your login directory). C C The DECforms Sample Checking Application in the FORTRAN language consists C of five files: C C FORMS$CHECKING_DATA.DAT A binary data file for reading C by the program C FORMS$CHECKING_FORM.IFDL The IFDL source form C FORMS$CHECKING_FORTRAN.FOR The application itself C FORMS_CHECKING_COMMON.F An include file containing C common definitions for C all the FORTRAN subroutines C FORMS_CHECKING_GETSYSINFO.F An include file containing C subroutines that perform C system specific processing C FORMSDEF.F An include file with DECforms C definitions C C The first five files are copied from the DECforms kit to the FORMS$EXAMPLES C directory and the last is put into SYS$LIBRARY. Putting the files in C FORMS$EXAMPLES is an installation option; talk to your system manager if they C aren't there. The FORMSDEF.F file is put into SYS$LIBRARY unconditionally, C so that you should be able to use it from all your FORTRAN programs using C DECforms. C C In addition, the binary form file, FORMS$CHECKING_FORM.FORM is also in the C FORMS$EXAMPLES directory. C C A working version of the DECforms Sample Checking Application in the FORTRAN C language can be created in your own directory from these sources by doing C the following: C C $! Set the default to your own directory: C $ SET DEFAULT yourdirectory C $ C $! Copy all the sources files from FORMS$EXAMPLES to your own directory: C $ COPY FORMS$EXAMPLES:FORMS$CHECKING_FORTRAN.FOR, - C FORMS_CHECKING_COMMON.F, - C FORMS_CHECKING_GETSYSINFO.F, - C FORMS$CHECKING_FORM.IFDL [] C $ C $! Compile the FORTRAN source: C $ FORTRAN FORMS$CHECKING_FORTRAN.FOR C $ C $! Translate the IFDL source form: C $ FORMS TRANSLATE FORMS$CHECKING_FORM.IFDL C $ C $! Extract a vector module from the binary form: C $ FORMS EXTRACT OBJECT/PORTABLE FORMS$CHECKING_FORM.FORM C $ C $! Link the FORTRAN object, the forms vector and the shareable image C $! containing FORTRAN Binding entry points: C $ LINK FORMS$CHECKING_FORTRAN.OBJ, C FORMS$CHECKING_FORM.OBJ, - C SYS$INPUT/OPTIONS C SYS$LIBRARY:FORMS$PORTABLE_API.EXE/SHARE C C You can then run the executable in your own directory by doing the C following: C C To run the Character Cell executable: C C $ DEFINE FORMS$DEFAULT_DEVICE SYS$INPUT C $ RUN FORMS$CHECKING_FORTRAN C C To run the Motif executable: C C $ SET DISPLAY/CREATE/NODE=NODE_NAME C $ DEFINE FORMS$DEFAULT_DEVICE DECW$DISPLAY C $ RUN FORMS$CHECKING_FORTRAN C C C Note that the program expects the form file as well as the data file to C be in the FORMS$EXAMPLES directory, or in the current directory. By C copying these files to your local directory you can change the form if C you wish and retranslate it. C C C VAX FORTRAN NOTES C ----------------- C C Note on use of DECforms from FORTRAN: DECforms requires a structure which C contains a pointer to a record as well as it's length. This is accomplished C in FORTRAN using the method shown in this program. C C One difficulty with this is that you have to count the number of bytes in C the record yourself if your FORTRAN is an earlier version than VAX FORTRAN C V5. With VAX FORTRAN V5 you have a new builtin function, SIZEOF, which C counts the bytes for you. In this program, lines marked "C-V5->" show how C to use SIZEOF if you have VAX FORTRAN V5. The pre-V5 method (which is C used in this program) will always work (even with V5) but it requires byte C counting. Use of SIZEOF is quite convenient, especially when you are C copying records from someplace else (text library, dictionary). C C Beginning of FORTRAN main program IMPLICIT NONE INCLUDE 'forms_checking_common.f' INTEGER sample_checking_account EXTERNAL sample_checking_account C C Define data and form file names C CHARACTER*200 form_file_name CHARACTER*200 sample_data_name C Option list. Used to pass special options to forms requests (calls) RECORD /forms_request_options/ enable_request_options(3) C Print startup message on console PRINT *, 1 'FORTRAN DECforms Sample Checking Account Application starting.' C Build the data and form file names CALL forms_checking_getdir( form_file_name, sample_data_name) C Set up printing to go to the operator's scratch directory. This involves C passing a request_options parameter in the enable request. enable_request_options(1).option = forms_c_opt_print enable_request_options(1).print_file_name = %LOC(print_file_name) enable_request_options(1).print_file_name_length = LEN(print_file_name) enable_request_options(2).option = forms_c_opt_form enable_request_options(2).form_object = %LOC(sample_checking_account) enable_request_options(3).option = forms_c_opt_end C Initialize the DECforms form & check for errors forms_status = forms_enable_for( session_id, ! Returned from forms$ 1 , ! Device name 2 form_file_name, ! Name of form file 3 form_name_string, ! Name of form 4 enable_request_options) ! Request options list CALL check_forms_status( forms_status ) C Initialize account information CALL initialize_account (sample_data_name) C Process all operator requests CALL do_operator_choice C Clean up, Print ending message on console, leave. CALL exit_application( exit_success ) END SUBROUTINE check_forms_status( status ) C Check the parameter for success. If not success, print the error and stop. IMPLICIT NONE INTEGER status CHARACTER*257 msg_text CHARACTER*256 msg INCLUDE 'forms_checking_common.f' INTEGER forms_errormsg_for EXTERNAL forms_errormsg_for IF ((status .NE. forms_s_normal) .AND. 1 (status .NE. forms_s_return_immed) .AND. 1 (status .NE. forms_s_converr) ) THEN C Null terminate the message text string. Then call a translation C routine to convert FIMS error number into message text. msg = ' ' msg_text = msg // char(0) CALL forms_errormsg_for (status, msg_text) PRINT *, 'Forms Error: ', status, msg_text CALL exit_application( exit_failure ) ENDIF END SUBROUTINE exit_application( status ) C Clean up, Print ending message on console, leave. IMPLICIT NONE INTEGER status INCLUDE 'forms_checking_common.f' forms_status = forms_disable_for( session_id , 0 ) PRINT *, 'FORTRAN DECforms Sample Checking Account Application ending.' STOP END SUBROUTINE initialize_account (sample_data_name) C Read from file FORMS$CHECKING_DATA.DAT into internal variables. C Write the account information to the form. C Reformat some account info and send that to the form. IMPLICIT NONE INCLUDE 'forms_checking_common.f' CHARACTER*200 sample_data_name INTEGER j C Open file, get account data and savings balance. OPEN(UNIT=5, 1 FILE=sample_data_name, 2 STATUS='OLD', 3 READONLY, 4 ACCESS='SEQUENTIAL', 5 FORM='UNFORMATTED', 6 RECORDTYPE='VARIABLE') READ (UNIT=5, END=100) account READ (UNIT=5, END=100) savings_balance C Read the remaining records into the register, counting them. C The last register record has the checking balance, and some record has the C last check number used (not necessarily the last record). last_check_num = 0 register.number_entries_used = 0 DO WHILE (register.number_entries_used .LT. reg_size) READ(UNIT=5,END=100)register.entry(register.number_entries_used+1) register.number_entries_used = register.number_entries_used + 1 IF (register.entry(register.number_entries_used).reg_check_num 1 .NE. 0) THEN last_check_num = 1 register.entry(register.number_entries_used).reg_check_num ENDIF ENDDO C Reached here without hitting end of file, reading exactly reg_size C records. There's something wrong with the data file. PRINT *,'Data file probably too big, only using ',REG_SIZE,' records.' C Reach here from above or as result of end of file-- C last record tried didn't read. C Check for data file in error. 100 CLOSE(5) IF (register.number_entries_used .EQ. 0) THEN PRINT *,'Data file in error, no register entries read' CALL exit_application( exit_failure ) ENDIF C Initialize the remaining date fields because we send the whole register C to the form, and we really shouldn't send illegal strings. j= register.number_entries_used DO WHILE (j .LE. reg_size) register.entry(j).reg_date = '19850315' j = j +1 ENDDO C Take checking balance from last record read. C Update check nuamber to be the next check number to use. checking_balance = 1 register.entry(register.number_entries_used).reg_balance last_check_num = last_check_num + 1 C Initialize the descriptor with ACCOUNT structure info C-V5-> See comments on SIZEOF above (on about page 4) record_data.data_length = account_size ! for pre-V5 FORTRAN C-V5-> record_data.data_length = SIZEOF(account) ! for VAX FORTRAN V5 record_data.data_record = %LOC( account ) record_data.shadow_record = 0 record_data.shadow_length = 0 C Tell the form all the account-derived information: C The account record C The balances, next available check number, register status C The edited version of name and address forms_status = forms_send_for( session_id, ! session id 1 'account', ! form record name 2 record_data, ! form record description 3 0) ! request options list CALL check_forms_status( forms_status ) CALL update_form CALL name_and_address RETURN END SUBROUTINE string_unpad_length ( string, max_len, length ) C C Find the last non-blank character in a character string C "max_len" is the maximum length. INTEGER max_len, length CHARACTER*(*) string INTEGER n DO n = max_len, 1, -1 IF (string(n:n) .NE. ' ') THEN length = n RETURN ENDIF ENDDO length = 1 !Minimum string is still one character... RETURN END SUBROUTINE name_and_address C Format the account data name and address and send to the form IMPLICIT NONE INCLUDE 'forms_checking_common.f' INTEGER trim_length_first INTEGER trim_length_city CHARACTER string_zip*5 C MAIL_FORMAT is a reformatting of the name and last address line C as they would appear on a mailing label, with extra spaces C squeezed out. This record is used only by a SEND from the program. STRUCTURE /mail_format/ UNION MAP CHARACTER*39 mail_name CHARACTER*30 mail_csz END MAP MAP CHARACTER*69 string END MAP END UNION END STRUCTURE RECORD /mail_format/ mail_format C-V5-> This byte counting with "INTEGER & PARAMETER mail_format_size" C-V5-> is unnecessary with FORTRAN V5. See the comments on the C-V5-> use of SIZEOF above, on about page 4. INTEGER mail_format_size PARAMETER (mail_format_size=69) C Need to trim trailing blanks - find out how C long the trimmed strings are, then do explicit concatenations and move. C Put only middle initial in, not full middle name. CALL string_unpad_length (account.first_name,15,trim_length_first) CALL string_unpad_length (account.city, 20, trim_length_city) C Format the name and address. mail_format.mail_name = account.first_name(1:trim_length_first) // 1 ' ' // account.middle_name(1:1) // 2 '. ' // account.last_name write( string_zip, '(I5.5)') account.zip_code mail_format.mail_csz = account.city(1:trim_length_city) // ', ' // 1 account.state // ' ' // string_zip C Initialize the descriptor with MAIL_FORMAT info C-V5-> See comments on SIZEOF above (on about page 4) record_data.data_length = mail_format_size ! for pre-V5 FORTRAN C-V5-> record_data.data_length = SIZEOF(mail_format) ! for VAX FORTRAN V5 record_data.data_record = %LOC( mail_format ) record_data.shadow_record = 0 record_data.shadow_length = 0 C Send the mail_format record forms_status = forms_send_for( session_id, ! session id 1 'mail_format', ! form record 2 record_data, ! info sent to form 3 0) ! request options list CALL check_forms_status( forms_status ) RETURN END SUBROUTINE update_form C Update the balances, next check number, and room_in_reg flag in the form. C If there's no room for more entries in the register, then C the room_in_reg flag is sent as zero(false), else true(all 1's in Fortran). IMPLICIT NONE INCLUDE 'forms_checking_common.f' RECORD /update/ update update.checking_balance = checking_balance update.savings_balance = savings_balance update.check_number = last_check_num update.room_in_reg = register.number_entries_used .LT. reg_size C Initialize the descriptor with UPDATE info C-V5-> See comments on SIZEOF above (on about page 4) record_data.data_length = update_size ! for pre-V5 FORTRAN C-V5-> record_data.data_length = SIZEOF(update) ! for VAX FORTRAN V5 record_data.data_record = %LOC( update ) record_data.shadow_record = 0 record_data.shadow_length = 0 C Send the update record forms_status = forms_send_for( session_id, ! session id 1 'update', ! form record 2 record_data, ! info sent to form 3 0 ) ! request options list CALL check_forms_status( forms_status ) RETURN END LOGICAL FUNCTION quit_requested() C Check the receive control text in the COMMON area. C Return .TRUE. if operator requested QUIT, return .FALSE. otherwise. IMPLICIT NONE INCLUDE 'forms_checking_common.f' INTEGER i C Assume false till proven otherwise. quit_requested = .FALSE. DO i=1, receive_ctl_txt_ct IF (receive_ctl_txt(i)(3:5) .EQ. 'QUT') quit_requested = .TRUE. ENDDO END SUBROUTINE do_operator_choice C Accept inputs from the operator and dispatch to the appropriate C routine. Repeat until option 1 (exit) is chosen. The validation C in the form guarantees that we get back only inputs 1-8. C Options are: C 1 => Exit C 2 => Write check (comes back from form only if there's room in the reg) C 3 => Make deposit (") C 4 => Cash withdrawal (") C 5 => Transfer money from checking to savings (") C 6 => Transfer money from savings to checking (") C 7 => View register C 8 => View account data IMPLICIT NONE INCLUDE 'forms_checking_common.f' choice.operator_choice = 0 DO WHILE (choice.operator_choice .NE. 1) C-V5-> See comments on SIZEOF above (on about page 4) record_data.data_length = choice_record_size ! for pre-V5 FORTRAN C-V5-> record_data.data_length = SIZEOF(choice) ! for VAX FORTRAN V5 record_data.data_record = %LOC(choice) record_data.shadow_record = 0 record_data.shadow_length = 0 C Get the choice record forms_status = forms_receive_for( session_id, ! session id 1 'choose', ! form record 2 record_data, ! info sent to form 3 0) ! request option list CALL check_forms_status( forms_status ) GOTO (119,120,120,120,120,120,170,180) choice.operator_choice C 119 RETURN C C 120 CALL account_transfer GOTO 100 C 170 CALL view_register GOTO 100 C 180 CALL view_account_data 100 ENDDO RETURN END SUBROUTINE account_transfer C The transaction is a checking account transfer, found in global CHOICE: C 2 => Write check C 3 => Make deposit C 4 => Cash withdrawal C 5 => Transfer money from checking to savings C 6 => Transfer money from savings to checking C C Perform the indicated arithmetic on the checking account balance and enter C the transaction into the register. C The amount in the choice record is always positive, even for withdrawals C so that arithmetic must be done with the proper sign. C The memo in the choice record is set to the appropriate string so nothing C special has to be done with it. C In the case of a check, a new check number is generated. C C Note that validation in the form guarantees that the amount of the transfer C is always greater than zero and less than or equal to the respective C balance. C Form validation also guarantees that none of these options is chosen if no C room is left in the register. IMPLICIT NONE INCLUDE 'forms_checking_common.f' INTEGER check_number C Update balances in memory. C The general idea is to do the specific thing needed for each choice and C then always do the checking account update. This also changes the sign C for checking withdrawals so that the register is updated properly. check_number = 0 GOTO (100,120,130,140,150,160) choice.operator_choice C Write a check (120) or cash withdrawal (140). C Generate a new check number for check. 120 check_number = last_check_num last_check_num = last_check_num + 1 140 choice.amount = - choice.amount GOTO 200 C Deposit into checking 130 GOTO 200 C Transfer from checking to savings 150 savings_balance = savings_balance + choice.amount choice.amount = - choice.amount GOTO 200 C Transfer from savings to checking 160 savings_balance = savings_balance - choice.amount 200 CONTINUE C Now update the checking account checking_balance = checking_balance + choice.amount C Transfer form values to new register item. CALL add_to_register( 1 check_number, !reg_chk_num 2 choice.current_date, !reg_date 3 choice.memo, !reg_memo 4 choice.amount, !reg_amount 5 checking_balance, !reg_balance 6 .FALSE.) !reg_tax_ded C Update the form with new values. CALL update_form 100 RETURN END SUBROUTINE add_to_register( chk_num, date, mem, amount, 1 new_balance, tax_ded) C Add an entry to the register. C Assume that there is room in the register. IMPLICIT NONE INCLUDE 'forms_checking_common.f' INTEGER*2 chk_num CHARACTER*8 date CHARACTER*35 mem INTEGER amount INTEGER new_balance LOGICAL*1 tax_ded 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 = new_balance register.entry(register.number_entries_used).reg_tax_ded = tax_ded END SUBROUTINE view_register C View the check register, with the option of changing the tax-ded status. C For the sake of a simple application (the form doesn't really care), C we're dealing only with a fixed size register. We send the entire thing C to the form and let it worry about scrolling or whatever. We get the entire C register back, again for simplicity -- we really should get back just the C tax deduction array, but that's more work and this is just a sample. C C Part of the record sent to the form is number_entries_used, which tells the C number of meaningful entries, that is, how many are not blank. C C There are two possible returns from the form: C 1. No control text => TRANSMIT pressed: update has already happened C because the record came back; return to menu C 2. QUT control text => QUIT pressed: No update, return to menu C In both cases, the routine doesn't really have to do anything C IMPLICIT NONE INCLUDE 'forms_checking_common.f' C Option list. Used to pass special options to forms requests (calls) RECORD /forms_request_options/ request_options(2) C Initialize the descriptor with REGISTER info C-V5-> See comments on SIZEOF above (on about page 4) record_data.data_length = register_record_size ! for pre-V5 FORTRAN C-V5-> record_data.data_length = SIZEOF(register) ! for VAX FORTRAN V5 record_data.data_record = %LOC(register) record_data.shadow_record = 0 record_data.shadow_length = 0 C Set up to receive control text back from the form request_options(1).option = forms_c_opt_receive_control request_options(1).receive_control_text_count=%LOC(receive_ctl_txt_ct) request_options(1).receive_control_text=%LOC(receive_ctl_txt_string) request_options(2).option = forms_c_opt_end C Transceive the record (send it and ask to get it back) forms_status = forms_transceive_for( session_id, ! session id 1 'register_record', ! send record name 2 record_data, ! the send record 3 'register_record', ! Receive record name 4 record_data, ! the recv record 5 request_options) ! request options list CALL check_forms_status( forms_status ) END SUBROUTINE view_account_data C Let the operator view and change the account data. IMPLICIT NONE INCLUDE 'forms_checking_common.f' LOGICAL quit_requested RECORD /account_str/ account_temp C Option list. Used to pass special options to forms requests (calls) RECORD /forms_request_options/ request_options(2) C Get new information for account record. If termination was quit, C then the operator might have changed a few things that the quit is C supposed to ignore, so send the original account record back to the C form and return to menu processing. C-V5-> See comments on SIZEOF above (on about page 4) record_data.data_length = account_size ! for pre-V5 FORTRAN C-V5-> record_data.data_length = SIZEOF(account_temp) ! for VAX FORTRAN V5 record_data.data_record = %LOC(account_temp) record_data.shadow_record = 0 record_data.shadow_length = 0 C Set up to receive control text back from the form request_options(1).option = forms_c_opt_receive_control request_options(1).receive_control_text_count= %LOC(receive_ctl_txt_ct) request_options(1).receive_control_text= %LOC(receive_ctl_txt_string) request_options(2).option = forms_c_opt_end C Get the record from the form forms_status = forms_receive_for( session_id, ! session id 1 'account', ! form record 2 record_data, ! info from the form 3 request_options) ! request option list CALL check_forms_status( forms_status ) C Now write what we've got, just in case the operator did any temporary changes C that weren't repaired. IF (quit_requested()) THEN C-V5-> See comments on SIZEOF above (on about page 4) record_data.data_length = account_size ! for pre-V5 FORTRAN C-V5-> record_data.data_length = SIZEOF(account) ! for VAX FORTRAN V5 record_data.data_record = %LOC(account) record_data.shadow_record = 0 record_data.shadow_length = 0 forms_status = forms_send_for( session_id, ! session id 1 'account', ! form record 2 record_data, ! info sent to form 3 0) ! request options list ELSE C This is where we would ordinarily update the account on the disk. C We don't do that because this is just a demo. The new information C is available only during this session. C CONTINUE C Update the form with new name and city information. account = account_temp CALL name_and_address ENDIF RETURN END C Include file containing subroutines that perform system specific C processing C INCLUDE 'forms_checking_getsysinfo.f'