|
|
|
PROCESS APOST.
IDENTIFICATION DIVISION.
H/TITLE Edit customer file Edit file
Z* CRTCBLPGM
*
H* SYNOPSIS :
H* - Maintain database file using subfile display
H* - Existing records may be updated or deleted,
H* - Key changes are not allowed
H* - Program operates in two modes: *CHANGE and *ADD
H* - Multiple new records may be added by changing to add mode
H* Generated by : COOL:2E Version: 8644
H* Function type : Edit file Version: 0.1
*
H* Company : Universal Sprocket Company Ltd.
H* System : Universal Sprocket Company Ltd.
H* User name : P.Djikastra
H* Date : 10/09/87
H* (C) Copyright 1987 Universal Sprocket Company Ltd.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = =
M* Maintenance : 92/03/02 C.Hoare Change Help processing
* = = = = = = = = = = = = = = = = = = = = = = = = = = = =
PROGRAM-ID. UUB7EFK.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
SPECIAL-NAMES. OPEN-FEEDBACK IS OPEN-FEEDBACK-AREA,
I-O-FEEDBACK IS I-O-FEEDBACK-AREA.
/EJECT
INPUT-OUTPUT SECTION.
FILE-CONTROL.
*
SELECT UUB7EFK
ASSIGN TO WORKSTATION-UUB7EFK-SI
ORGANIZATION IS TRANSACTION
ACCESS MODE IS DYNAMIC
RELATIVE KEY IS ZZRR
FILE STATUS IS FILE-STATUS, MAJOR-MINOR-CODE.
* DSP: Edit customer file Edit file
*
SELECT UUAIREL1
ASSIGN TO DATABASE-UUAIREL1
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
FILE STATUS IS FILE-STATUS.
* RTV: customer file Retrieval index
*
SELECT UUAIREL0
ASSIGN TO DATABASE-UUAIREL0
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
FILE STATUS IS FILE-STATUS.
* UPD: customer file Update index
*
I-O-CONTROL.
*
/EJECT
DATA DIVISION.
FILE SECTION.
*
FD UUB7EFK
LABEL RECORDS ARE STANDARD.
01 UUB7EFK-F.
COPY DDS-ALL-FORMATS OF UUB7EFK.
*
FD UUAIREL1
LABEL RECORDS ARE STANDARD.
01 UUAIREL1-R.
COPY DDS-ALL-FORMATS OF UUAIREL1.
*
FD UUAIREL0
LABEL RECORDS ARE STANDARD.
01 UUAIREL0-R.
COPY DDS-ALL-FORMATS OF UUAIREL0.
/EJECT
WORKING-STORAGE SECTION.
* Job context
01 JOB-CONTEXT.
COPY DDS-ALL-FORMATS OF Y2PGDSPK.
* Job date/time
03 IJBDTTM.
05 ZZJDT PIC S9(6).
05 ZZJDTE REDEFINES ZZJDT.
07 ZZJYY PIC S9(2).
07 ZZJMM PIC S9(2).
07 ZZJDD PIC S9(2).
05 ZZJTM PIC S9(6).
05 ZZJTME REDEFINES ZZJTM.
07 ZZJHH PIC S9(2).
07 ZZJNN PIC S9(2).
07 ZZJSS PIC S9(2).
03 ZZFQL PIC X(10).
03 ZZFLB PIC X(10).
03 ZZFFL PIC X(10).
03 ZZFMB PIC X(10).
01 ZZTIME.
03 ZZHNS PIC S9(6).
03 ZZHH PIC S9(2).
*
77 C-IND-OFF PIC 1(1) VALUE B’0’.
77 C-IND-ON PIC 1(1) VALUE B’1’.
*
*
01 FILE-STATUS PIC X(2).
88 C-IO-OK VALUE ‘00’.
88 C-EOF VALUE ‘10’.
88 C-NO-MOD-SFLRCDS VALUE ‘12’.
88 C-IO-ERR VALUE ‘21’ ‘24’ ‘30’ ‘34’ ‘90’ ‘91’ ‘92’
‘94’ ‘95’ ‘9A’ ‘9H’ ‘9I’ ‘9K’ ‘9M’ ‘9N’ ‘9P’.
88 C-NO-RECORD VALUE ‘23’.
88 C-RECORD-LOCKED VALUE ‘9D’.
01 UNTIL-CONDITION PIC 1(1).
88 CONDITION-FALSE VALUE B’0’.
88 CONDITION-TRUE VALUE B’1’.
01 FOREVER PIC 1(1) VALUE B’1’.
88 C-FOREVER VALUE B’1’.
01 W0RTN PIC X(7).
01 Y1DBRC.
COPY DDS-ALL-FORMATS OF UUAIREL0.
* Current/previous master file format fields for change
* control
*
01 W0RSF PIC X(1).
01 ZZRRMX PIC S9(5) COMP-3.
* customer code
01 WZAICD PIC X(6).
01 KPOS.
* customer code
03 AIAICD PIC X(6).
01 KPOS-TMP.
* customer code
03 AIAICD PIC X(6).
* Define Full Externally Described Keylist
01 KPOS-EXT.
* customer code
03 AIAICD PIC X(6).
01 WKIND0-A.
03 WKIND0 PIC 1(1) OCCURS 3.
01 WKIND1-A.
03 WKIND1 PIC 1(1) OCCURS 3.
01 ZZRROK PIC S9(5) COMP-3.
01 CAIN89 PIC 1(1).
01 CAIN81 PIC 1(1).
01 ZAPGM PIC X(10).
01 ZAPGRL PIC X(5).
01 ZAFSMS PIC X(1).
01 WKIPIN PIC X(1).
01 W0DCF PIC X(1).
01 W0NLR PIC X(1).
01 WN30-A.
03 WN30 PIC 1(1) OCCURS 30.
01 IND-COUNT PIC S9(5) COMP-3.
01 ZADFMF PIC X(10).
01 DATA-AREA-NAME PIC X(10).
01 ZZSFPG PIC S9(3).
01 W0PMD PIC X(3).
88 C-ADD-MODE VALUE ‘ADD’.
88 C-CHANGE-MODE VALUE ‘CHG’.
88 C-SELECT-MODE VALUE ‘SEL’.
01 ZAMSID PIC X(7).
01 ZAMSGF PIC X(10).
01 ZAMSDA PIC X(132).
01 ZAMSTP PIC X(7).
01 ZZRR PIC 9(5) COMP-3.
01 UUB7EFK-I-O-DSPF.
COPY DDS-ALL-FORMATS OF Y2IDSPFIO.
* Subfile I/O feedback area
*
01 MAJOR-MINOR-CODE.
COPY DDS-ALL-FORMATS OF Y2IMAJMIN.
* Display major/minor code for timeouts
*
01 UUAIREL1-OPEN.
COPY DDS-ALL-FORMATS OF Y2IOPEN.
* Open feedback area
*
01 UUAIREL0-OPEN.
COPY DDS-ALL-FORMATS OF Y2IOPEN.
* Open feedback area
*
01 UUB7EFK-WS-O.
03 ZSFLRCD-WS-O.
COPY DDS-ZSFLRCD-O OF UUB7EFK.
06 FILLER PIC X.
03 ZSFLCTL-WS-O.
COPY DDS-ZSFLCTL-O OF UUB7EFK.
06 FILLER PIC X.
03 ZCMDTXT1-WS-O.
COPY DDS-ZCMDTXT1-O OF UUB7EFK.
06 FILLER PIC X.
03 ZMSGCTL-WS-O.
COPY DDS-ZMSGCTL-O OF UUB7EFK.
06 FILLER PIC X.
03 ZCONFIRM-WS-O.
COPY DDS-ZCONFIRM-O OF UUB7EFK.
06 FILLER PIC X.
01 UUB7EFK-WS-I.
03 ZSFLRCD-WS-I.
COPY DDS-ZSFLRCD-I OF UUB7EFK.
06 FILLER PIC X.
03 ZSFLCTL-WS-I.
COPY DDS-ZSFLCTL-I OF UUB7EFK.
06 FILLER PIC X.
03 ZCMDTXT1-WS-I.
COPY DDS-ZCMDTXT1-I OF UUB7EFK.
06 FILLER PIC X.
03 ZMSGCTL-WS-I.
COPY DDS-ZMSGCTL-I OF UUB7EFK.
06 FILLER PIC X.
03 ZCONFIRM-WS-I.
COPY DDS-ZCONFIRM-I OF UUB7EFK.
06 FILLER PIC X.
01 W0OPN PIC X(1).
* Indicators
01 INDICS.
03 IND PIC 1(1) OCCURS 990INDICATOR 1.
88 C-INDICATOR-ON VALUE B’1’.
88 C-INDICATOR-OFF VALUE B’0’.
*
/EJECT
** * * * * * * * * * * * * * * * * * * * * * * * * * * * *
LINKAGE SECTION.
* Return code
01 P0RTN PIC X(7).
** * * * * * * * ** * * * * * * * * * * * * * * * * * * * *
PROCEDURE DIVISION USING
P0RTN.
** * * * * * * * * * * * * * * * * * * * * * * * * * ** * *
MAINLINE SECTION.
* Initialise
PERFORM ZZINIT
*
* Initialisation
MOVE ZZPGM OF JOB-CONTEXT TO ZZPGM OF ZMSGCTL-WS-O
* Main loop
PERFORM UNTIL NOT (C-FOREVER)
* Initialise and load subfile page
PERFORM BAIZSF
MOVE ‘N’ TO W0RSF
* Display screen until reload requested:
PERFORM UNTIL NOT (W0RSF = ‘N’)
* Display screen
PERFORM CAEXFM
* Process response:
* EVALUATE
* Cancel & exit program
IF (C-INDICATOR-ON(03)) THEN
PERFORM ZXEXPG
* HOME: Request subfile reload
ELSE IF (C-INDICATOR-ON(30)) THEN
PERFORM FBRQRL
* Display next sfl page
ELSE IF (C-INDICATOR-ON(27)) THEN
PERFORM BBLDSF
ELSE
* Process screen input
PERFORM DAPRZZ
*
END-IF END-IF END-IF
END-PERFORM
*
END-PERFORM
.
MAINLINE-EXIT.
EXIT.
** * * * * * * * * * * * * * * * * * * * * * * * * * * * *
/EJECT
BAIZSF SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Initialise & Load subfile page
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Clear subfile
SET C-INDICATOR-ON(80) TO TRUE
WRITE UUB7EFK-F FROM ZSFLCTL-WS-O
FORMAT IS ‘ZSFLCTL’ INDICATORS ARE INDICS
END-WRITE
* Reset count of no of records in SFL
MOVE ZERO TO ZZRRMX
SET C-INDICATOR-OFF(81) TO TRUE
* If CHANGE mode, then position file:
IF (NOT C-ADD-MODE) THEN
* customer code
MOVE Z2AICD OF ZSFLCTL-WS-O TO WZAICD
* Setup key
MOVE Z2AICD OF ZSFLCTL-WS-O TO AIAICD OF KPOS
* Initialise Full Externally Described Keylist
* customer code
MOVE LOW-VALUES TO AIAICD OF KPOS-EXT
MOVE CORRESPONDING
KPOS-EXT TO
FAIREA4 OF UUAIREL1-R
MOVE CORRESPONDING
KPOS TO
FAIREA4 OF UUAIREL1-R
START UUAIREL1 KEY NOT EXTERNALLY-DESCRIBED-KEY
FORMAT IS ‘FAIREA4’
END-START
IF (C-IO-ERR) THEN
STOP RUN
END-IF
IF (C-EOF) THEN
SET C-INDICATOR-ON(82) TO TRUE
ELSE
SET C-INDICATOR-OFF(82) TO TRUE
SET C-INDICATOR-OFF(91) TO TRUE
READ UUAIREL1 NEXT
FORMAT IS ‘FAIREA4’
END-READ
IF (C-EOF) THEN
SET C-INDICATOR-ON(82) TO TRUE
ELSE
IF (C-IO-ERR) THEN
SET C-INDICATOR-ON(91) TO TRUE
END-IF
END-IF
IF (C-IO-OK) THEN
MOVE CORRESPONDING
FAIREA4 OF UUAIREL1 TO
FAIREA3 OF Y1DBRC
END-IF
END-IF
ELSE
SET C-INDICATOR-OFF(82) TO TRUE
END-IF
* Load subfile page
PERFORM BBLDSF
*. . . . . . . . . . . . . . . . . . . . . . . . . . . . .
* If no records found, display error message
IF (C-INDICATOR-ON(82) AND
ZZRR = ZERO) THEN
* Send message ‘*No data to display’
* Message ID
MOVE ‘Y2U0008’ TO ZAMSID
* Message file.
MOVE ‘Y2USRMSG’ TO ZAMSGF
PERFORM ZASNMS
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
BAEXIT.
EXIT.
/EJECT
BBLDSF SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Load subfile page (write empty page if add mode).
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
SET C-INDICATOR-OFF(84) TO TRUE
* No SFLNXTCHG
* Re-establish fields in read-ahead record
IF (C-INDICATOR-ON(27)) THEN
IF (C-INDICATOR-OFF(82) AND
NOT C-ADD-MODE) THEN
SET C-INDICATOR-OFF(90) TO TRUE
READ UUAIREL1 PRIOR
FORMAT IS ‘FAIREA4’
END-READ
IF (C-EOF) THEN
SET C-INDICATOR-ON(90) TO TRUE
ELSE
IF (C-IO-ERR) THEN
STOP RUN
END-IF
END-IF
SET C-INDICATOR-OFF(90) TO TRUE
READ UUAIREL1 NEXT
FORMAT IS ‘FAIREA4’
END-READ
IF (C-EOF) THEN
SET C-INDICATOR-ON(90) TO TRUE
ELSE
IF (C-IO-ERR) THEN
STOP RUN
END-IF
END-IF
MOVE CORRESPONDING
FAIREA4 OF UUAIREL1 TO
FAIREA3 OF Y1DBRC
END-IF
END-IF
* Setof record error indicators
MOVE ALL B’0’ TO WKIND1-A
MOVE ALL B’1’ TO WKIND1-A
* Start at previous highest SFL record reached
MOVE ZZRRMX TO ZZRR
MOVE ZERO TO ZZRROK
*. . . . . . . . . . . . . . . . . . . . . . . . . . . . .
* Load next page of SFL:
PERFORM UNTIL NOT (C-INDICATOR-OFF(82) AND
ZZRROK ZZSFPG)
MOVE WKIND0(1) TO IND(32)
MOVE WKIND0(2) TO IND(33)
MOVE WKIND0(3) TO IND(34)
SET C-INDICATOR-OFF(87) TO TRUE
* Clear SFL fields
PERFORM MAIZZ1
* If change mode, load SFL fields
IF (NOT C-ADD-MODE) THEN
PERFORM MBFLZ1
END-IF
* Output to subfile
ADD 1 TO ZZRR
IF (ZZRR ZERO) THEN
SET C-INDICATOR-ON(81) TO TRUE
ELSE
SET C-INDICATOR-OFF(81) TO TRUE
END-IF
ADD 1 TO ZZRROK
* Set screen conditioning indicators
PERFORM GADSA1
WRITE SUBFILE UUB7EFK-F FROM ZSFLRCD-WS-O
FORMAT IS ‘ZSFLRCD’ INDICATORS ARE INDICS
END-WRITE
IF (NOT C-ADD-MODE) THEN
SET C-INDICATOR-OFF(82) TO TRUE
READ UUAIREL1 NEXT
FORMAT IS ‘FAIREA4’
END-READ
IF (C-EOF) THEN
SET C-INDICATOR-ON(82) TO TRUE
ELSE
IF (C-IO-ERR) THEN
STOP RUN
END-IF
END-IF
MOVE CORRESPONDING
FAIREA4 OF UUAIREL1 TO
FAIREA3 OF Y1DBRC
END-IF
END-PERFORM
*. . . . . . . . . . . . . . . . . . . . . . . . . . . . .
* Save highest SFL rec, so load can continue at end point
IF (ZZRR ZZRRMX) THEN
ADD 1, ZZRRMX GIVING ZZSFRC OF ZSFLCTL-WS-O
MOVE ZZRR TO ZZRRMX
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
BBEXIT.
EXIT.
/EJECT
CAEXFM SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Display screen
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Set screen conditioning indicators
PERFORM GBDSA2
* Update screen time
ACCEPT ZZTIME FROM TIME
MOVE ZZHNS TO ZZTME OF ZSFLCTL-WS-O
* PUTOVR unless conditioned fields change
SET C-INDICATOR-ON(86) TO TRUE
IF (IND(89) NOT = CAIN89 OR
IND(81) NOT = CAIN81) THEN
SET C-INDICATOR-OFF(86) TO TRUE
END-IF
MOVE IND(89) TO CAIN89
MOVE IND(81) TO CAIN81
WRITE UUB7EFK-F FROM ZMSGCTL-WS-O
FORMAT IS ‘ZMSGCTL’ INDICATORS ARE INDICS
END-WRITE
WRITE UUB7EFK-F FROM ZCMDTXT1-WS-O
FORMAT IS ‘ZCMDTXT1’ INDICATORS ARE INDICS
END-WRITE
WRITE UUB7EFK-F FROM ZSFLCTL-WS-O
FORMAT IS ‘ZSFLCTL’ INDICATORS ARE INDICS
END-WRITE
READ UUB7EFK INTO ZSFLCTL-WS-I
FORMAT IS ‘ZSFLCTL’ INDICATORS ARE INDICS
END-READ
MOVE CORRESPONDING
ZSFLCTL-I OF ZSFLCTL-WS-I TO
ZSFLCTL-O OF ZSFLCTL-WS-O
* Update job time
ACCEPT ZZTIME FROM TIME
MOVE ZZHNS TO ZZJTM
* Clear messages from program message queue
MOVE ZZPGM OF JOB-CONTEXT TO ZAPGM
MOVE ‘*SAME’ TO ZAPGRL
CALL ‘Y2CLMSC’ USING
ZAPGM
ZAPGRL
END-CALL
* Reset first message only flag
MOVE ‘Y’ TO ZAFSMS
SET C-INDICATOR-OFF(99) TO TRUE
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
CAEXIT.
EXIT.
/EJECT
DAPRZZ SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Process screen input
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Maintain subfile position where possible
ACCEPT UUB7EFK-I-O-DSPF FROM I-O-FEEDBACK-AREA
FOR UUB7EFK
IF (ZZSFRC OF UUB7EFK-I-O-DSPF ZERO) THEN
MOVE ZZSFRC OF UUB7EFK-I-O-DSPF TO ZZSFRC OF
ZSFLCTL-WS-O
END-IF
IF (NOT C-ADD-MODE) THEN
* Change of position specified?
* EVALUATE
* customer code
IF (WZAICD NOT = Z2AICD OF ZSFLCTL-WS-O) THEN
PERFORM FBRQRL
ELSE
CONTINUE
END-IF
END-IF
* Quit if reload requested
IF (W0RSF = ‘Y’) THEN
GO DAEXIT
END-IF
IF (C-INDICATOR-ON(81)) THEN
* No data entered as yet
MOVE ‘N’ TO WKIPIN
* Confirm/update is not defered
MOVE ‘N’ TO W0DCF
* Process subfile records
PERFORM DBPRSF
* If error, exit:
IF (C-INDICATOR-ON(99)) THEN
GO DAEXIT
END-IF
* Defer confirm/update requested:
IF (W0DCF = ‘Y’) THEN
GO DAEXIT
END-IF
* If data entered
IF (WKIPIN = ‘Y’) THEN
* Prompt for confirm
PERFORM DHPRCF
* Exit if not confirmed
IF (C-INDICATOR-ON(99)) THEN
GO DAEXIT
END-IF
* Update DBF from subfile
PERFORM EAPRSF
* If error during update, exit:
IF (C-INDICATOR-ON(99)) THEN
GO DAEXIT
END-IF
END-IF
END-IF
* = = = = = Process function keys = = = = =
* Switch between *ADD/*CHANGE modes
IF (C-INDICATOR-ON(09)) THEN
PERFORM FACHMD
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
DAEXIT.
EXIT.
/EJECT
DBPRSF SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Process modified subfile records
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
READ SUBFILE UUB7EFK NEXT MODIFIED INTO ZSFLRCD-WS-I
FORMAT IS ‘ZSFLRCD’ INDICATORS ARE INDICS
END-READ
IF (C-NO-MOD-SFLRCDS) THEN
SET C-INDICATOR-ON(92) TO TRUE
ELSE
SET C-INDICATOR-OFF(92) TO TRUE
MOVE CORRESPONDING
ZSFLRCD-I OF ZSFLRCD-WS-I TO
ZSFLRCD-O OF ZSFLRCD-WS-O
END-IF
PERFORM UNTIL NOT (C-INDICATOR-OFF(92))
PERFORM DCPRSR
SET C-INDICATOR-OFF(87) TO TRUE
* Set screen conditioning indicators
PERFORM GADSA1
REWRITE SUBFILE UUB7EFK-F FROM ZSFLRCD-WS-O
FORMAT IS ‘ZSFLRCD’ INDICATORS ARE INDICS
END-REWRITE
READ SUBFILE UUB7EFK NEXT MODIFIED INTO ZSFLRCD-WS-I
FORMAT IS ‘ZSFLRCD’ INDICATORS ARE INDICS
END-READ
MOVE CORRESPONDING
ZSFLRCD-I OF ZSFLRCD-WS-I TO
ZSFLRCD-O OF ZSFLRCD-WS-O
IF (C-NO-MOD-SFLRCDS) THEN
SET C-INDICATOR-ON(92) TO TRUE
ELSE
SET C-INDICATOR-OFF(92) TO TRUE
END-IF
END-PERFORM
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
DBEXIT.
EXIT.
/EJECT
DCPRSR SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Process subfile record
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Setoff error indicators
MOVE WKIND0(1) TO IND(32)
MOVE WKIND0(2) TO IND(33)
MOVE WKIND0(3) TO IND(34)
* SFLRCD error
SET C-INDICATOR-OFF(98) TO TRUE
* NO SFLNXTCHG
SET C-INDICATOR-OFF(84) TO TRUE
IF (C-ADD-MODE) THEN
* Check for null record
PERFORM DDNLRC
IF (W0NLR = ‘Y’) THEN
GO DCEXIT
END-IF
* If not null record, continue
END-IF
* Data entered
MOVE ‘Y’ TO WKIPIN
* 84 SFLNXTCHG
SET C-INDICATOR-ON(84) TO TRUE
* If delete request, bypass validation
* Validate subfile record
PERFORM DEV1RC
* If SFLRCD invalid, note the fact
IF (C-INDICATOR-ON(98) AND
C-INDICATOR-OFF(99)) THEN
MOVE ZZRR TO ZZSFRC OF ZSFLCTL-WS-O
IF (ZZSFRC OF ZSFLCTL-WS-O ZERO) THEN
SET C-INDICATOR-ON(99) TO TRUE
ELSE
SET C-INDICATOR-OFF(99) TO TRUE
END-IF
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
DCEXIT.
EXIT.
/EJECT
DDNLRC SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Check for null record
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE ‘N’ TO W0NLR
* customer code
IF (Z1AICD OF ZSFLRCD-WS-O NOT = SPACES) THEN
GO DDEXIT
END-IF
* customer name
IF (Z1APTX OF ZSFLRCD-WS-O NOT = SPACES) THEN
GO DDEXIT
END-IF
MOVE ‘Y’ TO W0NLR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
DDEXIT.
EXIT.
/EJECT
DEV1RC SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Validate subfile record
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* customer code required
IF (Z1AICD OF ZSFLRCD-WS-O = SPACES) THEN
SET C-INDICATOR-ON(98) TO TRUE
SET C-INDICATOR-ON(33) TO TRUE
* Send message ‘*Value required’
* Message ID
MOVE ‘Y2U0001’ TO ZAMSID
* Message file.
MOVE ‘Y2USRMSG’ TO ZAMSGF
PERFORM ZASNMS
END-IF
* customer name required
IF (Z1APTX OF ZSFLRCD-WS-O = SPACES) THEN
SET C-INDICATOR-ON(98) TO TRUE
SET C-INDICATOR-ON(34) TO TRUE
* Send message ‘*Value required’
* Message ID
MOVE ‘Y2U0001’ TO ZAMSID
* Message file.
MOVE ‘Y2USRMSG’ TO ZAMSGF
PERFORM ZASNMS
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
DEEXIT.
EXIT.
/EJECT
DHPRCF SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Prompt for confirm
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Set screen conditioning indicators
PERFORM GBDSA2
* Update screen time
ACCEPT ZZTIME FROM TIME
MOVE ZZHNS TO ZZTME OF ZSFLCTL-WS-O
* Force PUTOVR
SET C-INDICATOR-ON(86) TO TRUE
WRITE UUB7EFK-F FROM ZMSGCTL-WS-O
FORMAT IS ‘ZMSGCTL’ INDICATORS ARE INDICS
END-WRITE
WRITE UUB7EFK-F FROM ZCMDTXT1-WS-O
FORMAT IS ‘ZCMDTXT1’ INDICATORS ARE INDICS
END-WRITE
WRITE UUB7EFK-F FROM ZSFLCTL-WS-O
FORMAT IS ‘ZSFLCTL’ INDICATORS ARE INDICS
END-WRITE
MOVE SPACES TO ZZCFCD OF UUB7EFK-WS-O
MOVE ‘N’ TO ZZCFCD OF UUB7EFK-WS-O
* Save CMD keys
MOVE INDICS TO WN30-A
WRITE UUB7EFK-F FROM ZCONFIRM-WS-O
FORMAT IS ‘ZCONFIRM’ INDICATORS ARE INDICS
END-WRITE
READ UUB7EFK INTO ZCONFIRM-WS-I
FORMAT IS ‘ZCONFIRM’ INDICATORS ARE INDICS
END-READ
MOVE CORRESPONDING
ZCONFIRM OF ZCONFIRM-WS-I TO
ZCONFIRM OF ZCONFIRM-WS-O
* Restore CMD keys
MOVE 1 TO IND-COUNT
SET CONDITION-FALSE TO TRUE
PERFORM UNTIL (CONDITION-TRUE)
MOVE WN30(IND-COUNT) TO IND(IND-COUNT)
ADD 1 TO IND-COUNT
IF (IND-COUNT 30)
SET CONDITION-TRUE TO TRUE
END-IF
END-PERFORM
* Update job time
ACCEPT ZZTIME FROM TIME
MOVE ZZHNS TO ZZJTM OF JOB-CONTEXT
IF (ZZCFCD OF UUB7EFK-WS-O NOT = ‘Y’) THEN
SET C-INDICATOR-ON(99) TO TRUE
ELSE
SET C-INDICATOR-OFF(99) TO TRUE
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
DHEXIT.
EXIT.
/EJECT
EAPRSF SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Update DBF from subfile records
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Initialise subfile reload flag
IF (C-ADD-MODE) THEN
MOVE ‘Y’ TO W0RSF
ELSE
MOVE ‘N’ TO W0RSF
END-IF
* Process all modified subfile records
READ SUBFILE UUB7EFK NEXT MODIFIED INTO ZSFLRCD-WS-I
FORMAT IS ‘ZSFLRCD’ INDICATORS ARE INDICS
END-READ
IF (C-NO-MOD-SFLRCDS) THEN
SET C-INDICATOR-ON(92) TO TRUE
ELSE
SET C-INDICATOR-OFF(92) TO TRUE
MOVE CORRESPONDING
ZSFLRCD-I OF ZSFLRCD-WS-I TO
ZSFLRCD-O OF ZSFLRCD-WS-O
END-IF
PERFORM UNTIL NOT (C-INDICATOR-OFF(92))
* Process modified subfile record
PERFORM EBPRSR
MOVE SPACES TO Z1SEL OF ZSFLRCD-WS-O
* Set screen conditioning indicators
PERFORM GADSA1
REWRITE SUBFILE UUB7EFK-F FROM ZSFLRCD-WS-O
FORMAT IS ‘ZSFLRCD’ INDICATORS ARE INDICS
END-REWRITE
READ SUBFILE UUB7EFK NEXT MODIFIED INTO ZSFLRCD-WS-I
FORMAT IS ‘ZSFLRCD’ INDICATORS ARE INDICS
END-READ
MOVE CORRESPONDING
ZSFLRCD-I OF ZSFLRCD-WS-I TO
ZSFLRCD-O OF ZSFLRCD-WS-O
IF (C-NO-MOD-SFLRCDS) THEN
SET C-INDICATOR-ON(92) TO TRUE
ELSE
SET C-INDICATOR-OFF(92) TO TRUE
END-IF
END-PERFORM
* If any errors, cancel reload
IF (C-INDICATOR-ON(99)) THEN
MOVE ‘N’ TO W0RSF
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
EAEXIT.
EXIT.
/EJECT
EBPRSR SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Process modified subfile record
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Set off error indicators
* Clear errors
MOVE WKIND0(1) TO IND(32)
MOVE WKIND0(2) TO IND(33)
MOVE WKIND0(3) TO IND(34)
SET C-INDICATOR-OFF(98) TO TRUE
IF (C-ADD-MODE) THEN
* Process add request
IF (Z1SEL OF ZSFLRCD-WS-O NOT = ‘D’) THEN
PERFORM DDNLRC
IF (W0NLR NOT = ‘Y’) THEN
PERFORM ECADRQ
END-IF
END-IF
ELSE
IF (Z1SEL OF ZSFLRCD-WS-O = ‘D’) THEN
* Process delete request
PERFORM EDDLRQ
ELSE
* Process change request
PERFORM EECHRQ
END-IF
END-IF
* If error occurred on update, note the fact
IF (C-INDICATOR-ON(98) AND
C-INDICATOR-OFF(99)) THEN
MOVE ZZRR TO ZZSFRC OF ZSFLCTL-WS-O
* Error on update
IF (ZZSFRC OF ZSFLCTL-WS-O ZERO) THEN
SET C-INDICATOR-ON(99) TO TRUE
ELSE
SET C-INDICATOR-OFF(99) TO TRUE
END-IF
ELSE
CONTINUE
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
EBEXIT.
EXIT.
/EJECT
ECADRQ SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Process add request
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* USER: Create DBF record
*
* Create object - customer file *
*
PERFORM SACRRC
IF (W0RTN NOT = SPACES) THEN
* Write error detected
* Screen errors
MOVE WKIND1(1) TO IND(32)
MOVE WKIND1(2) TO IND(33)
MOVE WKIND1(3) TO IND(34)
* Format error
SET C-INDICATOR-ON(98) TO TRUE
* Enable entry
SET C-INDICATOR-OFF(87) TO TRUE
* SFLNXTCHG
SET C-INDICATOR-ON(84) TO TRUE
ELSE
* DBF Write successful
* Disable entry
SET C-INDICATOR-ON(87) TO TRUE
* No SFLNXTCHG
SET C-INDICATOR-OFF(84) TO TRUE
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
ECEXIT.
EXIT.
/EJECT
EDDLRQ SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Process delete request
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* USER: Delete DBF record
*
* Delete object - customer file *
*
PERFORM SBDLRC
IF (W0RTN NOT = SPACES) THEN
* Delete unsuccessful
* Screen errors
MOVE WKIND1(1) TO IND(32)
MOVE WKIND1(2) TO IND(33)
MOVE WKIND1(3) TO IND(34)
* Format Error
SET C-INDICATOR-ON(98) TO TRUE
* Enable entry
SET C-INDICATOR-OFF(87) TO TRUE
* SFLNXTCHG
SET C-INDICATOR-ON(84) TO TRUE
* If record altered, reset subfile record
IF (W0RTN = ‘Y2U0007’) THEN
PERFORM MBFLZ1
END-IF
ELSE
* DBF Delete successful
* Blank out record and protect from entry
PERFORM MAIZZ1
* Disable entry
SET C-INDICATOR-ON(87) TO TRUE
* No SFLNXTCHG
SET C-INDICATOR-OFF(84) TO TRUE
* Reload subfile
MOVE ‘Y’ TO W0RSF
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
EDEXIT.
EXIT.
/EJECT
EECHRQ SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Process update request
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* USER: Change DBF record
*
* Change object - customer file *
*
PERFORM SCCHRC
IF (W0RTN NOT = SPACES) THEN
* DBF Update error detected
* Screen errors
MOVE WKIND1(1) TO IND(32)
MOVE WKIND1(2) TO IND(33)
MOVE WKIND1(3) TO IND(34)
* Format Error
SET C-INDICATOR-ON(98) TO TRUE
* Enable entry
SET C-INDICATOR-OFF(87) TO TRUE
* SFLNXTCHG
SET C-INDICATOR-ON(84) TO TRUE
* Reset subfile record if changed record
IF (W0RTN = ‘Y2U0007’) THEN
MOVE CORRESPONDING
FAIREA3 OF UUAIREL0 TO
FAIREA4
PERFORM MBFLZ1
END-IF
ELSE
* DBF Update successful
* Enable entry
SET C-INDICATOR-OFF(87) TO TRUE
* No SFLNXTCHG
SET C-INDICATOR-OFF(84) TO TRUE
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
EEEXIT.
EXIT.
/EJECT
FACHMD SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Flip between *ADD and *CHANGE modes
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
IF (NOT C-ADD-MODE) THEN
SET C-ADD-MODE TO TRUE
ELSE
SET C-CHANGE-MODE TO TRUE
END-IF
PERFORM FBRQRL
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
FAEXIT.
EXIT.
/EJECT
FBRQRL SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Request subfile reload
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE ‘Y’ TO W0RSF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
FBEXIT.
EXIT.
/EJECT
GADSA1 SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Set display attributes for Subfile record
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
IF (C-ADD-MODE) THEN
SET C-INDICATOR-ON(89) TO TRUE
ELSE
SET C-INDICATOR-OFF(89) TO TRUE
END-IF
* Protect keys if change mode or updated record
IF (C-INDICATOR-ON(89) AND
C-INDICATOR-OFF(87)) THEN
SET C-INDICATOR-OFF(88) TO TRUE
ELSE
SET C-INDICATOR-ON(88) TO TRUE
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
GAEXIT.
EXIT.
/EJECT
GBDSA2 SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Set display attributes for Subfile control
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
IF (C-ADD-MODE) THEN
SET C-INDICATOR-ON(89) TO TRUE
ELSE
SET C-INDICATOR-OFF(89) TO TRUE
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
GBEXIT.
EXIT.
/EJECT
MAIZZ1 SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Initialise subfile record
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE SPACES TO Z1DBRC OF UUB7EFK-WS-O
MOVE SPACES TO Z1SEL OF ZSFLRCD-WS-O
MOVE SPACES TO Z1AICD OF ZSFLRCD-WS-O
MOVE SPACES TO Z1APTX OF ZSFLRCD-WS-O
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
MAEXIT.
EXIT.
/EJECT
MBFLZ1 SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Move FAIREA4 fields to subfile
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* customer code
MOVE AIAICD OF FAIREA4 TO Z1AICD OF ZSFLRCD-WS-O
* customer name
MOVE AIAPTX OF FAIREA4 TO Z1APTX OF ZSFLRCD-WS-O
* Hold current record image for change detection
MOVE Y1DBRC TO Z1DBRC OF ZSFLRCD-WS-O
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
MBEXIT.
EXIT.
/EJECT
MEIZZ2 SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Initialise subfile control
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE SPACES TO Z2AICD OF ZSFLCTL-WS-O
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
MEEXIT.
EXIT.
/EJECT
SACRRC SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Create object - customer file *
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE SPACES TO W0RTN
* Move all fields to FAIREA3
* customer code
MOVE Z1AICD OF ZSFLRCD-WS-O TO AIAICD OF UUAIREL0-R
* customer name
MOVE Z1APTX OF ZSFLRCD-WS-O TO AIAPTX OF UUAIREL0-R
*
* Check for duplicate primary key
START UUAIREL0 KEY = EXTERNALLY-DESCRIBED-KEY
FORMAT IS ‘FAIREA3’
END-START
IF (NOT C-NO-RECORD) THEN
SET C-INDICATOR-ON(90) TO TRUE
MOVE ‘USR0028’ TO W0RTN
* Send message ‘customer file EX’
* Message ID
MOVE ‘USR0028’ TO ZAMSID
PERFORM ZASNMS
GO SAEXIT
ELSE
SET C-INDICATOR-OFF(90) TO TRUE
END-IF
*
WRITE UUAIREL0-R END-WRITE
IF (C-IO-ERR) THEN
SET C-INDICATOR-ON(91) TO TRUE
* Write error detected
MOVE ‘Y2U0004’ TO W0RTN
ELSE
SET C-INDICATOR-OFF(91) TO TRUE
* DBF Write successful
* Update saved record image
MOVE CORRESPONDING
FAIREA3 OF UUAIREL0 TO
FAIREA3 OF Y1DBRC
END-IF
*
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
SAEXIT.
EXIT.
/EJECT
SBDLRC SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Delete object - customer file *
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE SPACES TO W0RTN
* Move key fields to FAIREA3
* customer code
MOVE Z1AICD OF ZSFLRCD-WS-O TO AIAICD OF UUAIREL0-R
*
READ UUAIREL0 END-READ
IF (C-NO-RECORD) THEN
SET C-INDICATOR-ON(90) TO TRUE
ELSE
SET C-INDICATOR-OFF(90) TO TRUE
END-IF
IF (C-IO-ERR) THEN
SET C-INDICATOR-ON(91) TO TRUE
ELSE
SET C-INDICATOR-OFF(91) TO TRUE
END-IF
IF (C-IO-OK) THEN
MOVE CORRESPONDING
FAIREA3 OF UUAIREL0 TO
FAIREA3 OF Y1DBRC
END-IF
*
IF (C-INDICATOR-ON(90)) THEN
* Record already deleted
MOVE ‘Y2U0009’ TO W0RTN
* Send message ‘*Record no longer on file’
* Message ID
MOVE ‘Y2U0009’ TO ZAMSID
* Message file.
MOVE ‘Y2USRMSG’ TO ZAMSGF
PERFORM ZASNMS
GO SBEXIT
ELSE
CONTINUE
END-IF
*
IF (C-INDICATOR-ON(91)) THEN
* Record locked
MOVE ‘Y2U0004’ TO W0RTN
GO SBEXIT
ELSE
CONTINUE
END-IF
*
* Check for changed record
IF (Z1DBRC OF ZSFLRCD-WS-O NOT = Y1DBRC) THEN
MOVE ‘Y2U0007’ TO W0RTN
* Send message ‘*Update not accepted’
* Message ID
MOVE ‘Y2U0007’ TO ZAMSID
* Message file.
MOVE ‘Y2USRMSG’ TO ZAMSGF
PERFORM ZASNMS
* Use SETLL to release record lock
START UUAIREL0 KEY = EXTERNALLY-DESCRIBED-KEY
FORMAT IS ‘FAIREA3’
END-START
IF (C-NO-RECORD) THEN
SET C-INDICATOR-ON(90) TO TRUE
ELSE
SET C-INDICATOR-OFF(90) TO TRUE
IF (C-IO-ERR) THEN
SET C-INDICATOR-ON(91) TO TRUE
ELSE
SET C-INDICATOR-OFF(91) TO TRUE
END-IF
END-IF
GO SBEXIT
ELSE
CONTINUE
END-IF
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
DELETE UUAIREL0 END-DELETE
IF (C-IO-ERR) THEN
SET C-INDICATOR-ON(91) TO TRUE
* Delete error detected
MOVE ‘Y2U0004’ TO W0RTN
ELSE
SET C-INDICATOR-OFF(91) TO TRUE
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
SBEXIT.
EXIT.
/EJECT
SCCHRC SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Change object - customer file *
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE SPACES TO W0RTN
* Move key fields to FAIREA3
* customer code
MOVE Z1AICD OF ZSFLRCD-WS-O TO AIAICD OF UUAIREL0-R
*
READ UUAIREL0 END-READ
IF (C-NO-RECORD) THEN
SET C-INDICATOR-ON(90) TO TRUE
* Record not found
MOVE ‘Y2U0009’ TO W0RTN
* Send message ‘*Record no longer on file’
* Message ID
MOVE ‘Y2U0009’ TO ZAMSID
* Message file.
MOVE ‘Y2USRMSG’ TO ZAMSGF
PERFORM ZASNMS
GO SCEXIT
ELSE
SET C-INDICATOR-OFF(90) TO TRUE
IF (C-IO-ERR) THEN
SET C-INDICATOR-ON(91) TO TRUE
* Record locked
MOVE ‘Y2U0004’ TO W0RTN
GO SCEXIT
ELSE
SET C-INDICATOR-OFF(91) TO TRUE
IF (C-IO-OK) THEN
MOVE CORRESPONDING
FAIREA3 OF UUAIREL0 TO
FAIREA3 OF Y1DBRC
END-IF
END-IF
END-IF
*
* Check for changed record
IF (Z1DBRC OF ZSFLRCD-WS-O NOT = Y1DBRC) THEN
MOVE ‘Y2U0007’ TO W0RTN
* Send message ‘*Update not accepted’
* Message ID
MOVE ‘Y2U0007’ TO ZAMSID
* Message file.
MOVE ‘Y2USRMSG’ TO ZAMSGF
PERFORM ZASNMS
* Use SETLL to release record lock
START UUAIREL0 KEY = EXTERNALLY-DESCRIBED-KEY
FORMAT IS ‘FAIREA3’
END-START
IF (C-NO-RECORD) THEN
SET C-INDICATOR-ON(90) TO TRUE
ELSE
SET C-INDICATOR-OFF(90) TO TRUE
IF (C-IO-ERR) THEN
SET C-INDICATOR-ON(91) TO TRUE
ELSE
SET C-INDICATOR-OFF(91) TO TRUE
END-IF
END-IF
GO SCEXIT
END-IF
* Move Non-key fields to FAIREA3
* customer name
MOVE Z1APTX OF ZSFLRCD-WS-O TO AIAPTX OF UUAIREL0-R
*
REWRITE UUAIREL0-R END-REWRITE
IF (NOT C-IO-OK) THEN
SET C-INDICATOR-ON(91) TO TRUE
* Change error detected
MOVE ‘Y2U0004’ TO W0RTN
ELSE
SET C-INDICATOR-OFF(91) TO TRUE
* DBF Change successful
* Update saved record image
MOVE CORRESPONDING
FAIREA3 OF UUAIREL0 TO
FAIREA3 OF Y1DBRC
MOVE Y1DBRC TO Z1DBRC OF ZSFLRCD-WS-O
END-IF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
SCEXIT.
EXIT.
/EJECT
ZASNMS SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Send message to program’s message queue
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Send if message is first *DIAG or not *DIAG
IF (ZAMSTP NOT = SPACES OR
ZAFSMS NOT = ‘N’) THEN
IF (ZAMSTP = SPACES) THEN
* Signal first error message sent
MOVE ‘N’ TO ZAFSMS
END-IF
IF (ZAPGM = SPACES) THEN
MOVE ZZPGM OF JOB-CONTEXT TO ZAPGM
END-IF
* If no message file specified use default
IF (ZAMSGF = SPACES) THEN
MOVE ZADFMF TO ZAMSGF
END-IF
CALL ‘Y2SNMGC’ USING
* Program queue
ZAPGM
* Relative queue
ZAPGRL
* Message id
ZAMSID
* Message file
ZAMSGF
* Message data
ZAMSDA
* Message type
ZAMSTP
END-CALL
END-IF
* Clear all fields for default mechanism next time
* Program queue
MOVE SPACES TO ZAPGM
* Relative queue
MOVE SPACES TO ZAPGRL
* Message id
MOVE SPACES TO ZAMSID
* Message file
MOVE SPACES TO ZAMSGF
* Message data
MOVE SPACES TO ZAMSDA
* Message type
MOVE SPACES TO ZAMSTP
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
ZAEXIT.
EXIT.
/EJECT
ZXEXPG SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Exit program: Normal
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE SPACES TO P0RTN
PERFORM ZYEXPG
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
ZXEXIT.
EXIT.
/EJECT
ZYEXPG SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Exit program: Direct
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CLOSE UUB7EFK
CLOSE UUAIREL1
CLOSE UUAIREL0
* Reset entry parameters as appropriate
PERFORM ZZEXPM.
* Exit program
ZYEXPG-EXIT.
GOBACK
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
ZYEXIT.
EXIT.
/EJECT
ZZEXPM SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Return parameters from work fields
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CONTINUE
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
ZZPEXT.
EXIT.
/EJECT
ZZINIT SECTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* Initialisation
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
MOVE SPACES TO P0RTN
MOVE SPACES TO W0RTN
MOVE ALL B’0’ TO INDICS
* Setup job date/time
ACCEPT ZZJDT FROM DATE
ACCEPT ZZTIME FROM TIME
MOVE ZZHNS TO ZZJTM OF JOB-CONTEXT
* Retrieve job attributes
CALL ‘Y2RTJBR’ USING
JOB-CONTEXT
END-CALL
MOVE ‘UUB7EFK’ TO ZZPGM OF JOB-CONTEXT
* OBTAIN DEFAULT MESSAGE FILE.
MOVE ‘Y2MGFLA’ TO DATA-AREA-NAME
CALL ‘Y2RTDAC’ USING
DATA-AREA-NAME
ZADFMF
END-CALL
* Signal first *DIAG message outstanding
MOVE ‘Y’ TO ZAFSMS
* Open files
OPEN I-O UUB7EFK
OPEN INPUT UUAIREL1
ACCEPT UUAIREL1-OPEN FROM OPEN-FEEDBACK-AREA FOR UUAIREL1
* Move main file information to JOB context
MOVE CORRESPONDING OPENFA OF UUAIREL1-OPEN TO JOB-CONTEXT
CALL ‘Y2QLNMR’ USING
ZZFFL OF JOB-CONTEXT
ZZFLB OF JOB-CONTEXT
ZZFQL OF JOB-CONTEXT
END-CALL
OPEN I-O UUAIREL0
ACCEPT UUAIREL0-OPEN FROM OPEN-FEEDBACK-AREA FOR UUAIREL0
MOVE ‘Y’ TO W0OPN
*
MOVE ‘UUB7EFK’ TO ZZPGM OF ZSFLCTL-WS-O
MOVE 12 TO ZZSFPG
* SFLRCDNBR
MOVE 1 TO ZZSFRC OF ZSFLCTL-WS-O
* MAX RECNO
MOVE ZERO TO ZZRRMX
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
* If member empty, set to *ADD mode, else to *CHANGE mode
IF (ZZNROP OF UUAIREL1-OPEN = ZERO) THEN
SET C-ADD-MODE TO TRUE
ELSE
SET C-CHANGE-MODE TO TRUE
END-IF
* Initialise subfile control
PERFORM MEIZZ2
* = = = = = = = = = = = = = = = = = = = = = = = = = = = =
.
ZZEXIT.
EXIT.
| Copyright © 2011 CA. All rights reserved. | Tell Technical Publications how we can improve this information |