CBL LIB,QUOTE
*Module/File Name: IGZTMSGS
*************************************************************
* *
* CE92MSG - Program to invoke the following LE services: *
* *
* : CEEMOUT - dispatch a message to message file *
* : CEENCOD - construct a condition token *
* : CEEMGET - retrieve, format and store a message *
* : CEEDCOD - decode an existing condition token *
* : CEEMSG - retrieve, format, and dispatch a *
* : message to message file *
* *
* This example illustrates the invocation of the Language *
* Environment Message and Condition Handling services. *
* It contructs a condition token, retrieves the associated *
* message, and outputs the message to the message file. *
* *
* This example program will output the Language Environment *
* message, "CEE0260S". *
* *
*************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. CE92MSG.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 MSGSTR.
02 Vstring-length PIC S9(4) BINARY.
02 Vstring-text.
03 Vstring-char PIC X
OCCURS 0 TO 256 TIMES
DEPENDING ON Vstring-length
of MSGSTR.
01 MSGDEST PIC S9(9) BINARY.
01 SEV PIC S9(4) BINARY.
01 MSGNO PIC S9(4) BINARY.
01 CASE PIC S9(4) BINARY.
01 SEV2 PIC S9(4) BINARY.
01 CNTRL PIC S9(4) BINARY.
01 FACID PIC X(3).
01 ISINFO PIC S9(9) BINARY.
01 MSGINDX PIC S9(9) BINARY.
01 CTOK.
02 Condition-Token-Value.
COPY CEEIGZCT.
03 Case-1-Condition-ID.
04 Severity PIC S9(4) BINARY.
04 Msg-No PIC S9(4) BINARY.
03 Case-2-Condition-ID
REDEFINES Case-1-Condition-ID.
04 Class-Code PIC S9(4) BINARY.
04 Cause-Code PIC S9(4) BINARY.
03 Case-Sev-Ctl PIC X.
03 Facility-ID PIC XXX.
02 I-S-Info PIC S9(9) BINARY.
01 FC.
02 Condition-Token-Value.
COPY CEEIGZCT.
03 Case-1-Condition-ID.
04 Severity PIC S9(4) BINARY.
04 Msg-No PIC S9(4) BINARY.
03 Case-2-Condition-ID
REDEFINES Case-1-Condition-ID.
04 Class-Code PIC S9(4) BINARY.
04 Cause-Code PIC S9(4) BINARY.
03 Case-Sev-Ctl PIC X.
03 Facility-ID PIC XXX.
02 I-S-Info PIC S9(9) BINARY.
01 MGETFC.
02 Condition-Token-Value.
COPY CEEIGZCT.
03 Case-1-Condition-ID.
04 Severity PIC S9(4) BINARY.
04 Msg-No PIC S9(4) BINARY.
03 Case-2-Condition-ID
REDEFINES Case-1-Condition-ID.
04 Class-Code PIC S9(4) BINARY.
04 Cause-Code PIC S9(4) BINARY.
03 Case-Sev-Ctl PIC X.
03 Facility-ID PIC XXX.
02 I-S-Info PIC S9(9) BINARY.
01 MSGAREA PIC X(80).
PROCEDURE DIVISION.
0001-BEGIN-PROCESSING.
DISPLAY "**************************************".
DISPLAY "CE92MSG COBOL Example is now in motion. ".
DISPLAY "**************************************".
MOVE 80 TO Vstring-length of MSGSTR.
MOVE "The following error message, CEE0260S, is expected:"
TO Vstring-text of MSGSTR.
MOVE 2 TO MSGDEST.
**************************************************************
** Call CEEMOUT to put out informational message. **
**************************************************************
CALL "CEEMOUT" USING MSGSTR , MSGDEST , FC.
IF NOT CEE000 of FC THEN
DISPLAY "Error " Msg-No of FC
" in issuing header message"
STOP RUN
END-IF.
**************************************************************
** Set up token fields for creation of a condition token **
**************************************************************
MOVE 3 TO SEV.
MOVE 260 TO MSGNO.
MOVE 1 TO CASE.
MOVE 3 TO SEV2.
MOVE 1 TO CNTRL.
MOVE "CEE" TO FACID.
MOVE 0 TO ISINFO.
**************************************************************
** Call CEENCOD to construct a condition token **
**************************************************************
CALL "CEENCOD" USING SEV, MSGNO, CASE, SEV2, CNTRL,
FACID, ISINFO, CTOK, FC. IF CEE000 of FC THEN
MOVE 0 TO MSGINDX
MOVE SPACES TO MSGAREA
**************************************************************
** Call CEEMGET to retrieve message 260. Since **
** message 260 is longer than the length of MSGAREA, **
** a PERFORM statement loop is used to call CEEMGET **
** multiple times until the message index is zero. **
**************************************************************
PERFORM TEST AFTER UNTIL( MSGINDX = 0 )
CALL "CEEMGET" USING CTOK, MSGAREA, MSGINDX, MGETFC
IF (MGETFC NOT = LOW-VALUE) THEN
**************************************************************
* Call CEEDCOD to decode CEEMGET's feedback token **
**************************************************************
CALL "CEEDCOD" USING MGETFC, SEV, MSGNO,
CASE, SEV2, CNTRL, FACID, ISINFO, FC
IF NOT CEE000 of FC THEN
**************************************************************
* Call CEEMSG to output LE error message **
* using feedback code from CEEDCOD call. **
**************************************************************
CALL "CEEMSG" USING MGETFC, MSGDEST, FC
IF NOT CEE000 of FC THEN
DISPLAY "Error " Msg-No of FC
" from CEEMSG after error in CEEDCOD"
END-IF
STOP RUN
END-IF
**************************************************************
* If decoded message number is not 455, **
* then CEEMGET actually failed with error. **
**************************************************************
IF ( Msg-No of MGETFC NOT = 455) THEN
DISPLAY "Error " Msg-No of MGETFC
" retrieving message CEE0260S"
STOP RUN
END-IF
END-IF
**************************************************************
* Call CEEMOUT to output earch portion of message 260 **
**************************************************************
MOVE MSGAREA TO Vstring-text of MSGSTR
CALL "CEEMOUT" USING MSGSTR , MSGDEST , FC
IF (MSGINDX = ZERO) THEN
DISPLAY "**************************************"
DISPLAY " COBOL message example program ended."
DISPLAY "**************************************"
END-IF
END-PERFORM
ELSE
DISPLAY "Error " Msg-No of FC
" in encoding condition token"
STOP RUN
END-IF.
GOBACK.