           EJECT
      ***************************************************************
      *                                                             *
      *   THESE ARE COMMON SUBROUTINES TO HANDLE ERROR CONDITIONS   *
      *   FOR DB2 AND CICS PROCESSES.                               *
      *                                                             *
      ***************************************************************
           SKIP1
       Z900-DB2-CHECK.

           MOVE CA-PARAGRAPH-NBR TO DB2-PARAGRAPH-NBR.
           MOVE SQLCODE          TO DB2-SQL-RETURN-CODE.

           EVALUATE TRUE
               WHEN DB2-NORMAL
                    CONTINUE
               WHEN DB2-END-OF-FILE
                    IF OPEN-O-CLOSE-CURSOR OR
                       NORMAL-RC-ONLY
                       PERFORM Z900-DB2-ERROR
                    END-IF
               WHEN DB2-RECORD-NOT-FOUND
                    IF OPEN-O-CLOSE-CURSOR OR
                       NORMAL-RC-ONLY
                       PERFORM Z900-DB2-ERROR
                    END-IF
               WHEN DB2-DUPLICATE-KEY
                    IF DUP-KEY
                       NEXT SENTENCE
                    ELSE
                       PERFORM Z900-DB2-ERROR
                    END-IF
               WHEN DB2-MULTIPLE-ROWS
                    IF MULTIPLE-ROWS
                       NEXT SENTENCE
                    ELSE
                       PERFORM Z900-DB2-ERROR
                    END-IF
               WHEN DB2-NULL-VALUE-RETURN
                    IF NULL-VALUE
                       NEXT SENTENCE
                    ELSE
                       PERFORM Z900-DB2-ERROR
                    END-IF
               WHEN DB2-FATAL-ERROR
                       PERFORM Z900-DB2-ERROR
           END-EVALUATE.

           SET NORMAL-RC TO TRUE.

       Z900-DB2-ERROR.
           MOVE DB2-PARAGRAPH-NBR TO DB2-MSG-PARA-NBR.
           MOVE DB2-SQL-RETURN-CODE TO DB2-MSG-SQLCODE
           MOVE SQLERRMC            TO DB2-MESSAGE-SQLERRMC.
           MOVE DB2-MESSAGE-AREA    TO M-MSG-24I.

           PERFORM Z900-HANDLE-ERROR.

      *
       Z900-HANDLE-ERROR.
      *

           INITIALIZE CICS-FATAL-MESSAGE-AREA.

           MOVE CA-PARAGRAPH-NBR
             TO CICS-FATAL-PARA-NBR.

           PERFORM Y600-ROLLBACK.

           MOVE PROGRAM-NAME
             TO CICS-FATAL-PROGRAM.

           MOVE EIBTRNID
             TO CICS-FATAL-TRAN-ID.

           MOVE DB2-SQL-RETURN-CODE
             TO CICS-FATAL-SQLCODE.

           MOVE SQLERRMC
             TO CICS-FATAL-SQLERRMC.

           MOVE EIBERR      TO CFM-EIBERR.
           MOVE EIBERRCD    TO CFM-EIBERRCD.
           MOVE EIBFN       TO CFM-EIBFN.
           MOVE EIBRCODE    TO CFM-EIBRCODE.
           MOVE EIBRSRCE    TO CFM-EIBRSRCE.
           MOVE EIBTRMID    TO CFM-EIBTRMID.
           MOVE EIBTRNID    TO CFM-EIBTRNID.
           MOVE EIBDATE     TO CFM-EIBDATE.
           MOVE EIBTIME     TO CFM-EIBTIME.
           MOVE EIBRESP     TO CFM-EIBRESP.
           MOVE EIBRESP     TO CICS-EIBRESP.

           PERFORM VARYING CICS-EIB-X FROM 1 BY 1
                     UNTIL CICS-EIB-X > 90
                        OR EIB-ERROR-CODE(CICS-EIB-X) = CICS-EIBRESP
           END-PERFORM.

           IF  EIB-ERROR-CODE(CICS-EIB-X) = CICS-EIBRESP
               MOVE EIB-MSG-OUT(CICS-EIB-X)
                 TO CFM-EIBMSG-OUT
           END-IF.

           MOVE CICS-FATAL-MESSAGE-AREA
             TO W9999-END-MESSAGE.

           PERFORM Y400-RETURN-TO-CICS.

