HP 3000 Manuals HP 3000 Manuals
FORTRAN 77
$CONTROL list on, tables on
!
! This application collects employee payroll deduction
! transactions and places the edited transactions into
! a file.
!
! For this application: Enter key = edit and file
! transaction;
!
! f8 = exit application;
!
! all other f keys = redo transaction.
!
! Each transaction entered by the operator is subjected to the
! data edits embedded within the input form.
!
! The application continues to collect transactions until either
! the operator signals to exit or a system error is detected.
!
$TITLE ' Main Program'
!***************************************************************!
! !
! Main Program !
! !
!***************************************************************!
!
PROGRAM FTNEXMP
!
IMPLICIT NONE
!
COMMON /COMO1/ COMAREA
COMMON /COM11/ STOP_NOW
COMMON /COM12/ DONE WITH TXNS
COMMON /COM13/ NBR_TXN_COLLECTED
COMMON /COM21/ FIELDINFO
COMMON /COM22/ INFOBUFLEN
COMMON /COM81/ MSGBUF
COMMON /COM82/ MSGBUFLEN
COMMON /COM83/ ERRMSGLEN
COMMON /COM91/ ERROR_LOCATION
!
INTEGER*2 COMAREA(60)
INTEGER*2 STOP_NOW
INTEGER*2 DONE_WITH_TXNS
INTEGER*2 NBR_TXN_COLLECTED
INTEGER*2 FIELDINFO(37)
INTEGER*2 INFOBUFLEN
CHARACTER*150 MSGBUF
INTEGER*2 MSGBUFLEN
INTEGER*2 ERRMSGLEN
CHARACTER*70 ERROR_LOCATION
!
STOP_ NOW = 0
DONE_ WITH_TXNS = 0
!
NBR_TXN_COLLECTED = 0
!
CALL SETUP_FOR_WORK
!
DO WHILE (STOP NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0)
CALL COLLECT_TXNS
END DO
!
CALL CLEANUP_AFTER _ WORK
!
PRINT *,
+ "Deduction transactions collected this session =",
+ NBR_TXN_COLLECTED
!
IF (STOP NOW.EQ.1) THEN
CALL DISPLAY_SYSTEM_ERROR
END IF
!
STOP
END
$TITLE ' Setup For Work'
!***************************************************************!
! !
! Setup For Work !
! !
!***************************************************************!
!
SUBROUTINE SETUP-FOR -WORK
!
IMPLICIT NONE
!
COMMON /COMO1/ COMAREA
COMMON /COM11/ STOP_NOW
COMMON /COM21/ FIELDINFO
COMMON /COM22/ INFOBUFLEN
COMMON /COM81/ MSGBUF
COMMON /COM82/ MSGBUFLEN
COMMON /COM83/ ERRMSGLEN
COMMON /COM91/ ERROR_LOCATION
!
SYSTEM INTRINSIC VOPENFORMF,
+ VOPENTERM,
+ VGETFIELDINFO
!
INTEGER*2 COMAREA(60)
INTEGER*2 CSTATUS
INTEGER*2 LANGUAGE
INTEGER*2 COMAREALEN
INTEGER*2 LABELOPTIONS
INTEGER*2 LOOKAHEAD
INTEGER*2 FORMSTORESIZE
EQUIVALENCE (COMAREA(1), CSTATUS),
+ (COMAREA(2), LANGUAGE),
+ (COMAREA(3), COMAREALEN),
+ (COMAREA(10), LABELOPTIONS),
+ (COMAREA(32), LOOKAHEAD),
+ (COMAREA(39), FORMSTORESIZE)
INTEGER*2 STOP_NOW
INTEGER*2 FIELDINFO(37)
INTEGER*2 NUM_ENTRIES
INTEGER*2 ENTRY_LEN
CHARACTER*16 FORM_NAME
EQUIVALENCE (FIELDINFO(1), NUM_ENTRIES),
+ (FIELDINFO(2), ENTRY_LEN),
+ (FIELDINFO(3), FORM_NAME)
CHARACTER*18 FIELD_NAME (1,3)
EQUIVALENCE (FIELDINFO(11), FIELD_NAME)
INTEGER*2 INFOBUFLEN
CHARACTER*150 MSGBUF
INTEGER*2 MSGBUFLEN
INTEGER*2 ERRMSGLEN
CHARACTER*70 ERROR_LOCATION
INTEGER*2 ARRAY_INDEX
CHARACTER*86 FILENAME
!
! Init Comarea to all zeros.
!
ARRAY_INDEX = 1
DO WHILE (ARRAY_INDEX.LE.60)
COMAREA(ARRAY_INDEX) = 0
ARRAY_INDEX = ARRAY_INDEX + 1
END DO
!
! Set Language for FORTRAN-77.
!
LANGUAGE = 5
!
! Set Comarealen for 60 words (120 bytes).
!
COMAREALEN = 60
!
! Activate function key labeling.
!
LABELOPTIONS = 1
!
! Disable form background loading on Vreadfields.
!
LOOKAHEAD = 0
!
! Set size of local form storage directory.
!
FORMSTORESIZE = 4
!
! Open the Transaction File:
!
OPEN (UNIT = 10,
+ ENTITY = 'PAYTXN',
+ ACCESS = 'DIRECT',
+ RECL = 200,
+ FORM = 'UNFORMATTED',
+ STATUS = 'NEW',
+ ERR = 110)
!
GOTO 120
!
110 STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Setup For Work - Open Transaction File"
MSGBUF =
+ "**** File open failed!"
!
! Open the Forms File.
!
120 IF (STOP NOW.EQ.0) THEN
FILENAME = "PAYROLL.WORK.ADMIN"
!
CALL VOPENFORMF (COMAREA,
+ FILENAME)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Setup For Work - Forms File Open"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Open the Terminal.
!
IF (STOP NOW.EQ.0) THEN
FILENAME = "HPTERM"
!
CALL VOPENTERM (COMAREA,
+ FILENAME)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Setup For Work - Terminal Setup"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Translate field names to screen orders.
!
! Three of the fields in the form used by this
! application need to be toggled from "display
! only" to "input allowed". In order to do this,
! we first translate field names to screen orders.
!
IF (STOP_NOW.EQ.0) THEN
!
NUM_ENTRIES = 3
ENTRY_LEN = 9
FORM_NAME = "DEDUCTION"
!
! Note that because the FIELD_NAME element is defined as 18
! characters long, each occurrence of FIELD_NAME overlaps
! the position of each occurrence of the SCREEN_ORDER element
! in the infobuf. Thus setting each FIELD_NAME element to
! a literal that is 16 characters long or Less results in each
! SCREEN_ORDER element being implicitly filled with blanks.
!
FIELD_NAME(1,1) = "BADGE_NUMBER"
!
FIELD_NAME(1,2) = "LAST_NAME"
!
FIELD_NAME(1,3) = "SUR_NAME"
!
! Now determine the length of the entire Fieldinfo buffer.
!
INFOBUFLEN = (NUM_ENTRIES * ENTRY_LEN) + 10
!
CALL VGETFIELDINFO (COMAREA,
+ FIELDINFO,
+ INFOBUFLEN)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Setup For Work - Field Info Retrieval"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
END
$TITLE ' Collect Transactions'
!***************************************************************!
! !
! Collect Transactions !
! !
!***************************************************************!
!
SUBROUTINE COLLECT_TXNS
!
IMPLICIT NONE
!
COMMON /COMO1/ COMAREA
COMMON /COM11/ STOP_NOW
COMMON /COM12/ DONE_WITH_TXNS
COMMON /COM13/ NBR_TXN_COLLECTED
COMMON /COM21/ FIELDINFO
COMMON /COM81/ MSGBUF
COMMON /COM82/ MSGBUFLEN
COMMON /COM83/ ERRMSGLEN
COMMON /COM91/ ERROR_LOCATION
COMMON /COM101/ FOUND_DATA_ERRS
!
SYSTEM INTRINSIC VCHANGEFIELD,
+ VPUTWINDOW,
+ VINITFORM,
+ VSHOWFORM
!
INTEGER*2 COMAREA(60)
INTEGER*2 CSTATUS
INTEGER*2 REPEATAPP
INTEGER*2 FREEZEAPP
CHARACTER*16 NFNAME
EQUIVALENCE (COMAREA(1), CSTATUS),
+ (COMAREA(27), REPEATAPP),
+ (COMAREA(28), FREEZEAPP),
+ (COMAREA(19), NFNAME)
INTEGER*2 STOP_NOW
INTEGER*2 DONE_WITH_TXNS
INTEGER*2 NBR_TXN_COLLECTED
INTEGER*2 FIELDINFO(37)
INTEGER*2 NUM_ENTRIES
INTEGER*2 ENTRY_LEN
CHARACTER*16 FORM_NAME
EQUIVALENCE (FIELDINFO(1), NUM_ENTRIES),
+ (FIELDINFO(2), ENTRY_LEN),
+ (FIELDINFO(3), FORM_NAME)
INTEGER*2 FIELD NAME (9,3)
INTEGER*2 SCREEN ORDER (9,3)
EQUIVALENCE (FIELDINFO(11), FIELD_NAME),
+ (FIELDINFO(11), SCREEN_ORDER)
CHARACTER*150 MSGBUF
INTEGER*2 MSGBUFLEN
INTEGER*2 ERRMSGLEN
CHARACTER*70 ERROR_LOCATION
INTEGER*2 FIELDSPECS(12)
INTEGER*2 FIELD_ID(4,3)
INTEGER*2 CHANGE_TYPE(4,3)
CHARACTER*4 CHANGE_SPEC(2,3)
EQUIVALENCE (FIELDSPECS (1), FIELD_ID) ,
+ (FIELDSPECS (1), CHANGE_TYPE),
+ (FIELDSPECS (1), CHANGE_SPEC)
INTEGER*2 NUMSPECS
INTEGER*2 FOUND_DATA_ERRS
!
! Setup for and get transaction data entry form.
!
REPEATAPP = 0
FREEZEAPP = 0
!
NFNAME = "DEDUCTION"
!
CALL VGETNEXTFORM (COMAREA)
!
IF (CSTATUS.NE.0) THEN
STOP_ NOW = 1
ERROR_LOCATION =
+ "**** Routine: Collect Transactions - Form Retrieval"
CALL GET_ERROR_MESSAGE
END IF
!
! Toggle three fields in form to "input allowed".
!
! Screen order is indicated to field change intrinsic
! as a negative number.
!
! Change field type is indicated by a 5.
!
! "Input allowed" is indicated by an "O" (for input/output).
!
IF (STOP_NOW.EQ.0) THEN
!
FIELD_ID(1,1) = (SCREEN_ORDER(9,1) * (-1))
CHANGE_TYPE(2,1) = 5
CHANGE_SPEC (2,1) = "O"
!
FIELD ID(1,2) = (SCREEN_ORDER(9,2) * (-1))
CHANGE_TYPE(2,2) = 5
CHANGE_SPEC(2,2) = "O"
!
FIELD_ID(1,3) = (SCREEN_ORDER(9,3) * (-1))
CHANGE_TYPE(2,3) = 5
CHANGE_SPEC(2,3) = "O"
!
NUMSPECS = 3
!
CALL VCHANGEFIELD (COMAREA,
+ FIELDSPECS,
+ NUMSPECS)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Collect Transactions - Field Type Updates"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Load window message.
!
IF (STOP_NOW.EQ.0) THEN
!
MSGBUFLEN = 79
!
MSGBUF =
+ "Fill in Deduction Transaction according to worksheet."
!
CALL VPUTWINDOW (COMAREA,
+ MSGBUF,
+ MSGBUFLEN)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Collect Transactions - Window Load"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Initialize form.
!
IF (STOP_NOW.EQ.0) THEN
!
CALL VINITFORM (COMAREA)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Collect Transactions - Form Init"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Show form.
!
IF (STOP_NOW.EQ.0) THEN
!
CALL SHOWFORM (COMAREA)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Collect Transactions - Form display"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Setup and loop on transaction until it can be filed.
!
FOUND_DATA_ERRS = 1
!
DO WHILE (FOUND_DATA_ERRS.EQ.1
+ .AND.STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0)
!
CALL READ_EDIT_AND_FILE
!
END DO
!
END
$TITLE ' Read Edit and File'
!***************************************************************!
! !
! Read Edit and File !
! !
!***************************************************************!
!
SUBROUTINE READ_EDIT_AND_FILE
!
IMPLICIT NONE
!
COMMON /COMO1/ COMAREA
COMMON /COM11/ STOP_NOW
COMMON /COM12/ DONE_WITH_TXNS
COMMON /COM13/ NBR_TXN_COLLECTED
COMMON /COM81/ MSGBUF
COMMON /COM82/ MSGBUFLEN
COMMON /COM83/ ERRMSGLEN
COMMON /COM91/ ERROR_LOCATION
COMMON /COM101/ FOUND_DATA_ERRS
!
SYSTEM INTRINSIC VREADFIELDS,
+ VFIELDEDITS,
+ VFINISHFORM,
+ VGETBUFFER
!
INTEGER*2 COMAREA(60)
INTEGER*2 CSTATUS
INTEGER*2 LASTKEY
INTEGER*2 NUMERRS
EQUIVALENCE (COMAREA(1), CSTATUS),
+ (COMAREA(6), LASTKEY),
+ (COMAREA(7), NUMERRS)
INTEGER*2 STOP_NOW
INTEGER*2 DONE_WITH_TXNS
INTEGER*2 NBR_TXN_COLLECTED
CHARACTER*150 MSGBUF
INTEGER*2 MSGBUFLEN
INTEGER*2 ERRMSGLEN
CHARACTER*70 ERROR_ LOCATION
INTEGER*2 FOUND_ DATA_ERRS
CHARACTER*200 DATABUF
INTEGER*2 DATABUFLEN
!
! Read form.
!
CALL VREADFIELDS (COMAREA)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Read Edit and File - Terminal Read"
CALL GET_ERROR_MESSAGE
END IF
!
! Determine if operator wants to stop transaction collection.
!
IF (STOP NOW.EQ.0) THEN
IF (LASTKEY.EQ.8) THEN
DONE_WITH_TXNS = 1
END IF
END IF
!
! Edit data read from terminal.
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
CALL VFIELDEDITS (COMAREA)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Read Edit and File - Data Edit"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Determine if edit errors detected.
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
IF (NUMERRS.LT.1) THEN
FOUND_DATA_ERRS = 0
END IF
END IF
!
! Finish form data.
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0
+ .AND.FOUND_DATA_ERRS.EQ.0) THEN
!
CALL VFINISHFORM (COMAREA)
!
IF (CSTATUS.NE.0) THEN
STOP_ NOW = 1
ERROR_LOCATION =
+ "**** Routine: Read Edit and File - Data Finishing"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
! Determine if data finishing errors detected.
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0
+ .AND.FOUND_DATA_ERRS.EQ.0) THEN
!
IF (NUMERRS.GT.0) THEN
FOUND_DATA_ERRS = 1
END IF
END IF
!
! Do we have a transaction that can be filed?
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
IF (FOUND_DATA_ERRS.EQ.0
+ .AND.LASTKEY.EQ.0) THEN
!
! Get transaction from form and file it.
!
DATABUF = " "
!
DATABUFLEN = 200
!
CALL VGETBUFFER (COMAREA,
+ DATABUF,
+ DATABUFLEN)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Read Edit and File - Data Get"
CALL GET_ERROR_MESSAGE
!
ELSE
!
! Write Databuf to Transaction File.
!
WRITE (UNIT = 10,
+ ERR = 310) DATABUF
!
GOTO 320
!
310 STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Read Edit and File - File Write"
MSGBUF =
+ "**** Write to Transaction File failed!"
!
320 IF (STOP_NOW.EQ.0) THEN
NBR_TXN_COLLECTED = NBR_TXN_COLLECTED + 1
END IF
END IF
END IF
END IF
!
! Do we need to prompt the operator to correct errors?
!
IF (STOP_NOW.EQ.O
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
IF (FOUND DATA ERRS.EQ.1
+ .AND.LASTKEY.EQ._O) THEN
!
CALL PROMPT _OPERATOR
!
END IF
END IF
!
! Do we need to refresh the display?
!
IF (STOP_ NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
IF (FOUND_DATA_ERRS.EQ.1
+ .AND.LASTKEY.NE.0) THEN
!
! The operator pressed some key other than <ENTER>
! or <EXIT> so clear data error flag to break loop.
!
FOUND_ DATA_ERRS = 0
!
END IF
END IF
!
END
$TITLE ' Prompt Operator'
!***************************************************************!
! !
! Prompt Operator !
! !
!***************************************************************!
!
SUBROUTINE PROMPT_OPERATOR
!
IMPLICIT NONE
!
COMMON /COMO1/ COMAREA
COMMON /COM11/ STOP NOW
COMMON /COM81/ MSGBUF
COMMON /COM82/ MSGBUFLEN
COMMON /COM83/ ERRMSGLEN
COMMON /COM91/ ERROR_LOCATION
!
SYSTEM INTRINSIC VPUTWINDOW,
+ VSHOWFORM
!
INTEGER*2 COMAREA(60)
INTEGER*2 CSTATUS
EQUIVALENCE (COMAREA(1), CSTATUS)
INTEGER*2 STOP_NOW
CHARACTER*150 MSGBUF
INTEGER*2 MSGBUFLEN
INTEGER*2 ERRMSGLEN
CHARACTER*70 ERROR_LOCATION
!
! Get message text associated with first field flagged
! with a data error.
!
CALL GET_ERROR_MESSAGE
CALL VPUTWINDOW (COMAREA,
+ MSGBUF,
+ ERRMSGLEN)
!
IF (CSTATUS.NE.0) THEN
STOP NOW = 1
ERROR_LOCATION =
+ "**** Routine: Prompt Operator - Window Load"
CALL GET_ERROR_MESSAGE
END IF
!
! Display highlighted form and updated window message.
!
IF (STOP_NOW.EQ.0) THEN
CALL VSHOWFORM (COMAREA)
!
IF (CSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Prompt Operator - Display Updates"
CALL GET_ERROR_MESSAGE
END IF
END IF
!
END
$TITLE ' Cleanup After Work'
!***************************************************************!
! !
! Cleanup After Work !
! !
!***************************************************************!
!
SUBROUTINE CLEANUP_AFTER_WORK
!
IMPLICIT NONE
!
COMMON /COMO1/ COMAREA
!
SYSTEM INTRINSIC VCLOSEFORMF,
+ VCLOSETERM
!
INTEGER*2 COMAREA(60)
INTEGER*2 CSTATUS
EQUIVALENCE (COMAREA(1), CSTATUS)
!
! Note that this routine unconditionally attempts to close
! the Forms File and Terminal
!
CLOSE (UNIT = 10)
!
CSTATUS = 0
!
CALL VCLOSEFORMF (COMAREA)
!
CSTATUS = 0
!
CALL VCLOSETERM (COMAREA)
!
END
$TITLE ' Get Error Message'
!***************************************************************!
! !
! Get Error Message !
! !
!***************************************************************!
!
SUBROUTINE GET-ERROR-MESSAGE
!
IMPLICIT NONE
!
COMMON /COMO1/ COMAREA
COMMON /COM81/ MSGBUF
COMMON /COM82/ MSGBUFLEN
COMMON /COM83/ ERRMSGLEN
!
SYSTEM INTRINSIC VERRMSG
!
INTEGER*2 COMAREA(60)
CHARACTER*150 MSGBUF
INTEGER*2 MSGBUFLEN
INTEGER*2 ERRMSGLEN
!
MSGBUF = " "
MSGBUFLEN = 150
!
CALL VERRMSG (COMAREA,
+ MSGBUF,
+ MSGBUFLEN,
+ ERRMSGLEN)
!
END
X
$TITLE ' Display System Error'
!***************************************************************!
! !
! Display System Error !
! !
!***************************************************************!
!
SUBROUTINE DISPLAY_SYSTEM_ERROR
!
IMPLICIT NONE
!
COMMON /COM81/ MSGBUF
COMMON /COM91/ ERROR_LOCATION
!
CHARACTER*150 MSGBUF
CHARACTER*70 ERROR_LOCATION
!
PRINT *,
+ "**** Transaction entry facility detected system error at:"
PRINT *, ERROR_LOCATION
PRINT *,
+ "**** The error message returned is:"
PRINT *, MSGBUF
!
END