From f67d330f3138733cb1e3426d467c42debf4974fe Mon Sep 17 00:00:00 2001 From: Joseph Walther Date: Sat, 28 Feb 2026 17:28:23 -0600 Subject: [PATCH] COBOL Stub and REXX driver method --- .../C1UEXT07-old-version.cob | 653 +++++++++ .../Package-Automation/C1UEXT07.cob | 1305 ++++++++--------- .../Package-Automation/C1UEXTR7.rex | 747 ++++++++++ .../Package-Automation/README.md | 32 +- 4 files changed, 2060 insertions(+), 677 deletions(-) create mode 100644 endevor/Field-Developed-Programs/Package-Automation/C1UEXT07-old-version.cob create mode 100644 endevor/Field-Developed-Programs/Package-Automation/C1UEXTR7.rex diff --git a/endevor/Field-Developed-Programs/Package-Automation/C1UEXT07-old-version.cob b/endevor/Field-Developed-Programs/Package-Automation/C1UEXT07-old-version.cob new file mode 100644 index 0000000..12722ee --- /dev/null +++ b/endevor/Field-Developed-Programs/Package-Automation/C1UEXT07-old-version.cob @@ -0,0 +1,653 @@ + PROCESS DYNAM OUTDD(DISPLAYS) + IDENTIFICATION DIVISION. + PROGRAM-ID. C1UEXT07. + + ************************************************************ + * DESCRIPTION: THIS PACKAGE EXIT PROGRAM WILL: * + * 1) Performs Automated Package Executions * + * by calling REXX subroutine PKGEXECT * + * 2) Performs Automated Package Shipping * + * by calling REXX subroutine PKGESHIP * + * https://github.com/BroadcomMFD/broadcom-product-scripts + ************************************************************ + * THESE ROUTINES ARE DISTRIBUTED BY THE CA STAFF "AS IS". + * NO WARRANTY, EITHER EXPRESSED OR IMPLIED, IS MADE FOR THEM. + * COMPUTER ASSOCIATES CANNOT GUARANTEE THAT THE ROUTINES ARE + * ERROR FREE, OR THAT IF ERRORS ARE FOUND, THEY WILL BE CORRECTED. + ************************************************************ + + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + ** + DATA DIVISION. + FILE SECTION. + + WORKING-STORAGE SECTION. + + 01 WS-DATE-VARIABLES. + 03 WS-DATE-TO-CONVERT PIC X(07). + 03 WS-DATE-CONVERTED. + 05 WS-DATE-CENTURY PIC 9(02). + 05 WS-DATE-YEAR PIC 9(02). + 05 WS-DATE-MONTH PIC 9(02). + 05 WS-DATE-DAY PIC 9(02). + 03 WS-DATE-OF-RUN PIC 9(06). + 03 WS-DOR REDEFINES WS-DATE-OF-RUN. + 05 WS-DOR-YEAR PIC 9(02). + 05 WS-DOR-MONTH PIC 9(02). + 05 WS-DOR-DAY PIC 9(02). + + 03 WS-RUN-DATE PIC 9(06). + 03 FILLER REDEFINES WS-RUN-DATE. + 05 WS-RUN-DATE-YEAR PIC 9(02). + 05 WS-RUN-DATE-MONTH PIC 9(02). + 05 WS-RUN-DATE-DAY PIC 9(02). + + 03 WS-TIME-OF-RUN PIC 9(08). + 03 FILLER REDEFINES WS-TIME-OF-RUN. + 05 WS-TOR. + 10 WS-TOR-HOUR PIC 9(02). + 10 WS-TOR-MINUTE PIC 9(02). + 05 FILLER PIC 9(04). + + 03 WS-RUN-TIME PIC 9(04). + 03 FILLER REDEFINES WS-RUN-TIME. + 05 WS-RUN-TIME-HOUR PIC 9(02). + 05 WS-RUN-TIME-MINUTE PIC 9(02). + + 03 WS-PACKAGE-DATE. + 10 WS-PKG-DAY PIC 9(02). + 10 WS-PKG-MONTH PIC X(03). + 10 WS-PKG-YEAR PIC 9(02). + + 03 WS-PKG-START-DATE. + 10 WS-PKG-START-YEAR PIC 9(02). + 10 WS-PKG-START-MONTH PIC 9(02). + 10 WS-PKG-START-DAY PIC 9(02). + + 03 WS-PKG-END-DATE. + 10 WS-PKG-END-YEAR PIC 9(02). + 10 WS-PKG-END-MONTH PIC 9(02). + 10 WS-PKG-END-DAY PIC 9(02). + + 03 WS-PACKAGE-TIME. + 10 WS-PKG-HOUR PIC 9(02). + 10 FILLER PIC X(01). + 10 WS-PKG-MINUTE PIC 9(02). + + 03 WS-PKG-START-TIME. + 10 WS-PKG-START-HOUR PIC 9(02). + 10 WS-PKG-START-MINUTE PIC 9(02). + + 03 WS-PKG-END-TIME. + 10 WS-PKG-END-HOUR PIC 9(02). + 10 WS-PKG-END-MINUTE PIC 9(02). + + 01 WS-MONTHS-TABLE. + 03 FILLER PIC X(36) + VALUE 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC' . + 01 WS-MONTHS-TABLE-RE REDEFINES WS-MONTHS-TABLE. + 03 WS-MONTH OCCURS 12 TIMES INDEXED BY WS-MONTH-INX + PIC X(03). + 01 WS-VARIABLES. + 03 WS-SUBMIT-SWITCH PIC X(01) VALUE 'N'. + 88 SUBMIT-OK VALUE 'S'. + 88 DO-NOT-SUBMIT VALUE 'N'. + 03 WS-TIME PIC 9(8). + 03 WS-PACKAGE-VARIABLE PIC X(01). + 03 WS-JOBCARD-ID PIC X(07) VALUE SPACES. + 03 ME PIC X(07) VALUE 'XALJO11'. + 03 ADMIN1 PIC X(01) VALUE 'P'. + 03 ADMIN2 PIC X(01) VALUE 'T'. + 03 WS-TALLY PIC 9(4) VALUE 0000. + + 01 BPXWDYN PIC X(8) VALUE 'BPXWDYN'. + 01 ALLOC-STRING. + 05 ALLOC-LENGTH PIC S9(4) BINARY VALUE 100. + 05 ALLOC-TEXT PIC X(100). + + 01 IRXJCL PIC X(6) VALUE 'IRXJCL'. + 01 IRXEXEC-PGM PIC X(08) VALUE 'IRXEXEC'. + + * + * DEFINE THE IRXEXEC DATA AREAS AND ARG BLOCKS + * + 77 FLAGS PIC S9(8) BINARY. + 77 REXX-RETURN-CODE PIC S9(8) BINARY. + 77 DUMMY-ZERO PIC S9(8) BINARY. + 77 LPAR-ID PIC X(04). + 88 DO-NOT-PROCESS-LPAR VALUE 'SKIP'. + 77 ARG1 PIC X(16). + 77 UPDPRINT-FILE-STATUS PIC X(02). + 77 ARGUMENT-PTR POINTER. + 77 EXECBLK-PTR POINTER. + 77 ARGTABLE-PTR POINTER. + 77 EVALBLK-PTR POINTER. + 77 TEMP-PTR POINTER. + + 01 EXECBLK. + 05 EXECBLK-ACRYN PIC X(08) VALUE 'IRXEXECB'. + 05 EXECBLK-LENGTH PIC S9(8) BINARY + VALUE 48. + 05 EXECBLK-RESERVED PIC S9(8) BINARY + VALUE 0. + 05 EXECBLK-MEMBER PIC X(08) VALUE 'PKGEXECT'. + 05 EXECBLK-DDNAME PIC X(08) VALUE 'REXFILE7'. + 05 EXECBLK-SUBCOM PIC X(08) VALUE SPACES. + 05 EXECBLK-DSNPTR POINTER VALUE NULL. + 05 EXECBLK-DSNLEN PIC 9(04) COMP + VALUE 0. + + 01 EVALBLK. + 05 EVALBLK-EVPAD1 PIC S9(8) BINARY + VALUE 0. + 05 EVALBLK-EVSIZE PIC S9(8) BINARY + VALUE 34. + 05 EVALBLK-EVLEN PIC S9(8) BINARY + VALUE 0. + 05 EVALBLK-EVPAD2 PIC S9(8) BINARY + VALUE 0. + 05 EVALBLK-EVDATA PIC X(256). + + 01 ARGUMENT. + 02 ARGUMENT-1 OCCURS 1 TIMES. + 05 ARGSTRING-PTR POINTER. + 05 ARGSTRING-LENGTH PIC S9(8) BINARY. + 02 ARGSTRING-LAST1 PIC S9(8) BINARY + VALUE -1. + 02 ARGSTRING-LAST2 PIC S9(8) BINARY + VALUE -1. + + * The block of data below can be used with either an + * IRXJCL or IRXEXEC call to the rexx program PKGEXECT. + * IRXJCL is used when running in batch (batch CAST) . + * IRXEXEC is used when running in foreground (CAST or APPROVE). + 01 PKG-EXECUTE-PARMS-IRXJCL. + 02 PKG-EXECUTE-PARMS-IRXJCL-TOP. + 03 PARM-LENGTH PIC X(2) VALUE X'0114'. + 03 REXX-NAME PIC X(8) VALUE 'PKGEXECT'. + 03 FILLER PIC X(1) VALUE SPACE . + 02 PKG-EXECUTE-PARMS-IRXEXEC. + 03 REXX-EXEC-PACKAGE PIC X(16) . + 03 FILLER PIC X(1) VALUE SPACE . + 03 REXX-EXEC-ENV PIC X(08) . + 03 FILLER PIC X(1) VALUE SPACE . + 03 REXX-EXEC-STGID PIC X(01) . + 03 REXX-EXEC-MODE PIC X(01) . + 03 REXX-EXE-CREATE-USER PIC X(08) . + 03 REXX-EXE-UPDATE-USER PIC X(08) . + 03 REXX-EXE-CAST-USER PIC X(08) . + 03 REXX-EXEC-COMMENT PIC X(50) . + + * The block of data below can be used for submitting pkg shipments + * IRXJCL is always used since executions are always in batch. + 01 PKG-SHIPMENT-PARMS-IRXJCL. + 02 PKG-SHIPMENT-PARMS-IRXJCL-TOP. + 03 PARM-LENGTH PIC X(2) VALUE X'0253'. + 03 REXX-NAME PIC X(8) VALUE 'PKGESHIP'. + 03 FILLER PIC X(1) VALUE SPACE . + 02 PKG-SHIPMENT-PARMS. + 03 REXX-SHIP-PACKAGE PIC X(16) . + 03 FILLER PIC X(1) VALUE SPACE . + 03 REXX-SHIP-ENV PIC X(08) . + 03 FILLER PIC X(1) VALUE SPACE . + 03 REXX-SHIP-STGID PIC X(01) . + 03 FILLER PIC X(1) VALUE SPACE . + 03 REXX-SHIP-COMMENT PIC X(50) . + 03 REXX-SHIP-CREATE-USR PIC X(08) . + 03 REXX-SHIP-UPDATE-USR PIC X(08) . + 03 REXX-SHIP-CAST-USER PIC X(08) . + 03 FILLER PIC X(1) VALUE SPACE . + 03 REXX-SHIP-NOTE1 PIC X(60) . + 03 REXX-SHIP-NOTE2 PIC X(60) . + 03 REXX-SHIP-NOTE3 PIC X(60) . + 03 REXX-SHIP-NOTE4 PIC X(60) . + 03 REXX-SHIP-NOTE5 PIC X(60) . + 03 REXX-SHIP-NOTE6 PIC X(60) . + 03 REXX-SHIP-NOTE7 PIC X(60) . + 03 REXX-SHIP-NOTE8 PIC X(60) . + 03 REXX-SHIP-OUT PIC X(03) . + + LINKAGE SECTION. + COPY PKGXBLKS. + + PROCEDURE DIVISION USING + PACKAGE-EXIT-BLOCK + PACKAGE-REQUEST-BLOCK + PACKAGE-EXIT-HEADER-BLOCK + PACKAGE-EXIT-FILE-BLOCK + PACKAGE-EXIT-ACTION-BLOCK + PACKAGE-EXIT-APPROVER-MAP + PACKAGE-EXIT-BACKOUT-BLOCK + PACKAGE-EXIT-SHIPMENT-BLOCK + PACKAGE-EXIT-SCL-BLOCK. + **** + **** + +******* DISPLAY 'C1UEXT07: GOT INTO EXIT 7' . + ACCEPT WS-DATE-OF-RUN FROM DATE. + ACCEPT WS-TIME-OF-RUN FROM TIME. + MOVE WS-DOR-YEAR TO WS-RUN-DATE-YEAR. + MOVE WS-DOR-MONTH TO WS-RUN-DATE-MONTH. + MOVE WS-DOR-DAY TO WS-RUN-DATE-DAY. + MOVE WS-TOR-HOUR TO WS-RUN-TIME-HOUR. + MOVE WS-TOR-MINUTE TO WS-RUN-TIME-MINUTE. + + IF SETUP-EXIT-OPTIONS +********* to support automated package shipping + MOVE 'Y' TO PECB-AFTER-EXEC + MOVE 'Y' TO PECB-REQ-ELEMENT-ACTION-BIBO + MOVE 'Y' TO PECB-AFTER-BACKOUT + MOVE 'Y' TO PECB-AFTER-BACKIN +********* to enforce package backout = Y +********* MOVE 'Y' TO PECB-BEFORE-CAST +********* MOVE 'Y' TO PECB-MID-CAST + MOVE 'Y' TO PECB-BEFORE-CREATE-BLD + MOVE 'Y' TO PECB-BEFORE-CREATE-COPY + MOVE 'Y' TO PECB-BEFORE-CREATE-EDIT + MOVE 'Y' TO PECB-BEFORE-CREATE-IMPT + MOVE 'Y' TO PECB-BEFORE-MOD-BLD + MOVE 'Y' TO PECB-BEFORE-MOD-CPY + MOVE 'Y' TO PECB-BEFORE-MOD-EDIT + MOVE 'Y' TO PECB-BEFORE-MOD-IMPT +********* to support submission of package Execute jobs + MOVE 'Y' TO PECB-AFTER-REV-APPR + MOVE 'Y' TO PECB-AFTER-CAST + MOVE ZEROS TO RETURN-CODE + GO TO 100-MAIN-EXIT. + + MOVE 0 TO PECB-NDVR-EXIT-RC. + +** *******====---> SUBMIT PACKAGE SHIPMENT JOBS + IF (EXECUTE-PACKAGE AND + PHDR-PACKAGE-STATUS(1:4) = 'EXEC') + OR (BACK-OUT-PACKAGE AND PECB-AFTER ) + OR (BACK-IN-PACKAGE AND PECB-AFTER ) + PERFORM 800-SUBMIT-PACKAGE-SHIPMENTS + GO TO 100-MAIN-EXIT. + + IF CAST-PACKAGE AND PECB-AFTER AND + PHDR-PACKAGE-STATUS = 'APPROVED' +******* DISPLAY 'PERFORM 599-CHECK-SUBMIT-DATES' + PERFORM 599-CHECK-SUBMIT-DATES + IF SUBMIT-OK +******* DISPLAY 'PERFORM 600-SUBMIT-PACKAGE-AUTOMATION' + IF PECB-BATCH-MODE + MOVE SPACES TO ALLOC-TEXT + PERFORM 2100-ALLOCATE-REXFILE + END-IF + PERFORM 600-SUBMIT-PACKAGE-AUTOMATION + PERFORM 2100-ALLOCATE-REXFILE + GO TO 100-MAIN-EXIT + ELSE + GO TO 100-MAIN-EXIT. + + IF REVIEW-PACKAGE AND PECB-AFTER AND + PHDR-PACKAGE-STATUS = 'APPROVED' + PERFORM 599-CHECK-SUBMIT-DATES + IF SUBMIT-OK + IF PECB-BATCH-MODE + MOVE SPACES TO ALLOC-TEXT + PERFORM 2100-ALLOCATE-REXFILE + END-IF + PERFORM 600-SUBMIT-PACKAGE-AUTOMATION + GO TO 100-MAIN-EXIT + ELSE + GO TO 100-MAIN-EXIT. + +******* DISPLAY 'C1UEXT07: PHDR-PACKAGE-STATUS=' +******* PHDR-PACKAGE-STATUS. + + IF PREQ-BACKOUT-ENABLED NOT = 'Y' + MOVE 'Y' TO PREQ-BACKOUT-ENABLED + MOVE 4 TO PECB-NDVR-EXIT-RC + MOVE 'Y' TO PECB-MODS-MADE-TO-PREQ + DISPLAY 'C1UEXT07: Package Backout is Enforced' + END-IF. + + 100-MAIN-EXIT. +******* DISPLAY 'C1UEXT07: GOING BACK ' + + GOBACK. + + + 599-CHECK-SUBMIT-DATES. + + ACCEPT WS-DATE-OF-RUN FROM DATE + ACCEPT WS-TIME-OF-RUN FROM TIME + MOVE WS-DOR-YEAR TO WS-RUN-DATE-YEAR + MOVE WS-DOR-MONTH TO WS-RUN-DATE-MONTH + MOVE WS-DOR-DAY TO WS-RUN-DATE-DAY + MOVE WS-TOR-HOUR TO WS-RUN-TIME-HOUR + MOVE WS-TOR-MINUTE TO WS-RUN-TIME-MINUTE + + MOVE PHDR-PKG-EXEC-STRT-DATE TO WS-DATE-TO-CONVERT + PERFORM 700-CONVERT-DATE-CONVERT + MOVE WS-DATE-YEAR TO WS-PKG-START-YEAR + MOVE WS-DATE-MONTH TO WS-PKG-START-MONTH + MOVE WS-DATE-DAY TO WS-PKG-START-DAY + + MOVE PHDR-PKG-EXEC-END-DATE TO WS-DATE-TO-CONVERT + PERFORM 700-CONVERT-DATE-CONVERT + MOVE WS-DATE-YEAR TO WS-PKG-END-YEAR + MOVE WS-DATE-MONTH TO WS-PKG-END-MONTH + MOVE WS-DATE-DAY TO WS-PKG-END-DAY + + MOVE PHDR-PKG-EXEC-STRT-TIME TO WS-PACKAGE-TIME + MOVE WS-PKG-HOUR TO WS-PKG-START-HOUR + MOVE WS-PKG-MINUTE TO WS-PKG-START-MINUTE + + MOVE PHDR-PKG-EXEC-END-TIME TO WS-PACKAGE-TIME + MOVE WS-PKG-HOUR TO WS-PKG-END-HOUR + MOVE WS-PKG-MINUTE TO WS-PKG-END-MINUTE + + IF PECB-USER-BATCH-JOBNAME(1:7) = ME + DISPLAY 'C1UEXT07: USING THESE DATES' + DISPLAY 'RUN DATE: ' WS-RUN-DATE + ' TIME: ' WS-RUN-TIME + DISPLAY 'START DATE: ' WS-PKG-START-DATE + ' TIME: ' WS-PKG-START-TIME + DISPLAY 'END DATE: ' WS-PKG-END-DATE + ' TIME: ' WS-PKG-END-TIME + END-IF + + SET SUBMIT-OK TO TRUE + IF WS-PKG-START-DATE > WS-RUN-DATE + SET DO-NOT-SUBMIT TO TRUE + END-IF + + IF WS-PKG-START-DATE = WS-RUN-DATE + AND WS-PKG-START-TIME > WS-RUN-TIME + SET DO-NOT-SUBMIT TO TRUE + END-IF + + IF WS-PKG-END-DATE < WS-RUN-DATE + SET DO-NOT-SUBMIT TO TRUE + END-IF + + IF WS-PKG-END-DATE = WS-RUN-DATE + AND WS-PKG-END-TIME < WS-RUN-TIME + SET DO-NOT-SUBMIT TO TRUE + END-IF + + IF PECB-USER-BATCH-JOBNAME(1:7) = ME + DISPLAY 'C1UEXT07: SUBMIT SWITCH: ' WS-SUBMIT-SWITCH + END-IF + . + 600-SUBMIT-PACKAGE-AUTOMATION. + + * MAKES A CALL TO THE REXX ROUTINE PKGEXECT. + * THE REXX ROUTINE PKGEXECT SUBMITS PACKAGE SHIPMENT JOBS. + * THE REXX ROUTINE PKGEXECT SUBMITS PACKAGE SHIPMENT JOBS. + +****** IF PECB-USER-BATCH-JOBNAME(1:7) = ME +****** DISPLAY 'C1UEXT07: SUBMITTING PACKAGE ' +****** PECB-PACKAGE-ID +****** DISPLAY 'C1UEXT07: PHDR-PKG-ENV ' PHDR-PKG-ENV +****** DISPLAY 'C1UEXT07: PHDR-PKG-STGID' PHDR-PKG-STGID +****** END-IF + + MOVE PECB-PACKAGE-ID TO REXX-EXEC-PACKAGE + MOVE PHDR-PKG-ENV TO REXX-EXEC-ENV + MOVE PHDR-PKG-STGID TO REXX-EXEC-STGID + MOVE PECB-MODE TO REXX-EXEC-MODE + MOVE PHDR-PKG-CREATE-USER TO REXX-EXE-CREATE-USER + MOVE PHDR-PKG-UPDATE-USER TO REXX-EXE-UPDATE-USER + MOVE PHDR-PKG-CAST-USER TO REXX-EXE-CAST-USER + MOVE PREQ-PACKAGE-COMMENT TO REXX-EXEC-COMMENT + MOVE 'PKGEXECT' TO EXECBLK-MEMBER . + MOVE 102 TO ARGSTRING-LENGTH(1) + +******** +******** IF PECB-TSO-MODE +******** DISPLAY 'C1UEXT07: IN TSO FOREGROUND ' +******** CALL 'SET-ARG1-POINTER' USING ARGUMENT-PTR +******** PKG-EXECUTE-PARMS-IRXEXEC +******** PERFORM 1800-REXX-CALL-VIA-IRXEXEC +******** ELSE +******** DISPLAY 'C1UEXT07: NOT IN TSO FOREGROUND ' + CALL IRXJCL USING PKG-EXECUTE-PARMS-IRXJCL . + + + IF RETURN-CODE NOT = 0 + DISPLAY 'C1UEXT07: BAD CALL TO IRXJCL - RC = ' + RETURN-CODE + END-IF + + MOVE 0 TO RETURN-CODE + . + 700-CONVERT-DATE-CONVERT. + + SET WS-MONTH-INX TO 1. + SEARCH WS-MONTH VARYING WS-MONTH-INX + AT END MOVE 00 TO WS-DATE-MONTH + WHEN WS-MONTH(WS-MONTH-INX) = WS-DATE-TO-CONVERT(3:3) + SET WS-DATE-MONTH TO WS-MONTH-INX + END-SEARCH + + MOVE WS-DATE-TO-CONVERT (1:2) TO WS-DATE-DAY + MOVE WS-DATE-TO-CONVERT (6:2) TO WS-DATE-YEAR + MOVE '20' TO WS-DATE-CENTURY + . + 800-SUBMIT-PACKAGE-SHIPMENTS. + + * MAKES A CALL TO THE REXX ROUTINE PKGESHIP + * THE REXX ROUTINE PKGESHIP SUBMITS PACKAGE SHIPMENT JOBS + + * Package Shipments may occur in batch only + * As a result, IRXJCL will be always be used to + * submit the package Shipment jobs. + +******* IF PECB-USER-BATCH-JOBNAME(1:7) = 'IBMUSER' +******* DISPLAY 'C1UEXT07: SHIPPING PACKAGE ' +******* PECB-PACKAGE-ID +******* DISPLAY 'C1UEXT07: PHDR-PKG-ENV ' PHDR-PKG-ENV +******* DISPLAY 'C1UEXT07: PHDR-PKG-STGID' PHDR-PKG-STGID +******* END-IF + + PERFORM 2100-ALLOCATE-REXFILE. + + MOVE PECB-PACKAGE-ID TO REXX-SHIP-PACKAGE + MOVE PHDR-PKG-ENV TO REXX-SHIP-ENV + MOVE PHDR-PKG-STGID TO REXX-SHIP-STGID + MOVE PREQ-PACKAGE-COMMENT TO REXX-SHIP-COMMENT + MOVE PHDR-PKG-CREATE-USER TO REXX-SHIP-CREATE-USR + MOVE PHDR-PKG-UPDATE-USER TO REXX-SHIP-UPDATE-USR + MOVE PHDR-PKG-CAST-USER TO REXX-SHIP-CAST-USER + MOVE PHDR-PKG-NOTE1 TO REXX-SHIP-NOTE1 + MOVE PHDR-PKG-NOTE2 TO REXX-SHIP-NOTE2 + MOVE PHDR-PKG-NOTE3 TO REXX-SHIP-NOTE3 + MOVE PHDR-PKG-NOTE4 TO REXX-SHIP-NOTE4 + MOVE PHDR-PKG-NOTE5 TO REXX-SHIP-NOTE5 + MOVE PHDR-PKG-NOTE6 TO REXX-SHIP-NOTE6 + MOVE PHDR-PKG-NOTE7 TO REXX-SHIP-NOTE7 + MOVE PHDR-PKG-NOTE8 TO REXX-SHIP-NOTE8 + IF BACK-OUT-PACKAGE + MOVE 'BAC' TO REXX-SHIP-OUT + ELSE + MOVE 'OUT' TO REXX-SHIP-OUT . + + CALL IRXJCL USING PKG-SHIPMENT-PARMS-IRXJCL. + + MOVE 0 TO RETURN-CODE + . + + + 1800-REXX-CALL-VIA-IRXEXEC. + *--- GET THE ADDRESS OF THE ARGUMENT(S) TO BE PASSED TO IXREXEC + *--- AND LOAD INTO THE ARGUMENT TABLES +******* IF PECB-USER-BATCH-JOBNAME(1:7) = ME +******* DISPLAY 'C1UEXT07: SETTING UP REXX EXECUTION' +******* ' FOR PACKAGE 'PECB-PACKAGE-ID +******* END-IF . + SET ARGSTRING-PTR (1) TO ARGUMENT-PTR . + CALL 'SET-ARGUMENT-POINTER' USING ARGTABLE-PTR + ARGUMENT . + CALL 'SET-EXECBLK-POINTER' USING EXECBLK-PTR + EXECBLK . + CALL 'SET-EVALBLK-POINTER' USING EVALBLK-PTR + EVALBLK . + *--- SET FLAGS TO HEX 20000000 + * I.E. EXEC INVOKED AS SUBROUTINE + MOVE 536870912 TO FLAGS + MOVE 0 TO REXX-RETURN-CODE . + + IF PECB-USER-BATCH-JOBNAME(1:7) = ME + DISPLAY 'C1UEXT07: CALLING IRXEXC ' + PECB-PACKAGE-ID + END-IF . + *--- CALL THE REXX EXEC --- + CALL IRXEXEC-PGM USING EXECBLK-PTR + ARGTABLE-PTR + FLAGS + DUMMY-ZERO + DUMMY-ZERO + EVALBLK-PTR + DUMMY-ZERO + DUMMY-ZERO + DUMMY-ZERO . + + IF REXX-RETURN-CODE NOT = 0 + DISPLAY 'C1UEXT07: IRXEXEC RETURN CODE = ' + REXX-RETURN-CODE + END-IF + + CANCEL IRXEXEC-PGM + . + + 2100-ALLOCATE-REXFILE. + + MOVE SPACES TO ALLOC-TEXT. + + STRING 'ALLOC DD(REXFILE7) ', + 'DA(YOURSITE.NDVR.REXX) SHR REUSE' + DELIMITED BY SIZE + INTO ALLOC-TEXT + END-STRING . + PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . + STRING 'ALLOC DD(SYSEXEC) ', + 'DA(YOURSITE.NDVR.REXX) SHR REUSE' + DELIMITED BY SIZE + INTO ALLOC-TEXT + END-STRING. + PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . + +********** MOVE 'CONCAT DDLIST(REXFILE,REXFILE2)' +********** TO ALLOC-TEXT . +********** +********** PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . + + ***************************************************************** + ** DYNAMICALLY DE-ALLOCATE UNNEEDED REXX FILES + ***************************************************************** + 2200-FREE-REXFILES. + + MOVE 'FREE DD(REXFILE7)' TO ALLOC-TEXT + PERFORM 9000-DYNAMIC-ALLOC-DEALLOC + + MOVE 'FREE DD(SYSEXEC)' TO ALLOC-TEXT + PERFORM 9000-DYNAMIC-ALLOC-DEALLOC + . + ***************************************************************** + ** CALL BPXWDYN TO PREFORM REQUIRED REXX FUNCTIONS + ***************************************************************** + 9000-DYNAMIC-ALLOC-DEALLOC. + + CALL BPXWDYN USING ALLOC-STRING + + IF RETURN-CODE NOT = ZERO + DISPLAY 'C1UEXT07: ALLOCATION FAILED: RETURN CODE = ' + RETURN-CODE + DISPLAY ALLOC-TEXT + END-IF + + MOVE SPACES TO ALLOC-TEXT + . + + + ****************************************************************** + * BEGIN NESTED PROGRAMS USED TO SET THE POINTERS OF DATA AREAS + * THAT ARE BEING PASSED TO IRXEXEC SO THAT A REXX ROUTINE CAN + * PASS DATA (OTHER THAN A RETURN CODE) BACK TO A COBOL PROGRAM. + ****************************************************************** + + ******** SET-ARG1-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-ARG1-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 ARG-PTR POINTER. + 77 ARG1 PIC X(16). + PROCEDURE DIVISION USING ARG-PTR + ARG1. + SET ARG-PTR TO ADDRESS OF ARG1 + GOBACK. + END PROGRAM SET-ARG1-POINTER. + + ******** SET-ARGUMENT-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-ARGUMENT-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 ARGTABLE-PTR POINTER. + 01 ARGUMENT. + 02 ARGUMENT-1 OCCURS 1 TIMES. + 05 ARGSTRING-PTR POINTER. + 05 ARGSTRING-LENGTH PIC S9(8) BINARY. + 02 ARGSTRING-LAST1 PIC S9(8) BINARY. + 02 ARGSTRING-LAST2 PIC S9(8) BINARY. + PROCEDURE DIVISION USING ARGTABLE-PTR + ARGUMENT. + SET ARGTABLE-PTR TO ADDRESS OF ARGUMENT + GOBACK. + END PROGRAM SET-ARGUMENT-POINTER. + + ******** SET-EXECBLK-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-EXECBLK-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 EXECBLK-PTR POINTER. + 01 EXECBLK. + 03 EXECBLK-ACRYN PIC X(8). + 03 EXECBLK-LENGTH PIC 9(4) COMP. + 03 EXECBLK-RESERVED PIC 9(4) COMP. + 03 EXECBLK-MEMBER PIC X(8). + 03 EXECBLK-DDNAME PIC X(8). + 03 EXECBLK-SUBCOM PIC X(8). + 03 EXECBLK-DSNPTR POINTER. + 03 EXECBLK-DSNLEN PIC 9(4) COMP. + PROCEDURE DIVISION USING EXECBLK-PTR + EXECBLK. + SET EXECBLK-PTR TO ADDRESS OF EXECBLK + GOBACK. + END PROGRAM SET-EXECBLK-POINTER. + + ******** SET-EVALBLK-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-EVALBLK-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 EVALBLK-PTR POINTER. + 01 EVALBLK. + 03 EVALBLK-EVPAD1 PIC 9(4) COMP. + 03 EVALBLK-EVSIZE PIC 9(4) COMP. + 03 EVALBLK-EVLEN PIC 9(4) COMP. + 03 EVALBLK-EVPAD2 PIC 9(4) COMP. + 03 EVALBLK-EVDATA PIC X(256). + PROCEDURE DIVISION USING EVALBLK-PTR + EVALBLK. + SET EVALBLK-PTR TO ADDRESS OF EVALBLK + GOBACK. + END PROGRAM SET-EVALBLK-POINTER. + *--- END OF MAIN PROGRAM + END PROGRAM C1UEXT07. diff --git a/endevor/Field-Developed-Programs/Package-Automation/C1UEXT07.cob b/endevor/Field-Developed-Programs/Package-Automation/C1UEXT07.cob index 12722ee..46b280b 100644 --- a/endevor/Field-Developed-Programs/Package-Automation/C1UEXT07.cob +++ b/endevor/Field-Developed-Programs/Package-Automation/C1UEXT07.cob @@ -1,653 +1,652 @@ - PROCESS DYNAM OUTDD(DISPLAYS) - IDENTIFICATION DIVISION. - PROGRAM-ID. C1UEXT07. - - ************************************************************ - * DESCRIPTION: THIS PACKAGE EXIT PROGRAM WILL: * - * 1) Performs Automated Package Executions * - * by calling REXX subroutine PKGEXECT * - * 2) Performs Automated Package Shipping * - * by calling REXX subroutine PKGESHIP * - * https://github.com/BroadcomMFD/broadcom-product-scripts - ************************************************************ - * THESE ROUTINES ARE DISTRIBUTED BY THE CA STAFF "AS IS". - * NO WARRANTY, EITHER EXPRESSED OR IMPLIED, IS MADE FOR THEM. - * COMPUTER ASSOCIATES CANNOT GUARANTEE THAT THE ROUTINES ARE - * ERROR FREE, OR THAT IF ERRORS ARE FOUND, THEY WILL BE CORRECTED. - ************************************************************ - - ENVIRONMENT DIVISION. - INPUT-OUTPUT SECTION. - FILE-CONTROL. - ** - DATA DIVISION. - FILE SECTION. - - WORKING-STORAGE SECTION. - - 01 WS-DATE-VARIABLES. - 03 WS-DATE-TO-CONVERT PIC X(07). - 03 WS-DATE-CONVERTED. - 05 WS-DATE-CENTURY PIC 9(02). - 05 WS-DATE-YEAR PIC 9(02). - 05 WS-DATE-MONTH PIC 9(02). - 05 WS-DATE-DAY PIC 9(02). - 03 WS-DATE-OF-RUN PIC 9(06). - 03 WS-DOR REDEFINES WS-DATE-OF-RUN. - 05 WS-DOR-YEAR PIC 9(02). - 05 WS-DOR-MONTH PIC 9(02). - 05 WS-DOR-DAY PIC 9(02). - - 03 WS-RUN-DATE PIC 9(06). - 03 FILLER REDEFINES WS-RUN-DATE. - 05 WS-RUN-DATE-YEAR PIC 9(02). - 05 WS-RUN-DATE-MONTH PIC 9(02). - 05 WS-RUN-DATE-DAY PIC 9(02). - - 03 WS-TIME-OF-RUN PIC 9(08). - 03 FILLER REDEFINES WS-TIME-OF-RUN. - 05 WS-TOR. - 10 WS-TOR-HOUR PIC 9(02). - 10 WS-TOR-MINUTE PIC 9(02). - 05 FILLER PIC 9(04). - - 03 WS-RUN-TIME PIC 9(04). - 03 FILLER REDEFINES WS-RUN-TIME. - 05 WS-RUN-TIME-HOUR PIC 9(02). - 05 WS-RUN-TIME-MINUTE PIC 9(02). - - 03 WS-PACKAGE-DATE. - 10 WS-PKG-DAY PIC 9(02). - 10 WS-PKG-MONTH PIC X(03). - 10 WS-PKG-YEAR PIC 9(02). - - 03 WS-PKG-START-DATE. - 10 WS-PKG-START-YEAR PIC 9(02). - 10 WS-PKG-START-MONTH PIC 9(02). - 10 WS-PKG-START-DAY PIC 9(02). - - 03 WS-PKG-END-DATE. - 10 WS-PKG-END-YEAR PIC 9(02). - 10 WS-PKG-END-MONTH PIC 9(02). - 10 WS-PKG-END-DAY PIC 9(02). - - 03 WS-PACKAGE-TIME. - 10 WS-PKG-HOUR PIC 9(02). - 10 FILLER PIC X(01). - 10 WS-PKG-MINUTE PIC 9(02). - - 03 WS-PKG-START-TIME. - 10 WS-PKG-START-HOUR PIC 9(02). - 10 WS-PKG-START-MINUTE PIC 9(02). - - 03 WS-PKG-END-TIME. - 10 WS-PKG-END-HOUR PIC 9(02). - 10 WS-PKG-END-MINUTE PIC 9(02). - - 01 WS-MONTHS-TABLE. - 03 FILLER PIC X(36) - VALUE 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC' . - 01 WS-MONTHS-TABLE-RE REDEFINES WS-MONTHS-TABLE. - 03 WS-MONTH OCCURS 12 TIMES INDEXED BY WS-MONTH-INX - PIC X(03). - 01 WS-VARIABLES. - 03 WS-SUBMIT-SWITCH PIC X(01) VALUE 'N'. - 88 SUBMIT-OK VALUE 'S'. - 88 DO-NOT-SUBMIT VALUE 'N'. - 03 WS-TIME PIC 9(8). - 03 WS-PACKAGE-VARIABLE PIC X(01). - 03 WS-JOBCARD-ID PIC X(07) VALUE SPACES. - 03 ME PIC X(07) VALUE 'XALJO11'. - 03 ADMIN1 PIC X(01) VALUE 'P'. - 03 ADMIN2 PIC X(01) VALUE 'T'. - 03 WS-TALLY PIC 9(4) VALUE 0000. - - 01 BPXWDYN PIC X(8) VALUE 'BPXWDYN'. - 01 ALLOC-STRING. - 05 ALLOC-LENGTH PIC S9(4) BINARY VALUE 100. - 05 ALLOC-TEXT PIC X(100). - - 01 IRXJCL PIC X(6) VALUE 'IRXJCL'. - 01 IRXEXEC-PGM PIC X(08) VALUE 'IRXEXEC'. - - * - * DEFINE THE IRXEXEC DATA AREAS AND ARG BLOCKS - * - 77 FLAGS PIC S9(8) BINARY. - 77 REXX-RETURN-CODE PIC S9(8) BINARY. - 77 DUMMY-ZERO PIC S9(8) BINARY. - 77 LPAR-ID PIC X(04). - 88 DO-NOT-PROCESS-LPAR VALUE 'SKIP'. - 77 ARG1 PIC X(16). - 77 UPDPRINT-FILE-STATUS PIC X(02). - 77 ARGUMENT-PTR POINTER. - 77 EXECBLK-PTR POINTER. - 77 ARGTABLE-PTR POINTER. - 77 EVALBLK-PTR POINTER. - 77 TEMP-PTR POINTER. - - 01 EXECBLK. - 05 EXECBLK-ACRYN PIC X(08) VALUE 'IRXEXECB'. - 05 EXECBLK-LENGTH PIC S9(8) BINARY - VALUE 48. - 05 EXECBLK-RESERVED PIC S9(8) BINARY - VALUE 0. - 05 EXECBLK-MEMBER PIC X(08) VALUE 'PKGEXECT'. - 05 EXECBLK-DDNAME PIC X(08) VALUE 'REXFILE7'. - 05 EXECBLK-SUBCOM PIC X(08) VALUE SPACES. - 05 EXECBLK-DSNPTR POINTER VALUE NULL. - 05 EXECBLK-DSNLEN PIC 9(04) COMP - VALUE 0. - - 01 EVALBLK. - 05 EVALBLK-EVPAD1 PIC S9(8) BINARY - VALUE 0. - 05 EVALBLK-EVSIZE PIC S9(8) BINARY - VALUE 34. - 05 EVALBLK-EVLEN PIC S9(8) BINARY - VALUE 0. - 05 EVALBLK-EVPAD2 PIC S9(8) BINARY - VALUE 0. - 05 EVALBLK-EVDATA PIC X(256). - - 01 ARGUMENT. - 02 ARGUMENT-1 OCCURS 1 TIMES. - 05 ARGSTRING-PTR POINTER. - 05 ARGSTRING-LENGTH PIC S9(8) BINARY. - 02 ARGSTRING-LAST1 PIC S9(8) BINARY - VALUE -1. - 02 ARGSTRING-LAST2 PIC S9(8) BINARY - VALUE -1. - - * The block of data below can be used with either an - * IRXJCL or IRXEXEC call to the rexx program PKGEXECT. - * IRXJCL is used when running in batch (batch CAST) . - * IRXEXEC is used when running in foreground (CAST or APPROVE). - 01 PKG-EXECUTE-PARMS-IRXJCL. - 02 PKG-EXECUTE-PARMS-IRXJCL-TOP. - 03 PARM-LENGTH PIC X(2) VALUE X'0114'. - 03 REXX-NAME PIC X(8) VALUE 'PKGEXECT'. - 03 FILLER PIC X(1) VALUE SPACE . - 02 PKG-EXECUTE-PARMS-IRXEXEC. - 03 REXX-EXEC-PACKAGE PIC X(16) . - 03 FILLER PIC X(1) VALUE SPACE . - 03 REXX-EXEC-ENV PIC X(08) . - 03 FILLER PIC X(1) VALUE SPACE . - 03 REXX-EXEC-STGID PIC X(01) . - 03 REXX-EXEC-MODE PIC X(01) . - 03 REXX-EXE-CREATE-USER PIC X(08) . - 03 REXX-EXE-UPDATE-USER PIC X(08) . - 03 REXX-EXE-CAST-USER PIC X(08) . - 03 REXX-EXEC-COMMENT PIC X(50) . - - * The block of data below can be used for submitting pkg shipments - * IRXJCL is always used since executions are always in batch. - 01 PKG-SHIPMENT-PARMS-IRXJCL. - 02 PKG-SHIPMENT-PARMS-IRXJCL-TOP. - 03 PARM-LENGTH PIC X(2) VALUE X'0253'. - 03 REXX-NAME PIC X(8) VALUE 'PKGESHIP'. - 03 FILLER PIC X(1) VALUE SPACE . - 02 PKG-SHIPMENT-PARMS. - 03 REXX-SHIP-PACKAGE PIC X(16) . - 03 FILLER PIC X(1) VALUE SPACE . - 03 REXX-SHIP-ENV PIC X(08) . - 03 FILLER PIC X(1) VALUE SPACE . - 03 REXX-SHIP-STGID PIC X(01) . - 03 FILLER PIC X(1) VALUE SPACE . - 03 REXX-SHIP-COMMENT PIC X(50) . - 03 REXX-SHIP-CREATE-USR PIC X(08) . - 03 REXX-SHIP-UPDATE-USR PIC X(08) . - 03 REXX-SHIP-CAST-USER PIC X(08) . - 03 FILLER PIC X(1) VALUE SPACE . - 03 REXX-SHIP-NOTE1 PIC X(60) . - 03 REXX-SHIP-NOTE2 PIC X(60) . - 03 REXX-SHIP-NOTE3 PIC X(60) . - 03 REXX-SHIP-NOTE4 PIC X(60) . - 03 REXX-SHIP-NOTE5 PIC X(60) . - 03 REXX-SHIP-NOTE6 PIC X(60) . - 03 REXX-SHIP-NOTE7 PIC X(60) . - 03 REXX-SHIP-NOTE8 PIC X(60) . - 03 REXX-SHIP-OUT PIC X(03) . - - LINKAGE SECTION. - COPY PKGXBLKS. - - PROCEDURE DIVISION USING - PACKAGE-EXIT-BLOCK - PACKAGE-REQUEST-BLOCK - PACKAGE-EXIT-HEADER-BLOCK - PACKAGE-EXIT-FILE-BLOCK - PACKAGE-EXIT-ACTION-BLOCK - PACKAGE-EXIT-APPROVER-MAP - PACKAGE-EXIT-BACKOUT-BLOCK - PACKAGE-EXIT-SHIPMENT-BLOCK - PACKAGE-EXIT-SCL-BLOCK. - **** - **** - -******* DISPLAY 'C1UEXT07: GOT INTO EXIT 7' . - ACCEPT WS-DATE-OF-RUN FROM DATE. - ACCEPT WS-TIME-OF-RUN FROM TIME. - MOVE WS-DOR-YEAR TO WS-RUN-DATE-YEAR. - MOVE WS-DOR-MONTH TO WS-RUN-DATE-MONTH. - MOVE WS-DOR-DAY TO WS-RUN-DATE-DAY. - MOVE WS-TOR-HOUR TO WS-RUN-TIME-HOUR. - MOVE WS-TOR-MINUTE TO WS-RUN-TIME-MINUTE. - - IF SETUP-EXIT-OPTIONS -********* to support automated package shipping - MOVE 'Y' TO PECB-AFTER-EXEC - MOVE 'Y' TO PECB-REQ-ELEMENT-ACTION-BIBO - MOVE 'Y' TO PECB-AFTER-BACKOUT - MOVE 'Y' TO PECB-AFTER-BACKIN -********* to enforce package backout = Y -********* MOVE 'Y' TO PECB-BEFORE-CAST -********* MOVE 'Y' TO PECB-MID-CAST - MOVE 'Y' TO PECB-BEFORE-CREATE-BLD - MOVE 'Y' TO PECB-BEFORE-CREATE-COPY - MOVE 'Y' TO PECB-BEFORE-CREATE-EDIT - MOVE 'Y' TO PECB-BEFORE-CREATE-IMPT - MOVE 'Y' TO PECB-BEFORE-MOD-BLD - MOVE 'Y' TO PECB-BEFORE-MOD-CPY - MOVE 'Y' TO PECB-BEFORE-MOD-EDIT - MOVE 'Y' TO PECB-BEFORE-MOD-IMPT -********* to support submission of package Execute jobs - MOVE 'Y' TO PECB-AFTER-REV-APPR - MOVE 'Y' TO PECB-AFTER-CAST - MOVE ZEROS TO RETURN-CODE - GO TO 100-MAIN-EXIT. - - MOVE 0 TO PECB-NDVR-EXIT-RC. - -** *******====---> SUBMIT PACKAGE SHIPMENT JOBS - IF (EXECUTE-PACKAGE AND - PHDR-PACKAGE-STATUS(1:4) = 'EXEC') - OR (BACK-OUT-PACKAGE AND PECB-AFTER ) - OR (BACK-IN-PACKAGE AND PECB-AFTER ) - PERFORM 800-SUBMIT-PACKAGE-SHIPMENTS - GO TO 100-MAIN-EXIT. - - IF CAST-PACKAGE AND PECB-AFTER AND - PHDR-PACKAGE-STATUS = 'APPROVED' -******* DISPLAY 'PERFORM 599-CHECK-SUBMIT-DATES' - PERFORM 599-CHECK-SUBMIT-DATES - IF SUBMIT-OK -******* DISPLAY 'PERFORM 600-SUBMIT-PACKAGE-AUTOMATION' - IF PECB-BATCH-MODE - MOVE SPACES TO ALLOC-TEXT - PERFORM 2100-ALLOCATE-REXFILE - END-IF - PERFORM 600-SUBMIT-PACKAGE-AUTOMATION - PERFORM 2100-ALLOCATE-REXFILE - GO TO 100-MAIN-EXIT - ELSE - GO TO 100-MAIN-EXIT. - - IF REVIEW-PACKAGE AND PECB-AFTER AND - PHDR-PACKAGE-STATUS = 'APPROVED' - PERFORM 599-CHECK-SUBMIT-DATES - IF SUBMIT-OK - IF PECB-BATCH-MODE - MOVE SPACES TO ALLOC-TEXT - PERFORM 2100-ALLOCATE-REXFILE - END-IF - PERFORM 600-SUBMIT-PACKAGE-AUTOMATION - GO TO 100-MAIN-EXIT - ELSE - GO TO 100-MAIN-EXIT. - -******* DISPLAY 'C1UEXT07: PHDR-PACKAGE-STATUS=' -******* PHDR-PACKAGE-STATUS. - - IF PREQ-BACKOUT-ENABLED NOT = 'Y' - MOVE 'Y' TO PREQ-BACKOUT-ENABLED - MOVE 4 TO PECB-NDVR-EXIT-RC - MOVE 'Y' TO PECB-MODS-MADE-TO-PREQ - DISPLAY 'C1UEXT07: Package Backout is Enforced' - END-IF. - - 100-MAIN-EXIT. -******* DISPLAY 'C1UEXT07: GOING BACK ' - - GOBACK. - - - 599-CHECK-SUBMIT-DATES. - - ACCEPT WS-DATE-OF-RUN FROM DATE - ACCEPT WS-TIME-OF-RUN FROM TIME - MOVE WS-DOR-YEAR TO WS-RUN-DATE-YEAR - MOVE WS-DOR-MONTH TO WS-RUN-DATE-MONTH - MOVE WS-DOR-DAY TO WS-RUN-DATE-DAY - MOVE WS-TOR-HOUR TO WS-RUN-TIME-HOUR - MOVE WS-TOR-MINUTE TO WS-RUN-TIME-MINUTE - - MOVE PHDR-PKG-EXEC-STRT-DATE TO WS-DATE-TO-CONVERT - PERFORM 700-CONVERT-DATE-CONVERT - MOVE WS-DATE-YEAR TO WS-PKG-START-YEAR - MOVE WS-DATE-MONTH TO WS-PKG-START-MONTH - MOVE WS-DATE-DAY TO WS-PKG-START-DAY - - MOVE PHDR-PKG-EXEC-END-DATE TO WS-DATE-TO-CONVERT - PERFORM 700-CONVERT-DATE-CONVERT - MOVE WS-DATE-YEAR TO WS-PKG-END-YEAR - MOVE WS-DATE-MONTH TO WS-PKG-END-MONTH - MOVE WS-DATE-DAY TO WS-PKG-END-DAY - - MOVE PHDR-PKG-EXEC-STRT-TIME TO WS-PACKAGE-TIME - MOVE WS-PKG-HOUR TO WS-PKG-START-HOUR - MOVE WS-PKG-MINUTE TO WS-PKG-START-MINUTE - - MOVE PHDR-PKG-EXEC-END-TIME TO WS-PACKAGE-TIME - MOVE WS-PKG-HOUR TO WS-PKG-END-HOUR - MOVE WS-PKG-MINUTE TO WS-PKG-END-MINUTE - - IF PECB-USER-BATCH-JOBNAME(1:7) = ME - DISPLAY 'C1UEXT07: USING THESE DATES' - DISPLAY 'RUN DATE: ' WS-RUN-DATE - ' TIME: ' WS-RUN-TIME - DISPLAY 'START DATE: ' WS-PKG-START-DATE - ' TIME: ' WS-PKG-START-TIME - DISPLAY 'END DATE: ' WS-PKG-END-DATE - ' TIME: ' WS-PKG-END-TIME - END-IF - - SET SUBMIT-OK TO TRUE - IF WS-PKG-START-DATE > WS-RUN-DATE - SET DO-NOT-SUBMIT TO TRUE - END-IF - - IF WS-PKG-START-DATE = WS-RUN-DATE - AND WS-PKG-START-TIME > WS-RUN-TIME - SET DO-NOT-SUBMIT TO TRUE - END-IF - - IF WS-PKG-END-DATE < WS-RUN-DATE - SET DO-NOT-SUBMIT TO TRUE - END-IF - - IF WS-PKG-END-DATE = WS-RUN-DATE - AND WS-PKG-END-TIME < WS-RUN-TIME - SET DO-NOT-SUBMIT TO TRUE - END-IF - - IF PECB-USER-BATCH-JOBNAME(1:7) = ME - DISPLAY 'C1UEXT07: SUBMIT SWITCH: ' WS-SUBMIT-SWITCH - END-IF - . - 600-SUBMIT-PACKAGE-AUTOMATION. - - * MAKES A CALL TO THE REXX ROUTINE PKGEXECT. - * THE REXX ROUTINE PKGEXECT SUBMITS PACKAGE SHIPMENT JOBS. - * THE REXX ROUTINE PKGEXECT SUBMITS PACKAGE SHIPMENT JOBS. - -****** IF PECB-USER-BATCH-JOBNAME(1:7) = ME -****** DISPLAY 'C1UEXT07: SUBMITTING PACKAGE ' -****** PECB-PACKAGE-ID -****** DISPLAY 'C1UEXT07: PHDR-PKG-ENV ' PHDR-PKG-ENV -****** DISPLAY 'C1UEXT07: PHDR-PKG-STGID' PHDR-PKG-STGID -****** END-IF - - MOVE PECB-PACKAGE-ID TO REXX-EXEC-PACKAGE - MOVE PHDR-PKG-ENV TO REXX-EXEC-ENV - MOVE PHDR-PKG-STGID TO REXX-EXEC-STGID - MOVE PECB-MODE TO REXX-EXEC-MODE - MOVE PHDR-PKG-CREATE-USER TO REXX-EXE-CREATE-USER - MOVE PHDR-PKG-UPDATE-USER TO REXX-EXE-UPDATE-USER - MOVE PHDR-PKG-CAST-USER TO REXX-EXE-CAST-USER - MOVE PREQ-PACKAGE-COMMENT TO REXX-EXEC-COMMENT - MOVE 'PKGEXECT' TO EXECBLK-MEMBER . - MOVE 102 TO ARGSTRING-LENGTH(1) - -******** -******** IF PECB-TSO-MODE -******** DISPLAY 'C1UEXT07: IN TSO FOREGROUND ' -******** CALL 'SET-ARG1-POINTER' USING ARGUMENT-PTR -******** PKG-EXECUTE-PARMS-IRXEXEC -******** PERFORM 1800-REXX-CALL-VIA-IRXEXEC -******** ELSE -******** DISPLAY 'C1UEXT07: NOT IN TSO FOREGROUND ' - CALL IRXJCL USING PKG-EXECUTE-PARMS-IRXJCL . - - - IF RETURN-CODE NOT = 0 - DISPLAY 'C1UEXT07: BAD CALL TO IRXJCL - RC = ' - RETURN-CODE - END-IF - - MOVE 0 TO RETURN-CODE - . - 700-CONVERT-DATE-CONVERT. - - SET WS-MONTH-INX TO 1. - SEARCH WS-MONTH VARYING WS-MONTH-INX - AT END MOVE 00 TO WS-DATE-MONTH - WHEN WS-MONTH(WS-MONTH-INX) = WS-DATE-TO-CONVERT(3:3) - SET WS-DATE-MONTH TO WS-MONTH-INX - END-SEARCH - - MOVE WS-DATE-TO-CONVERT (1:2) TO WS-DATE-DAY - MOVE WS-DATE-TO-CONVERT (6:2) TO WS-DATE-YEAR - MOVE '20' TO WS-DATE-CENTURY - . - 800-SUBMIT-PACKAGE-SHIPMENTS. - - * MAKES A CALL TO THE REXX ROUTINE PKGESHIP - * THE REXX ROUTINE PKGESHIP SUBMITS PACKAGE SHIPMENT JOBS - - * Package Shipments may occur in batch only - * As a result, IRXJCL will be always be used to - * submit the package Shipment jobs. - -******* IF PECB-USER-BATCH-JOBNAME(1:7) = 'IBMUSER' -******* DISPLAY 'C1UEXT07: SHIPPING PACKAGE ' -******* PECB-PACKAGE-ID -******* DISPLAY 'C1UEXT07: PHDR-PKG-ENV ' PHDR-PKG-ENV -******* DISPLAY 'C1UEXT07: PHDR-PKG-STGID' PHDR-PKG-STGID -******* END-IF - - PERFORM 2100-ALLOCATE-REXFILE. - - MOVE PECB-PACKAGE-ID TO REXX-SHIP-PACKAGE - MOVE PHDR-PKG-ENV TO REXX-SHIP-ENV - MOVE PHDR-PKG-STGID TO REXX-SHIP-STGID - MOVE PREQ-PACKAGE-COMMENT TO REXX-SHIP-COMMENT - MOVE PHDR-PKG-CREATE-USER TO REXX-SHIP-CREATE-USR - MOVE PHDR-PKG-UPDATE-USER TO REXX-SHIP-UPDATE-USR - MOVE PHDR-PKG-CAST-USER TO REXX-SHIP-CAST-USER - MOVE PHDR-PKG-NOTE1 TO REXX-SHIP-NOTE1 - MOVE PHDR-PKG-NOTE2 TO REXX-SHIP-NOTE2 - MOVE PHDR-PKG-NOTE3 TO REXX-SHIP-NOTE3 - MOVE PHDR-PKG-NOTE4 TO REXX-SHIP-NOTE4 - MOVE PHDR-PKG-NOTE5 TO REXX-SHIP-NOTE5 - MOVE PHDR-PKG-NOTE6 TO REXX-SHIP-NOTE6 - MOVE PHDR-PKG-NOTE7 TO REXX-SHIP-NOTE7 - MOVE PHDR-PKG-NOTE8 TO REXX-SHIP-NOTE8 - IF BACK-OUT-PACKAGE - MOVE 'BAC' TO REXX-SHIP-OUT - ELSE - MOVE 'OUT' TO REXX-SHIP-OUT . - - CALL IRXJCL USING PKG-SHIPMENT-PARMS-IRXJCL. - - MOVE 0 TO RETURN-CODE - . - - - 1800-REXX-CALL-VIA-IRXEXEC. - *--- GET THE ADDRESS OF THE ARGUMENT(S) TO BE PASSED TO IXREXEC - *--- AND LOAD INTO THE ARGUMENT TABLES -******* IF PECB-USER-BATCH-JOBNAME(1:7) = ME -******* DISPLAY 'C1UEXT07: SETTING UP REXX EXECUTION' -******* ' FOR PACKAGE 'PECB-PACKAGE-ID -******* END-IF . - SET ARGSTRING-PTR (1) TO ARGUMENT-PTR . - CALL 'SET-ARGUMENT-POINTER' USING ARGTABLE-PTR - ARGUMENT . - CALL 'SET-EXECBLK-POINTER' USING EXECBLK-PTR - EXECBLK . - CALL 'SET-EVALBLK-POINTER' USING EVALBLK-PTR - EVALBLK . - *--- SET FLAGS TO HEX 20000000 - * I.E. EXEC INVOKED AS SUBROUTINE - MOVE 536870912 TO FLAGS - MOVE 0 TO REXX-RETURN-CODE . - - IF PECB-USER-BATCH-JOBNAME(1:7) = ME - DISPLAY 'C1UEXT07: CALLING IRXEXC ' - PECB-PACKAGE-ID - END-IF . - *--- CALL THE REXX EXEC --- - CALL IRXEXEC-PGM USING EXECBLK-PTR - ARGTABLE-PTR - FLAGS - DUMMY-ZERO - DUMMY-ZERO - EVALBLK-PTR - DUMMY-ZERO - DUMMY-ZERO - DUMMY-ZERO . - - IF REXX-RETURN-CODE NOT = 0 - DISPLAY 'C1UEXT07: IRXEXEC RETURN CODE = ' - REXX-RETURN-CODE - END-IF - - CANCEL IRXEXEC-PGM - . - - 2100-ALLOCATE-REXFILE. - - MOVE SPACES TO ALLOC-TEXT. - - STRING 'ALLOC DD(REXFILE7) ', - 'DA(YOURSITE.NDVR.REXX) SHR REUSE' - DELIMITED BY SIZE - INTO ALLOC-TEXT - END-STRING . - PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . - STRING 'ALLOC DD(SYSEXEC) ', - 'DA(YOURSITE.NDVR.REXX) SHR REUSE' - DELIMITED BY SIZE - INTO ALLOC-TEXT - END-STRING. - PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . - -********** MOVE 'CONCAT DDLIST(REXFILE,REXFILE2)' -********** TO ALLOC-TEXT . -********** -********** PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . - - ***************************************************************** - ** DYNAMICALLY DE-ALLOCATE UNNEEDED REXX FILES - ***************************************************************** - 2200-FREE-REXFILES. - - MOVE 'FREE DD(REXFILE7)' TO ALLOC-TEXT - PERFORM 9000-DYNAMIC-ALLOC-DEALLOC - - MOVE 'FREE DD(SYSEXEC)' TO ALLOC-TEXT - PERFORM 9000-DYNAMIC-ALLOC-DEALLOC - . - ***************************************************************** - ** CALL BPXWDYN TO PREFORM REQUIRED REXX FUNCTIONS - ***************************************************************** - 9000-DYNAMIC-ALLOC-DEALLOC. - - CALL BPXWDYN USING ALLOC-STRING - - IF RETURN-CODE NOT = ZERO - DISPLAY 'C1UEXT07: ALLOCATION FAILED: RETURN CODE = ' - RETURN-CODE - DISPLAY ALLOC-TEXT - END-IF - - MOVE SPACES TO ALLOC-TEXT - . - - - ****************************************************************** - * BEGIN NESTED PROGRAMS USED TO SET THE POINTERS OF DATA AREAS - * THAT ARE BEING PASSED TO IRXEXEC SO THAT A REXX ROUTINE CAN - * PASS DATA (OTHER THAN A RETURN CODE) BACK TO A COBOL PROGRAM. - ****************************************************************** - - ******** SET-ARG1-POINTER ******** - IDENTIFICATION DIVISION. - PROGRAM-ID. SET-ARG1-POINTER. - ENVIRONMENT DIVISION. - DATA DIVISION. - WORKING-STORAGE SECTION. - LINKAGE SECTION. - 77 ARG-PTR POINTER. - 77 ARG1 PIC X(16). - PROCEDURE DIVISION USING ARG-PTR - ARG1. - SET ARG-PTR TO ADDRESS OF ARG1 - GOBACK. - END PROGRAM SET-ARG1-POINTER. - - ******** SET-ARGUMENT-POINTER ******** - IDENTIFICATION DIVISION. - PROGRAM-ID. SET-ARGUMENT-POINTER. - ENVIRONMENT DIVISION. - DATA DIVISION. - WORKING-STORAGE SECTION. - LINKAGE SECTION. - 77 ARGTABLE-PTR POINTER. - 01 ARGUMENT. - 02 ARGUMENT-1 OCCURS 1 TIMES. - 05 ARGSTRING-PTR POINTER. - 05 ARGSTRING-LENGTH PIC S9(8) BINARY. - 02 ARGSTRING-LAST1 PIC S9(8) BINARY. - 02 ARGSTRING-LAST2 PIC S9(8) BINARY. - PROCEDURE DIVISION USING ARGTABLE-PTR - ARGUMENT. - SET ARGTABLE-PTR TO ADDRESS OF ARGUMENT - GOBACK. - END PROGRAM SET-ARGUMENT-POINTER. - - ******** SET-EXECBLK-POINTER ******** - IDENTIFICATION DIVISION. - PROGRAM-ID. SET-EXECBLK-POINTER. - ENVIRONMENT DIVISION. - DATA DIVISION. - WORKING-STORAGE SECTION. - LINKAGE SECTION. - 77 EXECBLK-PTR POINTER. - 01 EXECBLK. - 03 EXECBLK-ACRYN PIC X(8). - 03 EXECBLK-LENGTH PIC 9(4) COMP. - 03 EXECBLK-RESERVED PIC 9(4) COMP. - 03 EXECBLK-MEMBER PIC X(8). - 03 EXECBLK-DDNAME PIC X(8). - 03 EXECBLK-SUBCOM PIC X(8). - 03 EXECBLK-DSNPTR POINTER. - 03 EXECBLK-DSNLEN PIC 9(4) COMP. - PROCEDURE DIVISION USING EXECBLK-PTR - EXECBLK. - SET EXECBLK-PTR TO ADDRESS OF EXECBLK - GOBACK. - END PROGRAM SET-EXECBLK-POINTER. - - ******** SET-EVALBLK-POINTER ******** - IDENTIFICATION DIVISION. - PROGRAM-ID. SET-EVALBLK-POINTER. - ENVIRONMENT DIVISION. - DATA DIVISION. - WORKING-STORAGE SECTION. - LINKAGE SECTION. - 77 EVALBLK-PTR POINTER. - 01 EVALBLK. - 03 EVALBLK-EVPAD1 PIC 9(4) COMP. - 03 EVALBLK-EVSIZE PIC 9(4) COMP. - 03 EVALBLK-EVLEN PIC 9(4) COMP. - 03 EVALBLK-EVPAD2 PIC 9(4) COMP. - 03 EVALBLK-EVDATA PIC X(256). - PROCEDURE DIVISION USING EVALBLK-PTR - EVALBLK. - SET EVALBLK-PTR TO ADDRESS OF EVALBLK - GOBACK. - END PROGRAM SET-EVALBLK-POINTER. - *--- END OF MAIN PROGRAM - END PROGRAM C1UEXT07. + PROCESS DYNAM OUTDD(DISPLAYS) + IDENTIFICATION DIVISION. + PROGRAM-ID. C1UEXT07. + ***************************************************************** + * DESCRIPTION: THIS PGM IS CALLED for misc Package actions. + * It gathers Endevor info from the exit blocks + * then calls REXX program C1UEXTR7. + ************************************************************ + * https://github.com/BroadcomMFD/broadcom-product-scripts + ************************************************************ + * Change the Dataset references within this program: * + * 1) Find all "DA(" * + * 2) Change each dataset name to your REXX library * + ************************************************************ + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + ** + DATA DIVISION. + FILE SECTION. + WORKING-STORAGE SECTION. + COPY NOTIFYDS. + 01 WS-CALLING-REASON PIC X(24). + 01 WS-VARIABLES. + 03 WS-POINTER PIC 9(09) COMP. + 03 WS-WORK-ADDRESS-ADR PIC 9(09) COMP SYNC . + 03 WS-WORK-ADDRESS-PTR REDEFINES WS-WORK-ADDRESS-ADR + USAGE IS POINTER . + 03 WS-PECB-REQUEST-RETURNCODE PIC 9999 . + 03 WS-PECB-NDVR-HIGH-RC PIC 9999 . + 03 WS-DISPLAY-NUMBER-FOR4 PIC 9(04) . + 03 WS-DISPLAY-NUMBER-FOR9 PIC 9(09) . + 00490200 + 01 PGM PIC X(8). + 01 MYSMTP-MESSAGE PIC X(80). + 01 MYSMTP-USERID PIC X(8). + 01 MYSMTP-FROM PIC X(50). + 01 MYSMTP-SUBJECT PIC X(50). + 01 MYSMTP-TEXT. + 03 MYSMTP-COUNTER PIC 9(2). + 03 MYSMTP-MSG-TEXT. + 05 MYSMTP-LINE PIC X(133) OCCURS 99. + 01 MYSMTP-URL PIC X(1). + 01 MYSMTP-EMAIL-IDS. + 03 FILLER PIC X(09) + OCCURS 320 . + 03 FILLER PIC X(8). + 01 MYSMTP-EMAIL-ID-SIZE PIC 9(8). + 01 WS-ADDRESSES. + 03 ADDRESS-MYSMTP-MESSAGE PIC 9(09) . + 03 ADDRESS-MYSMTP-USERID PIC 9(09) . + 03 ADDRESS-MYSMTP-FROM PIC 9(09) . + 03 ADDRESS-MYSMTP-SUBJECT PIC 9(09) . + 03 ADDRESS-MYSMTP-TEXT PIC 9(09) . + 03 ADDRESS-MYSMTP-URL PIC 9(09) . + 03 ADDRESS-MYSMTP-EMAIL-IDS PIC 9(09) . + 00510000 + 03 ADDRESS-PECB-NDVR-EXIT-RC PIC 9(09) . + 03 ADDRESS-PECB-MESSAGE-ID PIC 9(09) . + 03 ADDRESS-PECB-MESSAGE PIC 9(09) . + 03 ADDRESS-PECB-ERROR-MESS-LENGTH PIC 9(09) . + 03 ADDRESS-PECB-MODS-MADE-TO-PREQ PIC 9(09) . + 03 ADDRESS-PREQ-SHARE-ENABLED PIC 9(09) . + 03 ADDRESS-PREQ-BACKOUT-ENABLED PIC 9(09) . + 01 BPXWDYN PIC X(8) VALUE 'BPXWDYN'. + 01 ALLOC-STRING. + 05 ALLOC-LENGTH PIC S9(4) BINARY VALUE 100. + 05 ALLOC-TEXT PIC X(100). + 01 IRXJCL PIC X(6) VALUE 'IRXJCL'. + 01 IRXEXEC-PGM PIC X(08) VALUE 'IRXEXEC'. + * + * DEFINE THE IRXEXEC DATA AREAS AND ARG BLOCKS + * + 77 WS-INX PIC 9(08) COMP . + 77 FLAGS PIC S9(8) BINARY. + 77 REXX-RETURN-CODE PIC S9(8) BINARY. + 77 DUMMY-ZERO PIC S9(8) BINARY. + 77 LPAR-ID PIC X(04). + 88 DO-NOT-PROCESS-LPAR VALUE 'SKIP'. + 77 ARG1 PIC X(16). + 77 UPDPRINT-FILE-STATUS PIC X(02). + 77 ARGUMENT-PTR POINTER. + 77 EXECBLK-PTR POINTER. + 77 ARGTABLE-PTR POINTER. + 77 EVALBLK-PTR POINTER. + 77 TEMP-PTR POINTER. + 01 EXECBLK. + 05 EXECBLK-ACRYN PIC X(08) VALUE 'IRXEXECB'. + 05 EXECBLK-LENGTH PIC S9(8) BINARY + VALUE 48. + 05 EXECBLK-RESERVED PIC S9(8) BINARY + VALUE 0. + 05 EXECBLK-MEMBER PIC X(08) VALUE 'C1UEXTR7'. + 05 EXECBLK-DDNAME PIC X(08) VALUE 'REXFILE7'. + 05 EXECBLK-SUBCOM PIC X(08) VALUE SPACES. + 05 EXECBLK-DSNPTR POINTER VALUE NULL. + 05 EXECBLK-DSNLEN PIC 9(04) COMP + VALUE 0. + 01 EVALBLK. + 05 EVALBLK-EVPAD1 PIC S9(8) BINARY + VALUE 0. + 05 EVALBLK-EVSIZE PIC S9(8) BINARY + VALUE 34. + 05 EVALBLK-EVLEN PIC S9(8) BINARY + VALUE 0. + 05 EVALBLK-EVPAD2 PIC S9(8) BINARY + VALUE 0. + 05 EVALBLK-EVDATA PIC X(256). + 01 ARGUMENT. + 02 ARGUMENT-1 OCCURS 1 TIMES. + 05 ARGSTRING-PTR POINTER. + 05 ARGSTRING-LENGTH PIC S9(8) BINARY. + 02 ARGSTRING-LAST1 PIC S9(8) BINARY + VALUE -1. + 02 ARGSTRING-LAST2 PIC S9(8) BINARY + VALUE -1. + * The block of data below can be used with either an + * IRXJCL or IRXEXEC call to the rexx program C1UEXTR7. + * IRXJCL is used when running in batch (batch CAST) . + * IRXEXEC is used when running in foreground (CAST or APPROVE). + 01 PKG-C1UEXTR7-PARMS-IRXJCL. + 02 PKG-C1UEXTR7-PARMS-IRXJCL-TOP. + 03 PARM-LENGTH PIC X(2) VALUE X'0BC1'. + 03 REXX-NAME PIC X(8) VALUE 'C1UEXTR7'. + 03 FILLER PIC X(1) VALUE SPACE . + 02 PKG-C1UEXTR7-PARMS-IRXEXEC. + 03 WS-REXX-STATEMENTS PIC X(3000). + LINKAGE SECTION. + COPY PKGXBLKS. + PROCEDURE DIVISION USING + PACKAGE-EXIT-BLOCK + PACKAGE-REQUEST-BLOCK + PACKAGE-EXIT-HEADER-BLOCK + PACKAGE-EXIT-FILE-BLOCK + PACKAGE-EXIT-ACTION-BLOCK + PACKAGE-EXIT-APPROVER-MAP + PACKAGE-EXIT-BACKOUT-BLOCK + PACKAGE-EXIT-SHIPMENT-BLOCK + PACKAGE-EXIT-SCL-BLOCK. + **** + **** IF PECB-USER-BATCH-JOBNAME(1:7) NOT = 'IBMUSER' AND + **** PECB-USER-BATCH-JOBNAME(1:7) NOT = 'PL05958' + **** GOBACK. + **** +********* DISPLAY 'C1UEXTT7: GOT INTO C1UEXTT7'. +********* MOVE PECB-FUNCTION-CODE TO WS-DISPLAY-NUMBER-FOR9. +********* DISPLAY 'PECB-FUNCTION-CODE=' WS-DISPLAY-NUMBER-FOR9. + IF SETUP-EXIT-OPTIONS + MOVE ZERO TO PECB-UEXIT-HOLD-FIELD +********* to enforce package create rules + MOVE 'Y' TO PECB-BEFORE-CREATE-BLD + MOVE 'Y' TO PECB-BEFORE-CREATE-COPY + MOVE 'Y' TO PECB-BEFORE-CREATE-EDIT + MOVE 'Y' TO PECB-BEFORE-CREATE-IMPT + MOVE 'Y' TO PECB-BEFORE-REV-APPR +********* to enforce package backout = Y + MOVE 'Y' TO PECB-BEFORE-CAST +********* to enforce Approver Group Sequencing + MOVE 'Y' TO PECB-AFTER-REV-APPR + MOVE 'Y' TO PECB-AFTER-CAST + MOVE 'Y' TO PECB-MID-CAST +********* MOVE 'Y' TO PECB-BEFORE-MOD-IMPT +********* MOVE 'Y' TO PECB-AFTER-RESET +********* MOVE 'Y' TO PECB-AFTER-DELETE +********* to support automated package shipping + MOVE 'Y' TO PECB-AFTER-EXEC + MOVE 'Y' TO PECB-REQ-ELEMENT-ACTION-BIBO + MOVE 'Y' TO PECB-BEFORE-BACKOUT + MOVE 'Y' TO PECB-BEFORE-BACKIN + MOVE 'Y' TO PECB-AFTER-BACKOUT + MOVE 'Y' TO PECB-AFTER-BACKIN +********* to support submission of package Execute jobs +**done*** MOVE 'Y' TO PECB-AFTER-REV-APPR +**done*** MOVE 'Y' TO PECB-AFTER-CAST + MOVE ZEROS TO RETURN-CODE + GOBACK. + MOVE 0 TO PECB-NDVR-EXIT-RC. + MOVE SPACES TO WS-REXX-STATEMENTS . +********* If just starting out, request Approver Group info + IF PECB-REQUEST-RETURNCODE = 0 AND PECB-AFTER AND + (CAST-PACKAGE OR REVIEW-PACKAGE) + PERFORM 1000-ALLOCATE-REXFILE + MOVE 'Y' TO PECB-REQ-APPROVER-REC + GOBACK + ELSE +********* If we just received an Appprover Group block, +********* pass it to the REXX and ask for more... + IF PECB-SUCCESSFUL-RECORD-SENT + MOVE PAPP-SEQUENCE-NUMBER TO WS-DISPLAY-NUMBER-FOR4 + MOVE SPACES TO WS-CALLING-REASON + STRING 'Approver Group #' + WS-DISPLAY-NUMBER-FOR4 + DELIMITED BY SIZE + INTO WS-CALLING-REASON + END-STRING + PERFORM 0500-CALL-C1UEXTR7-REXX + MOVE 'Y' TO PECB-REQ-APPROVER-REC + GOBACK + ELSE +********* Endevor says 'no more Appprover Group blocks' +********* tell REXX and let it decide on email + IF PECB-END-OF-FILE-FOR-REC-TYP OR + PECB-NO-RECORDS-FOUND + MOVE 'NO MORE Approver Grps ' TO WS-CALLING-REASON + PERFORM 0500-CALL-C1UEXTR7-REXX + IF MYSMTP-COUNTER NUMERIC AND + MYSMTP-COUNTER GREATER THAN '00' AND + MYSMTP-EMAIL-IDS(1:1) GREATER THAN SPACE + MOVE 'BC1PMLIF' TO PGM + PERFORM 0900-SEND-EMAILS + END-IF + PERFORM 2000-FREE-REXFILES + GOBACK + ELSE +********* If Before the CAST, just pass Package info to the REXX + IF (PECB-BEFORE OR PECB-MID) AND + (CREATE-PACKAGE OR CAST-PACKAGE) + IF CREATE-PACKAGE + MOVE 'Before CREATE' TO WS-CALLING-REASON + ELSE + MOVE 'Before CAST' TO WS-CALLING-REASON + END-IF. +********* For many conditions, call REXX and let it decide what to do + PERFORM 1000-ALLOCATE-REXFILE. + PERFORM 0500-CALL-C1UEXTR7-REXX. + PERFORM 2000-FREE-REXFILES. + 0100-MAIN-EXIT. + GOBACK. + 0500-CALL-C1UEXTR7-REXX. + * Give addresses of updatable fields to the REXX. + * MAKES A CALL TO THE REXX ROUTINE C1UEXTR7. + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-MESSAGE . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-MYSMTP-MESSAGE. + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-USERID . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-MYSMTP-USERID . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-FROM . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-MYSMTP-FROM . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-SUBJECT . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-MYSMTP-SUBJECT. + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-TEXT . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-MYSMTP-TEXT . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-URL . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-MYSMTP-URL . + MOVE SPACES TO MYSMTP-EMAIL-IDS . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-EMAIL-IDS . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-MYSMTP-EMAIL-IDS . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF MYSMTP-EMAIL-ID-SIZE . + COMPUTE MYSMTP-EMAIL-ID-SIZE = + WS-WORK-ADDRESS-ADR - 4 - + ADDRESS-MYSMTP-EMAIL-IDS . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF PECB-NDVR-EXIT-RC . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-PECB-NDVR-EXIT-RC. + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF PECB-MESSAGE . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-PECB-MESSAGE . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF PECB-ERROR-MESS-LENGTH . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-PECB-ERROR-MESS-LENGTH. + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF PECB-MODS-MADE-TO-PREQ . + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-PECB-MODS-MADE-TO-PREQ. + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF PECB-MESSAGE-ID. + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-PECB-MESSAGE-ID . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF PREQ-SHARE-ENABLED. + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-PREQ-SHARE-ENABLED . + SET WS-WORK-ADDRESS-PTR TO + ADDRESS OF PREQ-BACKOUT-ENABLED. + MOVE WS-WORK-ADDRESS-ADR + TO ADDRESS-PREQ-BACKOUT-ENABLED . + MOVE PECB-REQUEST-RETURNCODE TO + WS-PECB-REQUEST-RETURNCODE. + MOVE PECB-NDVR-HIGH-RC TO + WS-PECB-NDVR-HIGH-RC . + ***** + ***** / Convert COBOL exit block Datanames into Rexx \ + ***** + ***** + MOVE 1 TO WS-POINTER. + STRING + 'PECB_PACKAGE_ID = "' PECB-PACKAGE-ID '";' + 'PECB_FUNCTION_LITERAL="' PECB-FUNCTION-LITERAL '";' + 'PECB_SUBFUNC_LITERAL="' PECB-SUBFUNC-LITERAL '";' + 'PECB_BEF_AFTER_LITERAL="' PECB-BEF-AFTER-LITERAL '";' + 'PECB_USER_BATCH_JOBNAME="' PECB-USER-BATCH-JOBNAME '";' + 'PREQ_PKG_CAST_COMPVAL="' PREQ-PKG-CAST-COMPVAL '";' + 'PHDR_PKG_SHR_OPTION ="' PHDR-PKG-SHR-OPTION '";' + 'PHDR_PKG_ENV ="' PHDR-PKG-ENV '";' + 'PHDR_PKG_STGID ="' PHDR-PKG-STGID '";' + 'PECB_MODE = "' PECB-MODE '";' + 'PREQ_EXEC_START_DATE = "' PREQ-EXEC-START-DATE '";' + 'PREQ_EXEC_START_TIME = "' PREQ-EXEC-START-TIME '";' + 'PREQ_EXEC_END_DATE = "' PREQ-EXEC-END-DATE '";' + 'PREQ_EXEC_END_TIME = "' PREQ-EXEC-END-TIME '";' + 'PECB_AUTOCAST ="' PECB-AUTOCAST '";' + 'PECB_ACT_REC_EXIST_FLAG="' PECB-ACT-REC-EXIST-FLAG '";' + 'PECB_APP_REC_EXIST_FLAG="' PECB-APP-REC-EXIST-FLAG '";' + 'PECB_BAC_REC_EXIST_FLAG="' PECB-BAC-REC-EXIST-FLAG '";' + 'PECB_REQUEST_RETURNCODE=' WS-PECB-REQUEST-RETURNCODE ';' + 'PECB_NDVR_HIGH_RC = ' WS-PECB-NDVR-HIGH-RC ';' + 'PREQ_BACKOUT_ENABLED="' PREQ-BACKOUT-ENABLED '";' + 'Address_PREQ_BACKOUT_ENABLED=' + ADDRESS-PREQ-BACKOUT-ENABLED ';' + 'PREQ_SHARE_ENABLED="' PREQ-SHARE-ENABLED '";' + 'Address_PREQ_SHARE_ENABLED=' + ADDRESS-PREQ-SHARE-ENABLED ';' + 'Address_PECB_MODS_MADE_TO_PREQ=' + ADDRESS-PECB-MODS-MADE-TO-PREQ ';' + 'Address_PECB_NDVR_EXIT_RC=' + ADDRESS-PECB-NDVR-EXIT-RC ';' + 'Address_PECB_MESSAGE_ID=' ADDRESS-PECB-MESSAGE-ID ';' + 'Address_PECB_ERROR_MESS_LENGTH = ' + ADDRESS-PECB-ERROR-MESS-LENGTH ';' + 'Address_PECB_MESSAGE = ' ADDRESS-PECB-MESSAGE ';' + 'Address_MYSMTP_MESSAGE=' ADDRESS-MYSMTP-MESSAGE ';' + 'Address_MYSMTP_USERID =' ADDRESS-MYSMTP-USERID ';' + 'Address_MYSMTP_FROM =' ADDRESS-MYSMTP-FROM ';' + 'Address_MYSMTP_SUBJECT=' ADDRESS-MYSMTP-SUBJECT ';' + 'Address_MYSMTP_TEXT =' ADDRESS-MYSMTP-TEXT ';' + 'Address_MYSMTP_URL =' ADDRESS-MYSMTP-URL ';' + 'Address_MYSMTP_EMAIL_IDS=' + ADDRESS-MYSMTP-EMAIL-IDS ';' + 'MYSMTP_EMAIL_ID_SIZE=' + MYSMTP-EMAIL-ID-SIZE ';' + DELIMITED BY SIZE + INTO WS-REXX-STATEMENTS + WITH POINTER WS-POINTER . +********* For these text fields, make sure none use a double quote +********* character. This ensures the integrity of the REXX + IF (REVIEW-PACKAGE OR CAST-PACKAGE) AND + PECB-AFTER AND + PECB-SUCCESSFUL-RECORD-SENT AND + PAPP-GROUP-NAME(1:1) IS ALPHABETIC + MOVE PAPP-QUORUM-COUNT TO WS-DISPLAY-NUMBER-FOR4 + STRING + 'CALL_REASON="' WS-CALLING-REASON '";' + 'PAPP_GROUP_NAME ="' PAPP-GROUP-NAME '";' + 'PAPP_ENVIRONMENT="' PAPP-ENVIRONMENT '";' + 'PAPP_QUORUM_COUNT="' WS-DISPLAY-NUMBER-FOR4 '";' + 'PAPP_APPROVER_FLAG="' PAPP-APPROVER-FLAG '";' + 'PAPP_APPR_GRP_TYPE="' PAPP-APPR-GRP-TYPE '";' + 'PAPP_APPR_GRP_DISQ="' PAPP-APPR-GRP-DISQ '";' + DELIMITED BY SIZE + 'PAPP_APPROVAL_IDS= "' + DELIMITED BY SIZE + INTO WS-REXX-STATEMENTS + WITH POINTER WS-POINTER + END-STRING + PERFORM VARYING WS-INX FROM 1 BY 1 UNTIL + WS-INX GREATER THAN PAPP-APPROVER-NUMBER + STRING PAPP-APPROVAL-ID(WS-INX) ' ' + DELIMITED BY SIZE + INTO WS-REXX-STATEMENTS + WITH POINTER WS-POINTER + END-STRING + END-PERFORM + STRING '";' + 'PAPP_APPROVAL_FLAGS= "' + DELIMITED BY SIZE + INTO WS-REXX-STATEMENTS + WITH POINTER WS-POINTER + END-STRING + PERFORM VARYING WS-INX FROM 1 BY 1 UNTIL + WS-INX GREATER THAN PAPP-APPROVER-NUMBER + STRING PAPP-APPROVAL-FLAG(WS-INX) ' ' + DELIMITED BY SIZE + INTO WS-REXX-STATEMENTS + WITH POINTER WS-POINTER + END-STRING + END-PERFORM + STRING '";' + DELIMITED BY SIZE + INTO WS-REXX-STATEMENTS + WITH POINTER WS-POINTER + END-STRING + END-IF. +******* Replace any double quote characters in data to be passed + IF CAST-PACKAGE OR REVIEW-PACKAGE + INSPECT PREQ-PACKAGE-COMMENT REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE1 REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE2 REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE3 REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE4 REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE5 REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE6 REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE7 REPLACING ALL '"' BY X'7D' + INSPECT PHDR-PKG-NOTE8 REPLACING ALL '"' BY X'7D' + STRING + 'CALL_REASON="' WS-CALLING-REASON '";' + 'PREQ_PACKAGE_COMMENT = "' PREQ-PACKAGE-COMMENT '";' + 'PHDR_PACKAGE_TYPE = "' PHDR-PACKAGE-TYPE '";' + 'PHDR_PACKAGE_STATUS = "' PHDR-PACKAGE-STATUS '";' + 'PHDR_PKG_BACKOUT_STATUS="' PHDR-PKG-BACKOUT-STATUS '";' + 'PHDR_PKG_CREATE_USER = "' PHDR-PKG-CREATE-USER '";' + 'PHDR_PKG_CAST_USER = "' PHDR-PKG-CAST-USER '";' + 'PHDR_PKG_NOTE1 = "' PHDR-PKG-NOTE1 '";' + 'PHDR_PKG_NOTE2 = "' PHDR-PKG-NOTE2 '";' + 'PHDR_PKG_NOTE3 = "' PHDR-PKG-NOTE3 '";' + 'PHDR_PKG_NOTE4 = "' PHDR-PKG-NOTE4 '";' + 'PHDR_PKG_NOTE5 = "' PHDR-PKG-NOTE5 '";' + 'PHDR_PKG_NOTE6 = "' PHDR-PKG-NOTE6 '";' + 'PHDR_PKG_NOTE7 = "' PHDR-PKG-NOTE7 '";' + 'PHDR_PKG_NOTE8 = "' PHDR-PKG-NOTE8 '";' + 'PHDR_PKG_CAST_COMPVAL = "' PHDR-PKG-CAST-COMPVAL '";' + DELIMITED BY SIZE + INTO WS-REXX-STATEMENTS + WITH POINTER WS-POINTER + END-STRING + END-IF. + ***** \ Convert COBOL exit block Datanames into Rexx / + ***** + MOVE 'C1UEXTR7' TO EXECBLK-MEMBER . + MOVE 3000 TO ARGSTRING-LENGTH(1) + IF PECB-TSO-MODE + CALL 'SET-ARG1-POINTER' USING ARGUMENT-PTR + PKG-C1UEXTR7-PARMS-IRXEXEC + PERFORM 0800-REXX-CALL-VIA-IRXEXEC + MOVE 0 TO PECB-NDVR-HIGH-RC + ELSE +********* DISPLAY 'C1UEXT07: Running in Batch ' + CALL IRXJCL USING PKG-C1UEXTR7-PARMS-IRXJCL . + IF RETURN-CODE NOT = 0 + DISPLAY 'C1UEXT07: BAD CALL TO IRXJCL - RC = ' + RETURN-CODE + END-IF + MOVE 0 TO RETURN-CODE + . + 0800-REXX-CALL-VIA-IRXEXEC. + *--- GET THE ADDRESS OF THE ARGUMENT(S) TO BE PASSED TO IXREXEC + *--- AND LOAD INTO THE ARGUMENT TABLES +******* IF PECB-USER-BATCH-JOBNAME(1:7) = 'PL05958' +******* DISPLAY 'C1UEXT07: SETTING UP REXX EXECUTION' +******* ' FOR PACKAGE 'PECB-PACKAGE-ID +******* END-IF . + SET ARGSTRING-PTR (1) TO ARGUMENT-PTR . + CALL 'SET-ARGUMENT-POINTER' USING ARGTABLE-PTR + ARGUMENT . + CALL 'SET-EXECBLK-POINTER' USING EXECBLK-PTR + EXECBLK . + CALL 'SET-EVALBLK-POINTER' USING EVALBLK-PTR + EVALBLK . + *--- SET FLAGS TO HEX 20000000 + * I.E. EXEC INVOKED AS SUBROUTINE + MOVE 536870912 TO FLAGS + MOVE 0 TO REXX-RETURN-CODE . +********* DISPLAY 'C1UEXT07: CALLING IRXEXC ' +********* PECB-PACKAGE-ID . + *--- CALL THE REXX EXEC --- + CALL IRXEXEC-PGM USING EXECBLK-PTR + ARGTABLE-PTR + FLAGS + DUMMY-ZERO + DUMMY-ZERO + EVALBLK-PTR + DUMMY-ZERO + DUMMY-ZERO + DUMMY-ZERO . + IF REXX-RETURN-CODE NOT = 0 + DISPLAY 'C1UEXT07: IRXEXEC RETURN CODE = ' + REXX-RETURN-CODE + END-IF + CANCEL IRXEXEC-PGM + . + 0900-SEND-EMAILS. +********** DISPLAY 'C1UEXTT7: MYSMTP-MESSAGE=' MYSMTP-MESSAGE . +********** DISPLAY 'C1UEXTT7: MYSMTP-FROM =' MYSMTP-FROM . +********** DISPLAY 'C1UEXTT7: MYSMTP-SUBJECT=' MYSMTP-SUBJECT . +********** DISPLAY 'C1UEXTT7: MYSMTP-TEXT ' MYSMTP-TEXT(1:80). + MOVE 1 TO WS-POINTER. + PERFORM UNTIL + MYSMTP-EMAIL-IDS(WS-POINTER:1) = LOW-VALUES OR + MYSMTP-EMAIL-IDS(WS-POINTER:8) + LESS THAN OR EQUAL SPACES OR + WS-POINTER GREATER THAN OR EQUAL + MYSMTP-EMAIL-ID-SIZE + MOVE SPACES TO MYSMTP-USERID + UNSTRING MYSMTP-EMAIL-IDS + DELIMITED BY SPACE + INTO MYSMTP-USERID + WITH POINTER WS-POINTER + END-UNSTRING + IF MYSMTP-USERID NOT = SPACES +********** DISPLAY 'C1UEXTT7: Emailing ' MYSMTP-USERID +********** ' WS-POINTER=' WS-POINTER ' ' +********** MYSMTP-EMAIL-IDS(WS-POINTER:60) + CALL PGM USING MYSMTP-MESSAGE + MYSMTP-USERID + MYSMTP-FROM + MYSMTP-SUBJECT + MYSMTP-TEXT + MYSMTP-URL + END-IF + IF RETURN-CODE > 0 + DISPLAY 'CALL BC1PMLIF RC = ' RETURN-CODE + DISPLAY MYSMTP-MESSAGE + END-IF +********** ADD 1 TO WS-POINTER + END-PERFORM. + *----------------------------------------------------------------- + 1000-ALLOCATE-REXFILE. + MOVE SPACES TO ALLOC-TEXT. + IF PECB-BATCH-MODE + STRING 'ALLOC DD(SYSEXEC) ', + 'DA(YOURSITE.NDVR.REXX)' + DELIMITED BY SIZE + ' SHR REUSE' + DELIMITED BY SIZE + INTO ALLOC-TEXT + END-STRING + ELSE + STRING 'ALLOC DD(REXFILE7) ', + 'DA(YOURSITE.NDVR.REXX)' + DELIMITED BY SIZE + ' SHR REUSE' + DELIMITED BY SIZE + INTO ALLOC-TEXT + END-STRING + END-IF. + PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . +********** MOVE 'CONCAT DDLIST(REXFILE,REXFILE2)' +********** TO ALLOC-TEXT . +********** +********** PERFORM 9000-DYNAMIC-ALLOC-DEALLOC . + ***************************************************************** + ** DYNAMICALLY DE-ALLOCATE UNNEEDED REXX FILES + ***************************************************************** + 2000-FREE-REXFILES. + MOVE SPACES TO ALLOC-TEXT. + IF PECB-BATCH-MODE + MOVE 'FREE DD(SYSEXEC)' TO ALLOC-TEXT + ELSE + MOVE 'FREE DD(REXFILE7)' TO ALLOC-TEXT + END-IF. + PERFORM 9000-DYNAMIC-ALLOC-DEALLOC + . + ***************************************************************** + ** CALL BPXWDYN TO PREFORM REQUIRED REXX FUNCTIONS + ***************************************************************** + 9000-DYNAMIC-ALLOC-DEALLOC. + CALL BPXWDYN USING ALLOC-STRING + IF RETURN-CODE NOT = ZERO + DISPLAY 'C1UEXT07: ALLOCATION FAILED: RETURN CODE = ' + RETURN-CODE + DISPLAY ALLOC-TEXT + END-IF +********* DISPLAY ALLOC-TEXT . + MOVE SPACES TO ALLOC-TEXT + . + ****************************************************************** + * BEGIN NESTED PROGRAMS USED TO SET THE POINTERS OF DATA AREAS + * THAT ARE BEING PASSED TO IRXEXEC SO THAT A REXX ROUTINE CAN + * PASS DATA (OTHER THAN A RETURN CODE) BACK TO A COBOL PROGRAM. + ****************************************************************** + ******** SET-ARG1-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-ARG1-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 ARG-PTR POINTER. + 77 ARG1 PIC X(16). + PROCEDURE DIVISION USING ARG-PTR + ARG1. + SET ARG-PTR TO ADDRESS OF ARG1 + GOBACK. + END PROGRAM SET-ARG1-POINTER. + ******** SET-ARGUMENT-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-ARGUMENT-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 ARGTABLE-PTR POINTER. + 01 ARGUMENT. + 02 ARGUMENT-1 OCCURS 1 TIMES. + 05 ARGSTRING-PTR POINTER. + 05 ARGSTRING-LENGTH PIC S9(8) BINARY. + 02 ARGSTRING-LAST1 PIC S9(8) BINARY. + 02 ARGSTRING-LAST2 PIC S9(8) BINARY. + PROCEDURE DIVISION USING ARGTABLE-PTR + ARGUMENT. + SET ARGTABLE-PTR TO ADDRESS OF ARGUMENT + GOBACK. + END PROGRAM SET-ARGUMENT-POINTER. + ******** SET-EXECBLK-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-EXECBLK-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 EXECBLK-PTR POINTER. + 01 EXECBLK. + 03 EXECBLK-ACRYN PIC X(8). + 03 EXECBLK-LENGTH PIC 9(4) COMP. + 03 EXECBLK-RESERVED PIC 9(4) COMP. + 03 EXECBLK-MEMBER PIC X(8). + 03 EXECBLK-DDNAME PIC X(8). + 03 EXECBLK-SUBCOM PIC X(8). + 03 EXECBLK-DSNPTR POINTER. + 03 EXECBLK-DSNLEN PIC 9(4) COMP. + PROCEDURE DIVISION USING EXECBLK-PTR + EXECBLK. + SET EXECBLK-PTR TO ADDRESS OF EXECBLK + GOBACK. + END PROGRAM SET-EXECBLK-POINTER. + ******** SET-EVALBLK-POINTER ******** + IDENTIFICATION DIVISION. + PROGRAM-ID. SET-EVALBLK-POINTER. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + LINKAGE SECTION. + 77 EVALBLK-PTR POINTER. + 01 EVALBLK. + 03 EVALBLK-EVPAD1 PIC 9(4) COMP. + 03 EVALBLK-EVSIZE PIC 9(4) COMP. + 03 EVALBLK-EVLEN PIC 9(4) COMP. + 03 EVALBLK-EVPAD2 PIC 9(4) COMP. + 03 EVALBLK-EVDATA PIC X(256). + PROCEDURE DIVISION USING EVALBLK-PTR + EVALBLK. + SET EVALBLK-PTR TO ADDRESS OF EVALBLK + GOBACK. + END PROGRAM SET-EVALBLK-POINTER. + *--- END OF MAIN PROGRAM + END PROGRAM C1UEXT07. diff --git a/endevor/Field-Developed-Programs/Package-Automation/C1UEXTR7.rex b/endevor/Field-Developed-Programs/Package-Automation/C1UEXTR7.rex new file mode 100644 index 0000000..6b30bc8 --- /dev/null +++ b/endevor/Field-Developed-Programs/Package-Automation/C1UEXTR7.rex @@ -0,0 +1,747 @@ +/* rexx */ +/* Perform various Package actions in REXX */ +/* */ +/* A COBOL exit CALLS this REXX and provides values for */ +/* REXX variables, including these. */ +/* Find documentation on these in the TechDocs documentation */ +/* where each underscore appears as a dash in the documentation. */ +/* For example, PECB_PACKAGE_ID is documented as */ +/* PECB-PACKAGE-ID */ +/* */ +/* PECB_PACKAGE_ID PAPP_GROUP_NAME */ +/* PECB_FUNCTION_LITERAL PAPP_ENVIRONMENT */ +/* PECB_SUBFUNC_LITERAL PAPP_QUORUM_COUNT */ +/* PECB_BEF_AFTER_LITERAL PAPP_APPROVER_FLAG */ +/* PECB_USER_BATCH_JOBNAME PAPP_APPR_GRP_TYPE */ +/* PREQ_PKG_CAST_COMPVAL PAPP_APPR_GRP_DISQ */ +/* PHDR_PKG_SHR_OPTION PAPP_SEQUENCE_NUMBER */ +/* PHDR_PKG_ENV */ +/* PHDR_PKG_STGID */ +/* Address fields are provided for fields that may be */ +/* modified by the REXX. */ +/* Address_PECB_MESSAGE Address_MYSMTP_SUBJECT */ +/* Address_MYSMTP_MESSAGE Address_MYSMTP_TEXT */ +/* Address_MYSMTP_USERID Address_MYSMTP_URL */ +/* Address_MYSMTP_FROM Address_MYSMTP_EMAIL_IDS */ +/* MYSMTP_EMAIL_IDS MYSMTP_EMAIL_ID_SIZE */ +/* */ + /* If wanting to limit the use of this exit, uncomment... */ +/* + If USERID() /= 'IBMUSER' &, + USERID() /= 'JW61868' &, + USERID() /= 'JW618685' then Say USERID() +*/ + /* In case these are not already allocated, these are attempted */ + STRING = "ALLOC DD(SYSTSPRT) SYSOUT(A) " + CALL BPXWDYN STRING; + STRING = "ALLOC DD(SYSTSIN) DUMMY" + CALL BPXWDYN STRING; + /* If C1UEXTR7 is allocated to anything, turn on Trace */ + WhatDDName = 'C1UEXTR7' + CALL BPXWDYN "INFO FI("WhatDDName")", + "INRTDSN(DSNVAR) INRDSNT(myDSNT)" + if RESULT = 0 then Trace ?R + /* Initialize variables.... */ + Message = '' + MessageCode = ' ' + MyRc = 0 + /* Values to be set for your site...... */ + /* For package REVIEW (APPROVE/DENY)..... */ + /* Enter location of Approver Group sequencing ... */ + ApproverGroupSequence= 'YOURSITE.NDVR.PARMLIB(APPROVER)' + ApproverGroupSequence= '' + /* Do you want all CAST actions to be peformed in Batch? */ + Force_CAST_in_Batch = 'N' ; /* Y/N */ + If USERID() = 'IBMUSER' then, + Force_CAST_in_Batch = 'Y' ; /* Y/N */ + Cast_with_SonarQube= 'N' /* Y/N/?=Check Notes */ + If USERID() = 'IBMUSER' then, + Cast_with_SonarQube= 'Y' /* Y/N/?=Check Notes */ + /* Parms are REXX statements passed from COBOL exit */ + Arg Parms + Parms = Strip(Parms) + sa= 'Parms len=' Length(Parms) + If TraceRQ = 'Y' then, + Say 'C1UEXTR7 is called again:' + /* Parms from C1UEXT07 is a string of REXX statements */ + Interpret Parms + If TraceRQ = 'Y' & PECB_MODE = 'B' then Trace r + If Substr(PHDR_PKG_NOTE5,1,5) = 'TRACE' then TraceRc = 1 + where = 'C1UEXTR7' + what = 'C1UEXTR7-' PECB_FUNCTION_LITERAL, + PECB_BEF_AFTER_LITERAL, + PHDR_PACKAGE_STATUS + /* Validate Package prefix with ServiceNow */ + If PECB_FUNCTION_LITERAL ='CREATE' &, + PECB_BEF_AFTER_LITERAL ='BEFORE' &, + (Substr(PECB_PACKAGE_ID,1,3) = 'PRB' |, + Substr(PECB_PACKAGE_ID,1,3) = 'CHG' ) then, + Do + PackageSnowRef = Substr(PECB_PACKAGE_ID,1,10) + Message = SERVINOW('C1UEXTR7' PackageSnowRef ECB_TSO_BATCH_MODE) + If POS('**NOT**', Message) > 0 then, + Do + MyRc = 8 + Call SetExitReturnInfo + Exit + End; /* If POS('**NOT**', Message) > 0 */ + End; /* If PECB_FUNCTION_LITERAL ='CREATE' ... */ + /* If the package status just became IN-APPROVAL, send emails */ + /* to request approval(s). */ + IF PHDR_PACKAGE_STATUS = 'IN-APPROVAL' &, + PECB_BEF_AFTER_LITERAL = 'AFTER' &, + PECB_FUNCTION_LITERAL = 'CAST' &, + Substr(CALL_REASON,1,16) = 'APPROVER GROUP #' then, + Do + Call SENDMAIL PAPP_GROUP_NAME PECB_PACKAGE_ID, + 'Needs-Approval' PAPP_APPROVAL_IDS + Exit + End + /* If the exit says there are no more approver groups, */ + /* FREE the SONAROPT allocation. */ + If Substr(CALL_REASON,1,21) = 'NO MORE APPROVER GRPS' then, + CALL BPXWDYN "FREE DD(SONAROPT) " ; + /* If the package status just became Approved, submit EXECUTE */ + IF PHDR_PACKAGE_STATUS = 'APPROVED' &, + PECB_BEF_AFTER_LITERAL = 'AFTER' &, + (PECB_FUNCTION_LITERAL = 'CAST' |, + PECB_FUNCTION_LITERAL = 'REVIEW') Then, + Do + PKGEXECT_Parm = Copies(' ',055) + PKGEXECT_Parm = Overlay(PECB_PACKAGE_ID ,PKGEXECT_Parm,001) + PKGEXECT_Parm = Overlay(PHDR_PKG_ENV ,PKGEXECT_Parm,018) + PKGEXECT_Parm = Overlay(PHDR_PKG_STGID ,PKGEXECT_Parm,026) + PKGEXECT_Parm = Overlay(REXX_EXEC_MODE ,PKGEXECT_Parm,028) + PKGEXECT_Parm = Overlay(PHDR_PKG_CREATE_USER,PKGEXECT_Parm,029) + PKGEXECT_Parm = Overlay(PHDR_PKG_UPDATE_USER,PKGEXECT_Parm,037) + PKGEXECT_Parm = Overlay(PHDR_PKG_CAST_USER ,PKGEXECT_Parm,045) + Call PKGEXECT PKGEXECT_Parm + Exit + End + /* Prevent a package from Backed out/in in batch */ + If Substr(PECB_FUNCTION_LITERAL,1,4) = 'BACK' &, + PECB_MODE = 'B' then, + Do + message = 'C1UEXTR7 -', + 'Package Backout/Backin unAuthorized for Batch' + MyRc = 8 + Call SetExitReturnInfo + If TraceRQ = 'Y' then Say 'C1UEXTR7 is exiting @123 ' + Exit + End + /* Before a package is being Backed out/in .... */ + IF PECB_BEF_AFTER_LITERAL = 'BEFORE' & PECB_MODE = 'T' &, + Substr(PECB_FUNCTION_LITERAL,1,4) = 'BACK' then, + Do + what = 'C1UEXTR7 before Backout/Backin' + ADDRESS TSO "EXECIO 1 DISKR AUTHORIZ (Finis" + pull BakoutCCID + BakoutCCID = Strip(BakoutCCID) + Call BKOUTLOG PECB_PACKAGE_ID 'Before', + BakoutCCID USERID() + End + /* If a package is being Backed out/in .... */ + IF PECB_BEF_AFTER_LITERAL = 'AFTER' & PECB_MODE = 'T' &, + Substr(PECB_FUNCTION_LITERAL,1,4) = 'BACK' then, + Do + what = 'C1UEXTR7 after Backout/Backin' + ADDRESS TSO "EXECIO 1 DISKR AUTHORIZ (Finis" + pull BakoutCCID + CALL BPXWDYN "FREE DD(AUTHORIZ)" + BakoutCCID = Strip(BakoutCCID) + Call BKOUTLOG PECB_PACKAGE_ID 'After', + BakoutCCID USERID() + ModelMember = 'SHIPRUNS' + Call SubmitBatchJCL + Exit + End + /* If a package is executed, examine for package shipments */ + IF PECB_BEF_AFTER_LITERAL = 'AFTER' &, + (Substr(PECB_FUNCTION_LITERAL,1,4) = 'EXEC' |, + Substr(PECB_FUNCTION_LITERAL,1,4) = 'BACK') then, + Do + If TraceRQ = 'Y' then Say 'C1UEXTR7 is exiting @160 ' + PKGESHIP_Parm = Copies(' ',055) + PKGESHIP_Parm = Overlay(PECB_PACKAGE_ID ,PKGESHIP_Parm,001) + PKGESHIP_Parm = Overlay(PHDR_PKG_ENV ,PKGESHIP_Parm,018) + PKGESHIP_Parm = Overlay(PHDR_PKG_STGID ,PKGESHIP_Parm,027) + PKGESHIP_Parm = Overlay(REXX_EXEC_MODE ,PKGESHIP_Parm,028) + PKGESHIP_Parm = Overlay(PHDR_PKG_CREATE_USER,PKGESHIP_Parm,029) + PKGESHIP_Parm = Overlay(PHDR_PKG_UPDATE_USER,PKGESHIP_Parm,037) + PKGESHIP_Parm = Overlay(PHDR_PKG_CAST_USER ,PKGESHIP_Parm,045) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE1 ,PKGESHIP_Parm,054) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE2 ,PKGESHIP_Parm,114) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE3 ,PKGESHIP_Parm,174) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE4 ,PKGESHIP_Parm,234) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE5 ,PKGESHIP_Parm,294) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE6 ,PKGESHIP_Parm,354) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE7 ,PKGESHIP_Parm,414) + PKGESHIP_Parm = Overlay(PHDR_PKG_NOTE8 ,PKGESHIP_Parm,474) + If Substr(PECB_FUNCTION_LITERAL,1,4) = 'BACK' then, + PKGESHIP_Parm = Overlay('BAK' ,PKGESHIP_Parm,584) + Else, + PKGESHIP_Parm = Overlay('OUT' ,PKGESHIP_Parm,584) + Call PKGESHIP PKGESHIP_Parm + If TraceRQ = 'Y' then Say 'C1UEXTR7 is exiting @183 ' + Exit + End + /* This code runs when you want to force CASTs to run in batch */ + If PECB_FUNCTION_LITERAL ='CAST' &, + PECB_SUBFUNC_LITERAL ='CAST' &, + PECB_BEF_AFTER_LITERAL ='BEFORE' &, + PHDR_PACKAGE_STATUS ='IN-EDIT' &, + PECB_MODE = "T" &, /* TSO foreground */ + (Force_CAST_in_Batch= 'Y' | Cast_with_SonarQube= 'Y') then, + Do + ModelMember = 'CAST#JCL' + Call SubmitBatchJCL + Message = JobData + MyRc = 8 + PACKAGE = PECB_PACKAGE_ID + MessageCode = 'U033' + Call SetExitReturnInfo + Exit + End + /* If we have any issues up at this point */ + /* set the Exit's return code and get out */ + If MyRc > 0 then, + Do + Call SetExitReturnInfo + Exit + End + /* Considering a SonarQube scan... ( +COB in description) */ + /* Does PACKAGE builder indicate the package has COBOL ? */ + thisPackageHasCobol = 'N' + If Substr(PREQ_PACKAGE_COMMENT,47,4) = '+COB' then, + thisPackageHasCobol = 'Y' + /* Considering a SonarQube scan... ( +COB in description) */ + /* If running in Batch and ... execute SonarQube Analysis*/ + IF Cast_with_SonarQube= 'Y' &, + thisPackageHasCobol= 'Y' &, + PECB_FUNCTION_LITERAL = 'CAST' &, + PECB_BEF_AFTER_LITERAL = 'MID' &, + PECB_MODE = "B" then, /* running in Batch */ + Do + AllNotes = PHDR_PKG_NOTE1 ||, + PHDR_PKG_NOTE2 ||, + PHDR_PKG_NOTE3 ||, + PHDR_PKG_NOTE4 ||, + PHDR_PKG_NOTE5 ||, + PHDR_PKG_NOTE6 ||, + PHDR_PKG_NOTE7 ||, + PHDR_PKG_NOTE8 + Upper AllNotes + If Pos('BYPASS SONARQUBE', AllNotes) > 0 then, + Say 'C1UEXTR7- A bypass of SonarQube processing', + 'is requested in the package notes' + Else, + Do /*Execute SonarQube*/ + Message = SONRQUBE(PECB_PACKAGE_ID); + If Message /= '' then, + Do + MyRc = 8 + Call SetExitReturnInfo + End + Exit + End /* Else.. If Pos('BYPASS SONARQUBE' */ + End /* IF Cast_with_SonarQube= 'Y' .... */ + /* Enforce packages to be Backout Enabled */ + IF PREQ_BACKOUT_ENABLED /= 'Y' then, + Do + Message = 'C1UEXTR7 - Package made to be Backout enabled' + MyRc = 4 + hexAddress = D2X(Address_PREQ_BACKOUT_ENABLED) + storrep = STORAGE(hexAddress,,'Y') + Call SetExitReturnInfo + Exit + End; + EXIT + /* Early outs .... */ + If PECB_FUNCTION_LITERAL = 'SETUP' then Exit + /* Work in progress .... */ + /* Unspecified about SonarQube? Let NOTES decide.... */ + If Cast_with_SonarQube /= 'N' then, + Do + End /* If Cast_with_SonarQube /= 'N' */ + If PECB_FUNCTION_LITERAL ='CAST' &, + PECB_SUBFUNC_LITERAL ='CAST' &, + PECB_BEF_AFTER_LITERAL ='AFTER' then, + Call ManageEmails ; + Exit +ManageEmails: + If TraceRQ = 'Y' then Trace ?R + whereami = 'ManageEmails' + /* Only run if the exit is giving us an Approver Group */ + If Substr(CALL_REASON,1,16) = 'APPROVER GROUP #' then, + Do + Call SaveOffApproverGrpInfo + Return + End + /*****************************************************************/ + /* Initializaztion and Example statements */ + /*****************************************************************/ + MySMTP_Message =, + 'YOURSITE.NDVR.REXX(C1UEXTR7)' + MySMTP_Message =, + 'SHARE.ENDV.SHARABLE.REXX(C1UEXTR7)' + MySMTP_Subject = 'Please Approve Package' PECB_PACKAGE_ID + MySMTP_From = Left('YOURSITE your testing Endevor',50) + MySMTP_textline.1 = 'Package' PECB_PACKAGE_ID, + ' has been CAST and is ready for APPROVAL.' + MySMTP_textline.2 = 'Your Review and approval of package', + PECB_PACKAGE_ID 'is reqested.' + MySMTP_textline.3 = ' ' + MySMTP_textline.4 = ' ' + MySMTP_textline.0 = 4 + MYSMTP_EMAIL_IDS = '' + /* Only run if the exit says all Approver Grps are done */ + If Substr(CALL_REASON,1,22) = 'NO MORE APPROVER GRPS ' then, + Do + Call CheckApproverGroupSequence + Return + End + Return +SaveOffApproverGrpInfo: + If TraceRQ = 'Y' then Trace ?R + PAPP_SEQUENCE_NUMBER = Substr(CALL_REASON,17,4) + numberQueued = QUEUED() + If PAPP_SEQUENCE_NUMBER = "0001" & numberQueued > 0 then, + Do numberQueued /* Clear out whatever is queued */ + pull leftovers + End + If PAPP_SEQUENCE_NUMBER = "0001" then, + CALL BPXWDYN , /* save Approver group data */ + "ALLOC DD(C1UEXTD7) LRECL(180) BLKSIZE(18000) SPACE(1,1) ", + " RECFM(F,B) TRACKS ", + " MOD UNCATALOG REUSE "; + pkgGrp# = Strip(PAPP_SEQUENCE_NUMBER,'L','0') + PAPP_GROUP_NAME = Strip(PAPP_GROUP_NAME) + Queue 'pkgGrp# = 'pkgGrp# + Queue 'GROUP_NAME.pkgGrp# ="'PAPP_GROUP_NAME'"' + Queue 'ENVIRONMENT.pkgGrp# ="'Strip(PAPP_ENVIRONMENT)'"' + Queue 'APPR_GRP_TYPE.pkgGrp# ="'Strip(PAPP_APPR_GRP_TYPE)'"' + Queue 'APPR_GRP_DISQ.pkgGrp# ="'Strip(PAPP_APPR_GRP_DISQ)'"' + Queue 'APPROVAL_FLAGS.pkgGrp# ="'Strip(PAPP_APPROVAL_FLAGS)'"' + Queue 'STATUS.'PAPP_GROUP_NAME '="'Strip(PAPP_APPROVER_FLAG)'"' + Queue 'QUORUM.'PAPP_GROUP_NAME '='Strip(PAPP_QUORUM_COUNT,'L','0') + Queue 'USRLST.'PAPP_GROUP_NAME '="'Strip(PAPP_APPROVAL_IDS)'"' + numberQueued = QUEUED() + "EXECIO" numberQueued " DISKW C1UEXTD7 " + Return; +CheckApproverGroupSequence: + If TraceRQ = 'Y' then Trace ?R + whereami = 'CheckApproverGroupSequence' + /* If C1UEXTD7 is allocated to anything, we have approvers */ + WhatDDName = 'C1UEXTD7' + CALL BPXWDYN "INFO FI("WhatDDName")", + "INRTDSN(DSNVAR) INRDSNT(myDSNT)" + If Substr(DSNVAR,1,1) = ' ' then Return + "EXECIO 0 DISKW C1UEXTD7 (Finis" + "EXECIO * DISKR C1UEXTD7 (Finis" + CALL BPXWDYN "FREE DD(C1UEXTD7)" + numberQueued = QUEUED() + /* Analyze Exit-provided Approver Group info */ + pkgGrp# = 0 + /* By default, ordered Approver Groups are not related */ + STATUS. = 'NotRelated' + QUORUM. = 0 + /* Return Approver Group info for this package */ + Do q# = 1 to numberQueued + Parse Pull something + If TraceRQ = 'Y' then say "@187" something + interpret something + End; + ThisEnvironment = ENVIRONMENT.pkgGrp# + /* Read the site's required Approver Group sequencing */ + CALL BPXWDYN, + "ALLOC DD(APPROVER) DA('"ApproverGroupSequence"') SHR REUSE" + "EXECIO * DISKR APPROVER (Stem ordered. Finis" + CALL BPXWDYN "FREE DD(APPROVER)" + /* Build a sequenced list of all named Approver Groups */ + OrderedApproverGroups = '' + /* Set a default value to be 1 greater than number of groups */ + NotOrdered = ordered.0 + 1 + Sequence. = NotOrdered + Do ord# = 1 to ordered.0 + orderedEntry = ordered.ord# + orderedEnv = Word(orderedEntry,1) + If orderedEnv /= thisEnvironment then iterate + orderedApproverGroup = Word(orderedEntry,2) + If orderedApproverGroup = 'AllOthers' then, + DefaultOrder = ord# + SEQUENCE.orderedApproverGroup = ord# + If TraceRQ = 'Y' then, + say "@201 Sequence for" orderedApproverGroup "is" ord# + End; /* Do ord# = 1 to ordered.0 */ + Sequence.NotOrdered = DefaultOrder + unsorted_list = "" + /* Build a list of Approver Groups for this package */ + PackageApproverGroups = '' + Do p# = 1 to pkgGrp# + PackageApproverGroup = GROUP_NAME.p# + thisSequence = SEQUENCE.PackageApproverGroup + entry = Right(thisSequence,4,'0') || '.' ||, + PackageApproverGroup + unsorted_list = unsorted_list entry + If TraceRQ = 'Y' then, + Say "unsorted_list=" unsorted_list + End; + Call SortApproverGroupList; + If TraceRQ = 'Y' then say "@220 PackageApproverGroups =", + sorted_list, + ' ThisEnvironment =' ThisEnvironment + /* Go through the Sorted list to identify the status */ + /* of the next group(s) to be approved */ + /* Find the 1st Approver group this user belongs to.... */ + thisApprover = USERID() + lastSequence = NotOrdered + Do seq# = 1 to Words(sorted_list) + entry = Word(sorted_list,seq#) + Parse Var entry thisSequence '.' orderedApproverGroup + orderedGroupStatus = STATUS.orderedApproverGroup + If orderedGroupStatus = 'APPROVED' then Iterate; + orderedGroupQuorum = QUORUM.orderedApproverGroup + If orderedGroupQuorum = 0 then Iterate; + If thisSequence > lastSequence then, + Do + Sa= 'We need to wait' + Leave; + End; + lastSequence = thisSequence + ListApprovers = USRLST.orderedApproverGroup + whereApprover = Wordpos(thisApprover,ListApprovers) + thisApproversFlag = " " + If whereApprover > 0 then, + Do + thisApproverGroup = orderedApproverGroup + thisApproversFlag = Word(APPROVAL_FLAGS.grp#,whereApprover) + End + If TraceRQ = 'Y' then, + Say orderedApproverGroup 'has status of' orderedGroupStatus, + " Quorum" orderedGroupQuorum + IF whereApprover > 0 &, + orderedGroupStatus /= 'NotRelated' then, + sa= 'You must wait for the' orderedApproverGroup, + " group's approval" + If Words(ListApprovers) > 0 then, + Do w# = 1 to Words(ListApprovers) + Approver = Word(ListApprovers,w#) + If Wordpos(Approver,MYSMTP_EMAIL_IDS) = 0 &, + Substr(Approver,1,1) > '00'X then, + MYSMTP_EMAIL_IDS = MYSMTP_EMAIL_IDS Approver + End; /* Do w# = 1 to Words(ListApprovers) */ + End; /* Do seq# = 1 to Words(sorted_list) */ + /* Prepare email to the usrids in MYSMTP_EMAIL_IDS */ + Call PrepareEmail + Return; +SortApproverGroupList: + If TraceRQ = 'Y' then Trace ?R + whereami = 'SortApproverGroupList' + sa= words(unsorted_list) unsorted_list; + drop sorted_list; + sorted_list = ""; + do forever ; + if words(unsorted_list) = 0 then leave; + lowest_entry = 1; + do entry = 1 to words(unsorted_list) + if word(unsorted_list,entry) <, + word(unsorted_list,lowest_entry) then, + lowest_entry = entry; + end; /* do entry = 1 .... */ + sorted_list = sorted_list word(unsorted_list,lowest_entry); + sa= "sorted_list=" sorted_list ; + position = wordindex(unsorted_list,lowest_entry) ; + len = length(word(unsorted_list,lowest_entry)); + unsorted_list =, + overlay(copies(" ",len),unsorted_list,position) ; + sa= "unsorted_list=" unsorted_list ; + end; /* do forever */ + drop unsorted_list; + sa= words(sorted_list) sorted_list; + Return; +PrepareEmail: + If TraceRQ = 'Y' then Trace ?R + whereami = 'PrepareEmail' +/* Here you can make last-moment adjustments to the email */ + shortlist = Substr(MYSMTP_EMAIL_IDS,1,100) + If Substr(MYSMTP_EMAIL_IDS,100,1) /= ' ' &, + Substr(MYSMTP_EMAIL_IDS,101,1) /= ' ' then, + Do + whereEnd = WordIndex(shortlist,Words(shortlist)) + shortlist = DELWORD(shortlist,whereEnd) + End + MySMTP_textline.4 = 'Sent to Group:' shortlist +/* Code in the section below should not be changed */ +/* Code in the section below should not be changed */ +/* Code in the section below should not be changed */ + MySMTP_Message = Left(MySMTP_Message,80) + hexAddress = D2X(Address_MYSMTP_MESSAGE) + storrep = STORAGE(hexAddress,,Message) + MySMTP_From = Left(MySMTP_From,50) + hexAddress = D2X(Address_MYSMTP_FROM) + storrep = STORAGE(hexAddress,,MySMTP_From) + MySMTP_Subject = Left(MySMTP_Subject,50) + hexAddress = D2X(Address_MySMTP_Subject) + storrep = STORAGE(hexAddress,,MySMTP_Subject) +/* If TraceRQ = 'Y' then Trace ?r */ + MYSMTP_COUNTER = '' + numberLines = Right(MySMTP_textline.0,2,'0') + Do l# = 1 to Length(numberLines) + MYSMTP_COUNTER = MYSMTP_COUNTER ||, + 'F' || Substr(numberLines,l#,1) + End + If TraceRQ = 'Y' then say 'MYSMTP_COUNTER=' MYSMTP_COUNTER + MYSMTP_TEXT = X2C(MYSMTP_COUNTER) + Do line# = 1 to numberLines + MYSMTP_TEXT = MYSMTP_TEXT || Left(MySMTP_textline.line#,133) + End; /* Do line# = 1 to MySMTP_textline.0 */ + hexAddress = D2X(Address_MYSMTP_TEXT) + storrep = STORAGE(hexAddress,,MYSMTP_TEXT) + MySMTP_URL = 'N' + hexAddress = D2X(Address_MYSMTP_URL) + storrep = STORAGE(hexAddress,,MySMTP_URL) + /* Provide distribution list ( list of userids ) to Exit */ + MYSMTP_EMAIL_IDS =, + Space(Strip(Translate(MYSMTP_EMAIL_IDS,' ','00'x))) + MYSMTP_EMAIL_IDS = MYSMTP_EMAIL_IDS '0000'x + MYSMTP_EMAIL_IDS = Left(MYSMTP_EMAIL_IDS,MYSMTP_EMAIL_ID_SIZE) + hexAddress = D2X(Address_MYSMTP_EMAIL_IDS) + storrep = STORAGE(hexAddress,,MYSMTP_EMAIL_IDS) + Return; +SubmitBatchJCL: + If TraceRQ = 'Y' then Trace ?R + whereami = 'SubmitBatchJCL' + /* Variable settings for each site ---> */ + WhereIam = WHERE@M1() + interpret 'Call' WhereIam "'MySENULibrary'" + MySENULibrary = Result + interpret 'Call' WhereIam "'MySEN2Library'" + MySEN2Library = Result + interpret 'Call' WhereIam "'MyCLS0Library'" + MyCLS0Library = Result + interpret 'Call' WhereIam "'MyCLS2Library'" + MyCLS2Library = Result + Unique_Name = GTUNIQUE() + /* Get job-related information from low address locations */ + MyAccountingCode = GETACCTC() + job_name = MVSVAR('SYMDEF',JOBNAME ) /*Returns JOBNAME */ + Jobname= BUMPJOB(job_name) + /* Prepare and run a Table Tool to build CAST jcl....... */ + CALL BPXWDYN , + "ALLOC DD(TABLE) LRECL(80) BLKSIZE(27920) SPACE(1,1) ", + " RECFM(F,B) TRACKS ", + " NEW UNCATALOG REUSE "; + Queue "* Do" + Queue " * " + "EXECIO 2 DISKW TABLE (FINIS "; /* count queued */ + CALL BPXWDYN "ALLOC DD(NOTHING) DUMMY" + CALL BPXWDYN , + "ALLOC DD(OPTIONS) LRECL(80) BLKSIZE(27920) SPACE(1,1) ", + " RECFM(F,B) TRACKS ", + " NEW UNCATALOG REUSE "; + QUEUE "$nomessages ='Y'" + QUEUE "MyAccountingCode='"MyAccountingCode"'" + QUEUE "MySEN2Library ='"MySEN2Library"'" + QUEUE "MySENULibrary ='"MySENULibrary"'" + QUEUE "MyCLS0Library ='"MyCLS0Library"'" + QUEUE "MyCLS2Library ='"MyCLS2Library"'" + QUEUE "Unique_Name ='"Unique_Name"'" + QUEUE "PECB_PACKAGE_ID ='"PECB_PACKAGE_ID"'" + QUEUE "Jobname= '"Jobname"'" + QUEUE "TBLOUT = 'SUBMTJCL'" + "EXECIO 10 DISKW OPTIONS (FINIS "; /* count queued */ + /* For CASTing a package in Batch */ + /* Build a JCL model, and name its location here.... */ + /* Name a work dataset to be created then deleted... */ + Jcl2SumbitModel = MySEN2Library || '(' || ModelMember || ')' + "ALLOC F(MODEL) DA('"Jcl2SumbitModel"') SHR REUSE" + /* Build the JCL for a Batch Cast */ + CastPackageJCL = USERID()".C1UEXTR7.SUBMIT."Unique_Name + "ALLOC F(SUBMTJCL) DA('"CastPackageJCL"') ", + "LRECL(80) BLKSIZE(16800) SPACE(5,5)", + "RECFM(F B) TRACKS ", + "NEW CATALOG REUSE " ; + myRC = ENBPIU00("A") + "EXECIO 0 DISKW SUBMTJCL (Finis" + "FREE DD(TABLE) " + "FREE DD(NOTHING) " + "FREE DD(OPTIONS) " + "FREE DD(MODEL) " + Call Submit_n_save_jobInfo ; + "FREE F(SUBMTJCL) DELETE " + Return; +Submit_n_save_jobInfo: /* submit Jcl2SumbitModel job and save job info */ + If TraceRQ = 'Y' then Trace ?R + whereami = 'Submit_n_save_jobInfo' + If TraceRQ = 'Y' then Say 'Submit_n_save_jobInfo:' + Address TSO "PROFILE NOINTERCOM" /* turn off msg notific */ + CALL MSG "ON" + CALL OUTTRAP "out." + ADDRESS TSO "SUBMIT '"CastPackageJCL"'" ; + If RC > 4 then, + Do + MyRC = 8 + Message = 'Cannot find Element member to submit.' + Call SetExitReturnInfo + Exit(12) + End + CALL OUTTRAP "OFF" + Address TSO "PROFILE INTERCOM" /* turn on msg notific */ + JobData = Strip(out.1); + jobinfo = Word(JobData,2) ; + If jobinfo = 'JOB' then, + jobinfo = Word(JobData,3) ; + SelectJobName = Word(Translate(jobinfo,' ',')('),1) ; + SelectJobNumber = Word(Translate(jobinfo,' ',')('),2) ; + Return; +Allocate_Files_For_CSV_and_API: + STRING = "ALLOC DD(C1MSGS1) DUMMY " + CALL BPXWDYN STRING; + STRING = "ALLOC DD(BSTERR) DA(*) " + CALL BPXWDYN STRING; + STRING = "ALLOC DD(BSTAPI) DA(*) " + CALL BPXWDYN STRING; + STRING = "ALLOC DD(MSGFILE) LRECL(133) BLKSIZE(26600) ", + " DSORG(PS) ", + " SPACE(5,5) RECFM(F,B) TRACKS ", + " NEW UNCATALOG REUSE "; + CALL BPXWDYN STRING; + Return; +FREE_Files_For_CSV_and_API: + CALL BPXWDYN STRING; + STRING = "FREE DD(C1MSGS1)" ; + CALL BPXWDYN STRING; + STRING = "FREE DD(BSTERR)" ; + CALL BPXWDYN STRING; + STRING = "FREE DD(BSTAPI)" ; + CALL BPXWDYN STRING; + STRING = "FREE DD(MSGFILE)"; + CALL BPXWDYN STRING; + Return; +CSV_to_List_Package_Actions: + /* Get Package Action information for SonarQube preparations */ + STRING = "ALLOC DD(EXTRACTM) LRECL(4000) BLKSIZE(32000) ", + " DSORG(PS) ", + " SPACE(1,5) RECFM(F,B) TRACKS ", + " NEW UNCATALOG REUSE "; + CALL BPXWDYN STRING; + STRING = "ALLOC DD(BSTIPT01) LRECL(80) BLKSIZE(800) ", + " DSORG(PS) ", + " SPACE(1,5) RECFM(F,B) TRACKS ", + " NEW UNCATALOG REUSE "; + CALL BPXWDYN STRING; + QUEUE "LIST PACKAGE ACTION FROM PACKAGE '"PECB_PACKAGE_ID"'" + QUEUE " TO DDNAME 'EXTRACTM' " + QUEUE " ." + "EXECIO" QUEUED() "DISKW BSTIPT01 (FINIS "; + ADDRESS LINK 'BC1PCSV0' ; /* load from authlib */ + call_rc = rc ; + "EXECIO * DISKR EXTRACTM (STEM CSV. finis" + STRING = "FREE DD(EXTRACTM)" ; + CALL BPXWDYN STRING; + STRING = "FREE DD(BSTIPT01)" ; + /* To Search the package action data in CSV format. */ + /* Identify matches with Rules file, determining Ship Dests */ + IF CSV.0 < 2 THEN RETURN; + /* CSV data heading - showing CSV variables */ + $table_variables= Strip(CSV.1,'T') + $table_variables = translate($table_variables,"_"," ") ; + $table_variables = translate($table_variables," ",',"') ; + $table_variables = translate($table_variables,"@","/") ; + $table_variables = translate($table_variables,"@",")") ; + $table_variables = translate($table_variables,"@","(") ; + WantedCSVVariables= , + "ELM_@S@ ENV_NAME_@S@ STG_ID_@S@ ", + "SYS_NAME_@S@ SBS_NAME_@S@ TYPE_NAME_@S@ " + Do rec# = 2 to CSV.0 + $detail = CSV.rec# + Drop SBS_NAME_@T@ + Trace Off + /* Parse CSV fields in the Detail record until done */ + Do $column = 1 to Words($table_variables) + Call ParseDetailCSVline + End + If TraceRc = 1 then Trace r + IF Substr(ENV_NAME_@S@,1,1) = '00'x |, + Substr(ENV_NAME_@S@,1,1) = ' ' then Iterate; + elm# = Elements.0 + 1 + Elements.elm# = ELM_@S@ ENV_NAME_@S@ STG_ID_@S@, + SYS_NAME_@S@ SBS_NAME_@S@ TYPE_NAME_@S@ + Elements.0 = elm# + Sa= 'Messages from C1UEXTR7:' Elements.elm# + Trace Off + End; /* Do rec# = 1 to CSV.0 */ + RETURN ; +ParseDetailCSVline: + /* Find the data for the current $column */ + $dlmchar = Substr($detail,1,1); + If $dlmchar = "'" then, + Do + SA= 'parsing with single quote ' + PARSE VAR $detail "'" $temp_value "'" $detail ; + If Substr($detail,1,1) = ',' then, + $detail = Strip(Substr($detail,2),'L') + End + Else, + If $dlmchar = '"' then, + Do + SA= 'parsing with double quote ' + PARSE VAR $detail '"' $temp_value '"' $detail ; + If Substr($detail,1,1) = ',' then, + $detail = Strip(Substr($detail,2),'L') + End + Else, + If $dlmchar = ',' then, + Do + SA= 'parsing with comma ' + PARSE VAR $detail ',' $temp_value ',' $detail ; + If Substr($detail,1,1)/= ',' then, + $detail = "," || $detail + $detail = Strip(Substr($detail,2),'L') */ + End + Else, + If Words($detail) = 0 then, + $temp_value = ' ' + Else, + Do + SA= 'parsing with comma ' + PARSE VAR $detail $temp_value ',' $detail ; + Sa= '$temp_value=>' $temp_value '<' + End + $temp_value = STRIP($temp_value) ; + $rslt = $temp_value + $rslt = Strip($rslt,'B','"') ; + $rslt = Strip($rslt,'B',"'") ; + if Length($rslt) < 1 then $rslt = ' ' + thisVariable = WORD($table_variables,$column) + If Wordpos(thisVariable,WantedCSVVariables) = 0 then Return + if Length($rslt) < 250 then, + $temp = WORD($table_variables,$column) '= "'$rslt'"'; + Else, + $temp = WORD($table_variables,$column) "=$rslt" + INTERPRET $temp; + If rec# < 3 then Say $temp + RETURN ; +SetExitReturnInfo: + If TraceRQ = 'Y' then Trace ?R + whereami = 'SetExitReturnInfo' + If TraceRQ = 'Y' then Say 'SetExitReturnInfo: ' + hexAddress = D2X(Address_PECB_MESSAGE) + storrep = STORAGE(hexAddress,,Message) + hexAddress = D2X(Address_PECB_ERROR_MESS_LENGTH) + storrep = STORAGE(hexAddress,,'0084'X) + hexAddress = D2X(Address_PECB_MODS_MADE_TO_PREQ) + storrep = STORAGE(hexAddress,,'Y') + If MessageCode /= ' ' then, + Do + hexAddress = D2X(Address_PECB_MESSAGE_ID) + storrep = STORAGE(hexAddress,,MessageCode) + End +/* Set the return code for the exit */ +/* for PECB-NDVR-EXIT-RC */ + hexAddress = D2X(Address_PECB_NDVR_EXIT_RC) + If MyRc = 4 then, + storrep = STORAGE(hexAddress,,'00000004'X) + Else, + storrep = STORAGE(hexAddress,,'00000008'X) + RETURN ; diff --git a/endevor/Field-Developed-Programs/Package-Automation/README.md b/endevor/Field-Developed-Programs/Package-Automation/README.md index 0695c88..fdee883 100644 --- a/endevor/Field-Developed-Programs/Package-Automation/README.md +++ b/endevor/Field-Developed-Programs/Package-Automation/README.md @@ -96,33 +96,17 @@ You can find the code for JCLCOMMT.rex in the [ISPF-tools-for-Quick-Edit-and-End The commnenting will allow you to reveiew your package shipping (and other) jobs, and know the element or member name that contains the lines of JCL. -## Find items at the these locations: +## Items outside of this folder, that might be a part of your solution: -**item** Location -**@site.rex** - endevor\Field-Developed-Programs\Package-Automation +[**BPXWDYN**](https://www.ibm.com/docs/en/zos/3.2.0?topic=guide-dynamic-allocation) - a Dynamic Allocation routine from IBM -**BILDTGGR.rex** - endevor\Field-Developed-Programs\Package-Automation - -**PKGESHIP.rex** - endevor\Field-Developed-Programs\Package-Automation - -**PULLTGGR.rex** - endevor\Field-Developed-Programs\Package-Automation - -**SHIP#FTP.skl** - endevor\Field-Developed-Programs\Package-Automation - -**other models** - endevor\Field-Developed-Programs\Package-Automation - -**SHIPRULE** - endevor\Field-Developed-Programs\Package-Automation - -**TBLUNLOD.rex** - endevor\Field-Developed-Programs\Package-Automation - -**Trigger** - endevor\Shipments-for-Multiple-Destinations + endevor\Field-Developed-Programs\Package-Automation - -**UPDTTGGR.rex** - endevor\Field-Developed-Programs\Package-Automation - -**WHERE@M1.rex** - endevor\Field-Developed-Programs\Package-Automation +[**GTUNIQUE**](https://github.com/BroadcomMFD/broadcom-product-scripts/blob/main/endevor/Field-Developed-Programs/Miscellaneous-items/GTUNIQUE.rex) - returns a unique 8-byte name, base on date and time, that can be used as a dataset node. + +[**GETACCTC**](https://github.com/BroadcomMFD/broadcom-product-scripts/blob/main/endevor/Field-Developed-Programs/Miscellaneous-items/GETACCTC.rex) - returns the "accounting code" for the current user id. -**WHEREAMI.rex** - endevor\Field-Developed-Programs\Package-Automation +[**JCLCOMMT.rex**](https://github.com/BroadcomMFD/broadcom-product-scripts/blob/main/endevor/Field-Developed-Programs/ISPF-tools-for-Quick-Edit-and-Endevor/JCLCOMMT.rex) - an edit macro that comments JCL, Skeletons and processors. -**JCLCOMMT.rex** - endevor\Field-Developed-Programs\ISPF-tools-for-Quick-Edit-and-Endevor +**ENTBJAPI** - see member BC1JAAPI in your CSIQJCL library. +[**BKOUTLOG**](https://github.com/BroadcomMFD/broadcom-product-scripts/blob/Package-Backout-Logging/endevor/Field-Developed-Programs/Package-Automation/Package-Backout-Logging/BKOUTLOG.rex) - for logging package Backout and BackIn actions. (currently in a branch) \ No newline at end of file