PROCESS TRUNC(BIN)
       IDENTIFICATION DIVISION.
       PROGRAM-ID.    DTADKDPL.
      **************************************************************
      *
      * This program uses the Dynatrace CICS tagging ADK to start a
      * CICS Purepath and then DPL LINK to a specified application
      * program. It is intended to permit a customer to add a tag to
      * the COMMAREA with no changes to the original application
      * program.
      *
      * Format of extended COMMAREA:
      *
      * Length   Format Contents
      * Variable Any    COMMAREA to pass to the applicaton program
      * Variable Any    Dynatrace string tag(1)
      * 8        Char   Name of the application program to LINK to
      * 2        Binary Length of COMMAREA passed to the application
      *
      * (1) Replace the call to DTSLPTF below with DTSCLPA for custom
      * tags or DTSLPA for Dynatrace standard binary tags.
      *
      * Note: Binary values must be in network byte order.
      *       Character values, including string tags, must be EBCDIC.
      *       Custom tags are considered to be binary values.
      *
      **************************************************************
       DATA DIVISION.
       WORKING-STORAGE SECTION.

       77  APPL-FLD-LEN        PIC S9(9)   USAGE COMP VALUE 10.
       77  APPL-OFFSET         PIC S9(9)   USAGE COMP.
       77  WS-CA-LENGTH        PIC S9(4)   USAGE COMP.
       77  TAG-OFFSET          PIC S9(9)   USAGE COMP.
       77  TAG-LENGTH          PIC S9(9)   USAGE COMP.
       77  RETCODE             PIC S9(9)   USAGE COMP.
       77  MSG-TAG             PIC X(29)   VALUE
               "DTADKDPL: INVALID TAG LENGTH.".
       77  MSG-COMMAREA        PIC X(29)   VALUE
               "DTADKDPL: COMMAREA TOO SHORT.".
       01  MSG-API.
           05  FILLER          PIC X(50) VALUE
               "DTADKDPL: DTSLPTF request failed with return code ".
           05  MSG-RC          PIC ZZ9.

       LINKAGE SECTION.

       01  DFHCOMMAREA.
           05  CA-BYTES        PIC X       OCCURS 32768 TIMES.

       01  TAG-FIELDS.
           05  TAG-BYTES       PIC X(200).

       01  APPL-FIELDS.
           05  PROGRAM-NAME    PIC X(8).
           05  APPL-CA-LENGTH  PIC S9(4)   USAGE COMP.

       PROCEDURE DIVISION.

           IF EIBCALEN < APPL-FLD-LEN
               EXEC CICS WRITE OPERATOR TEXT(MSG-COMMAREA) END-EXEC
               EXEC CICS RETURN END-EXEC
           ELSE
               COMPUTE WS-CA-LENGTH = EIBCALEN - APPL-FLD-LEN
      *
      *        NOTE: COBOL subscripts start at 1 so the last 10
      *        bytes start at byte COMMAREA length - 10 + 1.
      *
               COMPUTE APPL-OFFSET = EIBCALEN - APPL-FLD-LEN + 1
               SET ADDRESS OF APPL-FIELDS
                   TO ADDRESS OF CA-BYTES(APPL-OFFSET)
               COMPUTE TAG-OFFSET = APPL-CA-LENGTH + 1
               SET ADDRESS OF TAG-FIELDS
                   TO ADDRESS OF CA-BYTES(TAG-OFFSET)
      *        Remove the -1 below for custom or binary tags or when
      *        the client doesn't send a null byte with string tags.
               COMPUTE TAG-LENGTH = WS-CA-LENGTH - APPL-CA-LENGTH - 1
               IF TAG-LENGTH > 0 AND TAG-LENGTH < 201
                   MOVE APPL-CA-LENGTH TO WS-CA-LENGTH
               ELSE
                   EXEC CICS WRITE OPERATOR TEXT(MSG-TAG) END-EXEC
                   MOVE 0 TO TAG-LENGTH
               END-IF
           END-IF.

           IF TAG-LENGTH > 0
               CALL "DTSLPTF" USING TAG-BYTES, TAG-LENGTH,
                   RETURNING RETCODE
               IF RETCODE > 0
                   MOVE RETCODE TO MSG-RC
                   EXEC CICS WRITE OPERATOR TEXT(MSG-API) END-EXEC
               END-IF
           END-IF.

           EXEC CICS LINK PROGRAM(PROGRAM-NAME)
               COMMAREA(DFHCOMMAREA) LENGTH(WS-CA-LENGTH)
           END-EXEC.

           EXEC CICS RETURN END-EXEC.