When I joined GE in October 1989 I went from a TSO/ISPF environment to one that was using CA/ROSCOE. There were several challenges to overcome to adjust to the different environment. One distinct difference between TSO/ROSCOE is that ROSCOE libraries/members are stored in a proprietary format - they can not be accessed the same as a PDS (Partitioned Data Set) member by adding a DD (Data Definition) in your JCL. A ROSCOE member must be exported to a sequential file which can be cumbersome and completely unnecessary. After doing some research I found ROSCOE is delivered with User Library Interface (LIBI) macros. See CA/ROSCOE PDF.
Instead of incorporating these LIBI macros in each application program that needed to read a Roscoe Member I took a better approach & encapsulated them in an all-purpose subroutine. It can be accesses by Assembler, COBOL, Eazytrieve or any other language that supports Assembler Calls.
I named the new module GETROS since it's function is to "Get Roscoe Records". When you supply a Prefix (in my case "TD") and a library member name it will locate the member & upon each call return a single record. The GETROS routine should be placed within a simple loop that will end once an End-Of-File condition is returned (Basic instructions are included in the GETROS program header).
GETROS Code:
TITLE 'GETROS - READ ROSCOE MEMBER INPUT CARDS // TONY DELIA'
***********************************************************************
* *
* MODULE: GETROS. *
* AUTHOR: TONY DELIA. *
* DATE: 01/03/1990. *
* DESC: READ ROSCOE INPUT MEMBER (SIMILAR TO GETCARD). *
* FORMAT: CALL GETROS,(ROSAREA) *
* PARMS: ROSAREA CONSISTS OF THE FOLLOWING- *
* *
* ROSAREA DC A(ROSEOF) -END-OF-FILE ADDRESS *
* ROSABND DC A(ROSAB) -ABEND ADDRESS *
* ROSPFX DC CL2'XX' -USER PREFIX *
* ROSMEM DC CL8'XXXXXXXX' -MEMBER NAME *
* ROSREC DC CL256' ' -RECORD BUFFER AREA *
* *
* NOTE: IN THE EVENT OF AN ABEND, 'ROSREC' AREA IS FILLED *
* WITH A 26-BYTE MESSAGE INDICATING CAUSE OF ABEND. *
* *
* IF NO EOF OR ABEND ADDRESS IS PROVIDED, ROSAREA *
* AND ROSABND MUST BE SET TO ZERO. WHEN EOF IS *
* REACHED, ROSAREA = 'END*'. WHEN ABEND CONDITION, *
* ROSABND = 'ABND'. THESE CAN BE TESTED FROM WITHIN *
* THE CALLING PROGRAM. *
* *
***********************************************************************
EJECT
***********************************************************************
* G E T R O S P R O G R A M *
***********************************************************************
GETROS CSECT BEGIN PROGRAM
STM 14,12,12(13) SAVE REGISTERS
LR 12,15 LOAD PROGRAM ENTRY POINT
USING GETROS,12 SET UP BASE NUMBER 1
L 11,BASE2 LOAD BASE 2 ADDRESS
USING GETROS+4096*1,11 SET UP BASE NUMBER 2
L 10,BASE3 LOAD BASE 3 ADDRESS
USING GETROS+4096*2,10 SET UP BASE NUMBER 3
ST 13,SAVE+4 SAVE EXTERNAL SAVE AREA
LR 14,13 HOLD EXTERNAL ADDR IN R14
LA 13,SAVE LOAD INTERNAL SAVE AREA
ST 13,8(14) SAVE INTERNAL ADDRESS
B GO GO TO MAINLINE PROCESSING
***********************************************************************
RETURN EQU *
L 13,SAVE+4 RESTORE EXTERNAL SAVE ADDR
LM 14,12,12(13) RESTORE ORIGINAL REGISTERS
BR 14 BRANCH BACK TO CALLING PGM
***********************************************************************
SAVE DC 18F'0' REGISTER PRESERVATION AREA
BASE2 DC A(GETROS+4096*1) BASE REGISTER 2 ADDRESS
BASE3 DC A(GETROS+4096*2) BASE REGISTER 3 ADDRESS
EODAD DC A(0) EOF RETURN ADDRESS
ABADDR DC A(0) ABEND RETURN ADDRESS
***********************************************************************
R0 EQU 0 R0 USED BY LIBI MACRO
R15 EQU 15 R15 USED BY LIBI MACRO
***********************************************************************
EJECT
***********************************************************************
* MAINLINE SECTION *
***********************************************************************
GO EQU *
PRINT NOGEN
L 3,0(1) LOAD CALLING PGM PARMAREA
USING XAREA,3 USE XAREA DSECT
LA 4,ROSPARM POINT TO ROSCOE PARM AREA
USING LBPMDEF,4 USE ROSCOE PARM DSECT
*
BC 0,READ AFTER 1ST, GO TO READ
OI *-3,X'F0' SET BRANCH INSTRUCTION
*
MVC EODAD,XEODAD MOVE END-OF-FILE ADDRESS
MVC ABADDR,XABEND MOVE ABEND ADDRESS
MVC PFX,XPFX MOVE PREFIX TO SAVE AREA
MVC MEMBER,XMEM MOVE INPUT MEMBER NAME
BAL 6,ROSINIT ROSCOE INITIALIZATION
BAL 6,ROSFIND FIND ROSCOE MEMBER
READ EQU *
BAL 6,ROSREAD READ ROSCOE MEMBER
MVC XREC,LBPMLINE MOVE RECORD TO TARGET
B RETURN RETURN TO CALLING PROGRAM
EOF EQU *
BAL 6,ROSDONE WRAP UP ROSCOE FUNCTION
L 13,SAVE+4 RESTORE EXTERNAL SAVE ADDR
*
MVC XEODAD,=C'END*' MOVE E-O-F LITERAL SWITCH
L 6,EODAD LOAD EOF-ADDRESS
LTR 6,6 WAS EOF-ADDRESS PROVIDED??
BZ RETURN NO - RETURN VIA R14
MVC 12(4,13),EODAD ALTER RETURN ADDRESS (EOF)
B RETURN RETURN TO CALLING PROGRAM
***********************************************************************
EJECT
***********************************************************************
* ROSCOE "LIBI" FUNCTIONS *
***********************************************************************
* INITIALIZE BATCH INTERFACE / ALLOCATE RESOURCES *
***********************************************************************
CNOP 0,4
ROSINIT EQU *
LIBI FUNC=INITX,LBRB=ROSLBRB
*
LTR 15,15 RETURN CODE = ZERO?
BNZ ERRINITX NO - ERROR ROUTINE
*
LIBI FUNC=ACTIVATE,LBRB=ROSLBRB,PARM=ROSPARM
*
LTR 15,15 RETURN CODE = ZERO?
BNZ ERRACTV NO - ERROR ROUTINE
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
* FIND <PFX>.<MEMBER> / ADD INDEX TO PARAMETER LIST *
***********************************************************************
CNOP 0,4
ROSFIND EQU *
MVI ROSPARM,X'00' HEX ZEROES 1ST BYTE
MVC ROSPARM+1(2),PFX MOVE USER PREFIX
MVI ROSPARM+3,C' ' MOVE BLANK 4TH BYTE
MVC ROSPARM+4(8),MEMBER MOVE DIRECTORY MEMBER
*
LIBI FUNC=FIND,LBRB=ROSLBRB,PARM=ROSPARM
*
LTR 15,15 RETURN CODE = ZERO?
BNZ ERRFIND NO - ERROR ROUTINE
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
* GET NEXT LOGICAL RECORD FROM LIBRARY MEMBER *
***********************************************************************
CNOP 0,4
ROSREAD EQU *
LIBI FUNC=GET,LBRB=ROSLBRB,PARM=ROSPARM
*
LTR 15,15 RETURN CODE = ZERO?
BZ 0(6) YES - BRANCH BAL/REGISTER
CH 15,=H'4' RETURN CODE = 4?
BNE ERRGET NO - ERROR ROUTINE
*
CLI ROSLBRB+(LBRBXRC-LBRB),LBRBXEOF END FILE CONDITION?
BNE ERRGET NO - ERROR ROUTINE
B EOF YES - END OF FILE
***********************************************************************
* FREE LIBRARY RESOURCES / TERMINATE LIBI INTERFACE *
***********************************************************************
ROSDONE EQU *
LIBI FUNC=FREE,LBRB=ROSLBRB
*
LTR 15,15 RETURN CODE = ZERO?
BNZ ERRFREE NO - ERROR ROUTINE
*
LIBI FUNC=TERM,LBRB=ROSLBRB
*
LTR 15,15 RETURN CODE = ZERO?
BNZ ERRTERM NO - ERROR ROUTINE
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
***********************************************************************
* ROSCOE ERROR ROUTINES *
***********************************************************************
ERRINITX EQU *
MVC XREC(26),AB111 MOVE ABEND MESSAGE 111
B ABENDIT GO TO ABEND ROUTINE
ERRACTV EQU *
MVC XREC(26),AB222 MOVE ABEND MESSAGE 222
B ABENDIT GO TO ABEND ROUTINE
ERRFIND EQU *
MVC AB333+14(2),PFX MOVE PREFIX TO AB333
MVC AB333+17(8),MEMBER MOVE MEMBER TO AB333
MVC XREC(26),AB333 MOVE ABEND MESSAGE 333
B ABENDIT GO TO ABEND ROUTINE
ERRGET EQU *
MVC AB444+14(2),PFX MOVE PREFIX TO AB444
MVC AB444+17(8),MEMBER MOVE MEMBER TO AB444
MVC XREC(26),AB444 MOVE ABEND MESSAGE 444
B ABENDIT GO TO ABEND ROUTINE
ERRFREE EQU *
MVC XREC(26),AB555 MOVE ABEND MESSAGE 555
B ABENDIT GO TO ABEND ROUTINE
ERRTERM EQU *
MVC XREC(26),AB666 MOVE ABEND MESSAGE 555
ABENDIT EQU *
L 13,SAVE+4 RESTORE EXTERNAL SAVE ADDR
MVC XABEND,=C'ABND' MOVE ABEND LITERAL SWITCH
L 6,ABADDR LOAD ABEND ADDRESS
LTR 6,6 WAS ABEND ADDR PROVIDED??
BZ RETURN NO - RETURN VIA R14
MVC 12(4,13),ABADDR ALTER RETURN ADDRESS (AB)
B RETURN RETURN TO CALLING PROGRAM
***********************************************************************
AB111 DC CL26'FUNC=INITX '
AB222 DC CL26'FUNC=ACTIVATE '
AB333 DC CL26'FUNC=FIND (XX.XXXXXXXX)'
AB444 DC CL26'FUNC=GET (XX.XXXXXXXX)'
AB555 DC CL26'FUNC=FREE '
AB666 DC CL26'FUNC=TERM '
***********************************************************************
EJECT
***********************************************************************
* WORKING STORAGE *
***********************************************************************
LTORG
***********************************************************************
ROSLBRB DC 8F'0' ROSCOE LIBI FULLWORDS
ROSPARM DC 265C' ' ROSCOE PARM AREA
PFX DC CL2'XX' ROSCOE LIBRARY PREFIX
MEMBER DC CL8'XXXXXXXX' ROSCOE LIBRARY MEMBER
***********************************************************************
LBRB
LBPMDEF
***********************************************************************
XAREA DSECT
XEODAD DS F END-OF-FILE ADDRESS
XABEND DS F ABEND ADDRESS
XPFX DS CL2 USER PREFIX
XMEM DS CL8 MEMBER NAME
XREC DS CL256 TARGET RECORD AREA
***********************************************************************
END GETROS
To validate my GETROS load module I created several Calling Programs - one in Assembler, COBOL & Eazytrieve. Unfortunately I no longer possess many of my older programs including the Eazytrieve version. I lost a lot of brilliant work between 1985 and the early 1990's simply due to lack of reliable storage media. Faulty 5.25 inch disks as well as a totally useless magnetic tape reel (with no tape drive to read it) contributed greatly to the loss... but not everything was gone. Below are the Assembler & COBOL versions (COBOL & Easytrieve are very similar).
Calling Program - Assembler Test - GETROSX:
The READ Loop executes the call as follows: CALL GETROS,(ROSAREA).
No explicit exit from the loop is required since the ROSAREA defintion contains the EOF Address as well as the ABEND address. GETROS will branch to the appropriate address.
TITLE 'GETROSX - GETROS SUBROUTINE TESTING // TONY DELIA'
***********************************************************************
* *
* MODULE: GETROSX. *
* AUTHOR: TONY DELIA. *
* DATE: 01/03/1990. *
* DESC: TEST 'GETROS' ROSCOE INPUT READER. *
* NOTE: PREFIX/MEMBER PASSED VIA JCL EXEC PARM. *
* *
***********************************************************************
EJECT
***********************************************************************
* G E T R O S X P R O G R A M *
***********************************************************************
GETROSX SETUP REGS=(12,11,10) BEGIN PROGRAM
***********************************************************************
* MAINLINE SECTION *
***********************************************************************
PRINT NOGEN
L 3,0(1) LOAD 'EXEC' PARM ADDRESS
MVC PFX,2(3) SAVE PREFIX PARAMETER
MVC MEMBER,5(3) SAVE MEMBER PARAMETER
MVC PRT,PRT-1 CLEAR PRINT LINE
BAL 6,W8B PRINT - PAGE EJECT
***********************************************************************
READ EQU *
CALL GETROS,(ROSAREA) READ ROSCOE INPUT
MVC PRT,RECORD MOVE ROSCOE RECORD TO PRT
BAL 6,W09 PRINT - SPACE 1 LINE
B READ READ NEXT RECORD
***********************************************************************
EOF EQU *
BAL 6,WXX CLOSE PRINT FILE
B RETURN EXIT PROGRAM
***********************************************************************
* ABEND ROUTINE *
***********************************************************************
ABENDIT EQU *
MVC PRT,PRT-1 CLEAR PRINT LINE
BAL 6,W8B PRINT - PAGE EJECT
MVC PRT+1(26),ABTITLE MOVE TITLE LINE
BAL 6,W19 PRINT - SPACE 3 LINES
MVC PRT+1(26),RECORD MOVE ABEND MESSAGE
BAL 6,W09 PRINT - SPACE 1 LINE
BAL 6,WXX CLOSE PRINT FILE
ABEND 111 ISSUE ABEND NO. 111
***********************************************************************
ABTITLE DC CL26'GETROS: READ UTILITY ABEND'
***********************************************************************
EJECT
***********************************************************************
* WORKING STORAGE *
***********************************************************************
TPRNT
LTORG
***********************************************************************
ROSAREA DC A(EOF)
ROSABND DC A(ABENDIT)
PFX DC CL2'**'
MEMBER DC CL8'********'
RECORD DC CL256' '
***********************************************************************
END GETROSX
Calling Program - COBOL Test - GETROSY:
In the COBOL test program the ROSCOE records are read within the ROS-LOOP using this call: CALL 'GETROS' USING ROSAREA. The address fullwords for End-Of-File & Abend Routine are set to zero. The GETROS load module detects this & passes a code of 'EOF*' or 'ABND' instead of branching to an address. The conditions are then 'explicitly' tested & handled appropriately.
******************************************************************
* *
* MODULE: GETROSY.CBL *
* AUTHOR: TONY DELIA. *
* DATE: 01/30/1990. *
* DESC: TEST 'GETROS' ROSCOE INPUT READER. *
* *
******************************************************************
INSTALLATION. TRANSPORT INTERNATIONAL POOL.
*
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT FILOT ASSIGN TO UT-S-FILOT.
*
DATA DIVISION.
FILE SECTION.
FD FILOT
RECORD CONTAINS 132 CHARACTERS
RECORDING MODE IS F
LABEL RECORDS ARE STANDARD
DATA RECORD IS OUT-RECORD.
01 OUT-RECORD PIC X(132).
*
WORKING-STORAGE SECTION.
*
01 ROSAREA SYNC.
05 ROSEOF PIC 9(8) COMP SYNC.
05 ROSEOF-X REDEFINES ROSEOF PIC X(4).
05 ROSAB PIC 9(8) COMP SYNC.
05 ROSAB-X REDEFINES ROSAB PIC X(4).
05 ROSPFX PIC X(2).
05 ROSMEM PIC X(8).
05 ROSREC PIC X(256).
*
PROCEDURE DIVISION.
*
OPEN OUTPUT FILOT.
MOVE 'TD' TO ROSPFX.
MOVE 'ZZZZZPRT' TO ROSMEM.
*****************************************************************
* READ ROSCOE MEMBER / LOOP UNTIL END-OF-FILE *
*****************************************************************
ROS-LOOP.
CALL 'GETROS' USING ROSAREA.
IF ROSEOF-X = 'END*' GO TO END-OF-JOB.
IF ROSAB-X = 'ABND' GO TO ABEND-JOB.
MOVE ROSREC TO OUT-RECORD.
WRITE OUT-RECORD.
GO TO ROS-LOOP.
*****************************************************************
* ABEND DETECTED *
*****************************************************************
ABEND-JOB.
MOVE ROSREC TO OUT-RECORD.
WRITE OUT-RECORD.
*****************************************************************
* END OF JOB *
*****************************************************************
END-OF-JOB.
CLOSE FILOT.
STOP RUN.
*****************************************************************
* END OF PROGRAM *
*****************************************************************
A pretty simple exercise but it ultimately saved countless hours as well as system resources. I was able to directly access the data I needed without the trouble of exporting, creating new datasets & constantly refreshing them as the data changed. The old adage is true, "If you want something done right you have to do it yourself".
This blog post brings back some great memories...
Thursday, April 18, 2019
Monday, April 8, 2019
Resourceful Solution using IBM / DFSORT - E35 Exit Routine
I started my IT career in February 1985 working as a technical consultant at a large banking data center. The systems were based on 1960/70's mainframe technology - DOS/VSE 4331 (Online) & OS/MVS 370 (Batch). Most programs were written in Assembler with a smattering of COBOL. Because there was such a great demand for ad-hoc reporting we had Eazytrieve & later Eazytrieve-Plus (CA Technologies) - these tools were invaluable to quickly provide results to users (as well as perform other critical tasks). I love coding in assembler but there's a lot of overhead & administrative bureaucracy involved to assemble, test & migrate load modules to production.
When I joined a division of GE in October 1989 we had a similar environment except there were no reporting tools. Also, we utilized Roscoe instead of TSO/ISPF but that's another matter. Although we were committed to modernizing all our systems (& would eventually obtain Eazytrieve Plus along the way) that was little help when currently deluged with report & extract requests. Marie in Accounting frequently needed extracts for GL, asset management, payroll, etc. The CFO stopped by frequently for data. The PC revolution was taking off & it seemed more & more users wanted data, ideally on a 5.25 or 3.5 inch disk to import into Alpha-Four.
The situation can be broken down as follows:
A Resourceful Solution - DFSORT's E35 Exit Routine Capability!
At GE, IBM's DFSORT product was used extensively. It commonly appears in our batch JCL processes (often multiple times within a single job). It reads in the file designated by SORTIN, performs the defined sort & writes the output as designated by SORTOUT. You can add criteria to OMIT/INCLUDE records. DFSORT also provides a facility where you can code a custom exit routine - E35 is specifically for sorted output. The E35 routine capability would make DFSORT a perfect custom utility for our purposes...
The idea is to code a routine that allows dynamic column definitions to extract/format the sorted data & write to a file (or print if that's the requirement). The input DD name will be called E35IN & contains the position, length, format & heading of the desired columns. Also, any page headings & page limits (for testing). The extract output will be directed to the DD name of PRINTER.
Sample JCL:
Pulling customer lease data & directing desired columns to a file (specified by PRINTER).
//SORT EXEC PGM=ICEMAN
//MODLIB DD DISP=SHR,DSN=GF.LOAD.LIB
//PRINTER DD SYSOUT=*
//SYSIN DD *
SORT FIELDS=(1,3,BI,A)
RECORD TYPE=F,LENGTH=35
MODS E35=(E35RPT,,MODLIB)
/*
//E35IN DD *
NOHEAD -SUPPRESS HEADING (OPTION)
LEN:0035 -RECORD LENGTH (REQUIRED)
LIM:00100 -REPORT LIMIT (#PAGES)
HD1:E35 ROUTINE - TEST RUN -HEADING 1 UP TO 50 CHARS
HD2:REPORT FORMATTING MODULE -HEADING 2 UP TO 50 CHARS
***:***,***,*,**********************************************
RPT:001,001,X,CO -COL.01 = 'RPT'
RPT:002,002,S,BR -COL.05 = POSITION
RPT:004,004,S,CUST# -COL.09 = LENGTH
RPT:008,004,S,LEASE# -COL.13 = DATA TYPE C,X,S
RPT:012,001,X,SQ -COL.15 = COLUMN HEADINGS
RPT:013,020,C,CUSTOMER NAME -TRUNCATED IF > FIELD LEN.
***:***,***,*,**********************************************
/*
The E35IN definitions are read & stored on the first SORT output pass - all records are then formatted/written based on those definitions. The SYSIN parameters are the same as usual with the exception of the MODS E35=(E35RPT,,MODLIB) definition. All other SORT parameters may be leveraged to further qualify the output data such as OMIT/INCLUDE conditions.
SAMPLE OUTPUT:
CO BR CUST# LEASE# SQ CUSTOMER NAME
** *** ******* ******* ** ********************
02 120 0000014 0769456 99 JOE'S TRUCKING
02 120 0000023 0770034 35 ACME PRODUCTS
02 150 0000345 0880023 30 COMPANY XYZ
...
...
Below is the full E35RPT Module - the macro TPRNT is used to write to the PRINTER DD name via the call to the W09 routine (adheres to the print standards of the organization).
TITLE 'E35RPT - SORT E35 EXIT - FORMAT/PRINT REPORT'
***********************************************************************
* *
* MODULE: E35RPT. *
* AUTHOR: TONY DELIA. *
* DATE: 06/26/90. *
* DESC: DFSORT E35 EXIT - REPORT FORMATTER. *
* *
***********************************************************************
* INSTRUCTIONS/JCL: (INCLUDE WITH STANDARD SORT JCL) *
***********************************************************************
* *
* //SORT EXEC PGM=ICEMAN *
* //MODLIB DD DISP=SHR,DSN=GF.LOAD.LIB *
* //PRINTER DD SYSOUT=* *
* *
* //SYSIN DD * *
* SORT FIELDS=(1,3,BI,A) *
* RECORD TYPE=F,LENGTH=35 *
* MODS E35=(E35RPT,,MODLIB) *
* /* *
* *
* //E35IN DD * *
* NOHEAD -SUPPRESS HEADING (OPTION) *
* LEN:0035 -RECORD LENGTH (REQUIRED) *
* LIM:00100 -REPORT LIMIT (#PAGES) *
* HD1:E35 ROUTINE - TEST RUN -HEADING 1 UP TO 50 CHARS *
* HD2:REPORT FORMATTING MODULE -HEADING 2 UP TO 50 CHARS *
* ***:***,***,*,********************************************** *
* RPT:001,001,X,CO -COL.01 = 'RPT' *
* RPT:002,002,S,BR -COL.05 = POSITION *
* RPT:004,004,S,CUST# -COL.09 = LENGTH *
* RPT:008,004,S,LEASE# -COL.13 = DATA TYPE C,X,S *
* RPT:012,001,X,SQ -COL.15 = COLUMN HEADINGS, *
* RPT:013,020,C,CUSTOMER NAME -TRUNCATED IF > FIELD LEN. *
* ***:***,***,*,********************************************** *
* /* *
* *
***********************************************************************
EJECT
***********************************************************************
* E 3 5 R P T P R O G R A M *
***********************************************************************
PRINT NOGEN
E35RPT CSECT ENTER PROGRAM
STM 14,12,12(13) SAVE REGISTERS
LR 12,15 LOAD PROGRAM ENTRY POINT
USING E35RPT,12 SET UP BASE NUMBER 1
L 11,BASE2 LOAD BASE 2 ADDRESS
USING E35RPT+4096,11 SET UP BASE NUMBER 2
ST 13,SAVE+4 SAVE EXTERNAL SAVE AREA
LR 14,13 HOLD EXTERNAL ADDR IN R14
LA 13,SAVE LOAD INTERNAL SAVE AREA
ST 13,8(14) SAVE INTERNAL ADDRESS
B GO BEGIN MAINLINE PROGRAM
***********************************************************************
RETURN EQU *
L 13,SAVE+4 RESTORE EXTERNAL SAVE ADDR
LM 14,10,12(13) RESTORE ORIGINAL REGISTERS
L 15,RC R15= DFSORT RETURN CODE
L 1,RECADDR R1 = CURRENT RECORD ADDR
LM 11,12,64(13) BASEREGS RESTORED LAST
BR 14 BRANCH BACK TO PLSORT
***********************************************************************
SAVE DC 18F'0' REGISTER PRESERVATION AREA
BASE2 DC A(E35RPT+4096*1) BASE REGISTER 2
RECADDR DC A(0) CURRENT RECORD ADDRESS
RC DC A(0) RETURN CODE AREA
RC0 DC A(0) RETURN CODE = "PROCESS"
RC8 DC A(8) RETURN CODE = "END E35"
RC12 DC A(12) RETURN CODE = "INSERT "
***********************************************************************
EJECT
***********************************************************************
* MAINLINE SECTION *
***********************************************************************
GO EQU *
LM 2,3,0(1) LOAD CURRENT/PREVIOUS ADDR
L 3,RECADDR LOAD PREVIOUS RECORD
ST 2,RECADDR STORE CURRENT RECORD
LTR 2,2 END-OF-FILE ???
BZ ENDFLE YES - WRAP UP LOOSE ENDS
LTR 3,3 1ST TIME THROUGH ???
BNZ *+8 NO - PROCESS SORT RECORD
BAL 6,E35SPEC YES - OBTAIN REPORT SPECS
*
LIMSW BC 15,LIMOK IF NO REPORT LIMIT -BYPASS
CLI OVFL,C'O' PAGE BREAK TIME ???
BNE *+14 NO - PROCESS AS PLANNED
CP PGCT,LIMIT YES - TEST PAGE LIMIT
BNL ENDFLE LIMIT MET- E35RPT COMPLETE
LIMOK EQU *
LA 4,SRTREC POINT TO SORT INPUT BUFFER
LH 5,MAXLEN BUFFER LENGTH IS 4096
LH 3,RECLEN LOAD SORT INPUT LENGTH
ICM 3,B'1000',=X'00' PAD CHARACTER IS HEX ZERO
MVCL 4,2 MOVE SORT INPUT TO BUFFER
*
LA 7,E35TAB POINT TO E35 TABLE
PROCLOOP EQU *
CLI 0(7),X'FF' END-OF-TABLE ???
BE PROCEXIT YES - EXIT LOOP
L 5,0(7) LOAD DATA FIELD ADDRESS
CLI 12(7),C'S' PACKED PRINT FORMAT ???
BE *+12 YES - CONVERT TO HEXPRINT
CLI 12(7),C'X' HEX PRINT FORMAT ???
BNE *+8 NO - SKIP HEX ROUTINE
BAL 6,HEXFMT YES - CONVERT TO HEXPRINT
LH 4,6(7) LOAD PRINT LENGTH
L 6,8(7) LOAD PRINT ADDRESS
EX 4,MVCPRT MOVE DATA TO PRTLINE
LA 7,16(,7) BUMP TO NEXT TABLE ENTRY
B PROCLOOP TEST/BUILD NEXT ENTRY
PROCEXIT EQU *
BAL 6,HEADING CHECK FOR HEADINGS
BAL 6,W09 PRINT - SPACE 1 LINE
MVC RC,RC0 MOVE RETURN CODE 0
B RETURN RETURN TO SORT PROGRAM
***********************************************************************
ENDFLE EQU *
BAL 6,WXX CLOSE PRINT FILE
MVC RC,RC8 MOVE RETURN CODE 8
B RETURN RETURN TO SORT PROGRAM
***********************************************************************
MVCPRT MVC 0(0,6),0(5) R4=LEN/R5=DATA/R6=PRTADDR
***********************************************************************
EJECT
***********************************************************************
* CONVERT DATA TO HEX FORMAT *
***********************************************************************
DC F'0' RETURN ADDRESS SAVE AREA
HEXFMT EQU *
ST 6,*-4 SAVE RETURN ADDRESS
*
LH 4,4(7) LOAD FIELD LENGTH
LA 4,1(,4) ADJUST BY +1
LA 6,HEXDATA LOAD DESTINATION ADDRESS
HEXLOOP EQU *
MVO ARG(2),0(1,5) ISOLATE ZONE PORTION
NI ARG,X'0F' TURN OFF LEFTMOST BITS
TRT ARG,TRTAB TRANSLATE TO CHARACTER
STC 2,0(6) MOVE CHARACTER TO HEXDATA
*
MVN ARG(2),0(5) ISOLATE NUMERIC PORTION
NI ARG,X'0F' TURN OFF LEFTMOST BITS
TRT ARG,TRTAB TRANSLATE TO CHARACTER
STC 2,1(6) MOVE CHARACTER TO HEXDATA
*
LA 6,2(,6) BUMP HEXDATA ADDRESS BY 2
LA 5,1(,5) BUMP FIELD ADDRESS
BCT 4,HEXLOOP REPEAT TIL FIELD CONVERTED
*
LA 5,HEXDATA POINT TO HEX DATA
HEXFMTX EQU *
L 6,HEXFMT-4 RESTORE LINK REGISTER
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
ARG DC CL2' ' ARGUMENT HOLD AREA
TRTAB DC CL16'0123456789ABCDEF' TRANSLATION TABLE
HEXDATA DC CL150' ' HEX CONVERSION AREA
***********************************************************************
EJECT
***********************************************************************
* HEADINGS *
***********************************************************************
DC F'0' RETURN ADDRESS SAVE AREA
HEADING EQU *
ST 6,*-4 SAVE RETURN ADDRESS
*
HEADSW BC 0,HEADINGX SUPPRESS HEADINGS ???
*
CLI OVFL,C'O' HEADINGS NEEDED ???
BNE HEADINGX NO - EXIT ROUTINE
*
MVC HOLDPRT,PRT SAVE CURRENT PRTLINE
MVC PRT,PRT-1 CLEAR PRINT LINE
MVI OVFL,C' ' CLEAR OVERFLOW SWITCH
ZAP LNCT,=P'0' CLEAR LINE COUNTER
BAL 6,W8B PRINT - PAGE EJECT
*
MVC PRT(12),=C'E35RPT: PAGE' MOVE REPORT TITLE/PAGE
AP PGCT,=P'1' ADD +1 TO PAGE COUNTER
MVC PRT+12(6),=X'402020202120' MOVE EDIT PATTERN
ED PRT+12(6),PGCT EDIT PAGE COUNTER
*
MVC PRT+22(8),E35DATE INIT HEADING 1 AREA
CLI HD1,C' ' HEADING 1 REQUIRED ???
BE *+10 NO - DON'T BOTHER
MVC PRT+22(L'HD1),HD1 MOVE HEADING 1
BAL 6,W11 PRINT - SPACE 2 LINES
*
CLI HD2,C' ' HEADING 2 REQUIRED ???
BE *+20 NO - DON'T BOTHER
MVC PRT(8),E35DATE MOVE SYSTEM DATE
MVC PRT+22(L'HD2),HD2 MOVE HEADING 2
BAL 6,W11 PRINT - SPACE 2 LINES
*
MVC PRT,COLS MOVE COLUMN HEADINGS
BAL 6,W09 PRINT - SPACE 1 LINE
MVC PRT,ASTLINE MOVE COLUMN HEADINGS
BAL 6,W11 PRINT - SPACE 1 LINE
*
MVC PRT,HOLDPRT RESTORE CURRENT PRTLINE
HEADINGX EQU *
L 6,HEADING-4 RESTORE LINK REGISTER
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
***********************************************************************
* READ E35 REPORT SPECIFICATIONS *
***********************************************************************
E35SAVE DC 16F'0' REGISTER SAVE AREA
E35SPEC EQU *
STM 0,15,E35SAVE SAVE ALL REGISTERS
*
OPEN (E35IN,(INPUT)) OPEN E35 'SYSIN' FILE
MVI E35TAB,X'FF' INIT TABLE TO EMPTY
MVC PRT,PRT-1 INIT PRINT LINE
GETE35 EQU *
GET E35IN,E35REC READ E35 INPUT RECORD
CLI E35REC,C'*' COMMENT CARD ???
BE GETE35 YES - READ NEXT E35 RECORD
CLC E35REC(3),=C'LEN' RECORD LENGTH CARD ???
BNE CHKHD1 NO - TEST FOR HD1 CARD
***********************************************************************
* CONVERT RECORD LENGTH *
***********************************************************************
BC 0,GETE35 PASS THROUGH ONLY ONCE
OI *-3,X'F0' REJECT SUBSEQUENT TIMES
PACK DUBB,E35REC+4(4) PACK RECORD LENGTH
CVB 4,DUBB CONVERT TO BINARY
STH 4,RECLEN SAVE RECORD LENGTH
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKHD1 EQU *
CLC E35REC(3),=C'HD1' HEADING 1 CARD ???
BNE CHKHD2 NO - TEST FOR HD2 CARD
MVC HD1,E35REC+4 MOVE HEADING NO. 1
B GETE35 READ NEXT E35 RECORD
CHKHD2 EQU *
CLC E35REC(3),=C'HD2' HEADING 2 CARD ???
BNE CHKLIM NO - TEST FOR RPT LIMIT
MVC HD2,E35REC+4 MOVE HEADING NO. 2
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKLIM EQU *
CLC E35REC(3),=C'LIM' REPORT PAGE LIMIT CARD ??
BNE CHKNOHD NO - TEST FOR NOHEAD CARD
LA 5,E35REC+4 POINT TO REPORT LIMIT
LA 4,5 TEST 5 DIGITS
BAL 6,TESTNUM VALID NUMERIC DIGITS ???
B GETE35 NO - DISREGARD THIS CARD
PACK LIMIT,E35REC+4(5) PACK REPORT LIMIT
CP LIMIT,=P'0' LIMIT MORE THAN 0 ???
BNH GETE35 NO - INVALID LIMIT
NI LIMSW+1,X'00' YES - SET LIMIT LOGIC SW
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKNOHD EQU *
CLC E35REC(6),=C'NOHEAD' SUPPRESS HEADING CARD ???
BNE CHKRPT NO - TEST FOR RPT CARD
MVI HEADSW+1,X'F0' YES - SET SUPPRESS SWITCH
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKRPT EQU *
CLC E35REC(3),=C'RPT' REPORT RECORD???
BNE GETE35 NO - READ NEXT E35 RECORD
MVC E35POS,E35REC+4 STORE FIELD POSITION
MVC E35LEN,E35REC+8 STORE FIELD LENGTH
MVC E35FMT,E35REC+12 STORE FIELD DATA TYPE
***********************************************************************
* TEST IF POSITION/LENGTH ARE VALID NUMERICS *
***********************************************************************
CLC E35POS,=C'000' POSITION ZERO ???
BE GETE35 YES - READ NEXT E35 RECORD
CLC E35LEN,=C'000' LENGTH = ZERO ???
BE GETE35 YES - READ NEXT E35 RECORD
LA 5,E35POS POINT TO POSITION/LENGTH
LA 4,6 TEST 6 DIGITS
BAL 6,TESTNUM VALID NUMERIC DIGITS ???
B GETE35 NO - DISREGARD THIS CARD
***********************************************************************
* POINT TO TABLE ENTRY, DETERMINE/LOAD FIELD ADDRESS IN TABLE *
***********************************************************************
L 6,TABPTR LOAD CURRENT TABLE POINTER
PACK DUBB,E35POS PACK POSITION IN DUBBWORD
CVB 5,DUBB CONVERT TO BINARY
L 4,=A(SRTREC) LOAD RECORD ADDRESS
AR 4,5 ADD POSITION DISPLACEMENT
BCTR 4,0 ADJUST ADDRESS BY -1
ST 4,0(6) STORE FIELD ADDRESS
***********************************************************************
* CALCULATE/LOAD FIELD LENGTH (ADJUST BY -1) IN TABLE *
***********************************************************************
PACK DUBB,E35LEN PACK LENGTH IN DUBBWORD
CVB 5,DUBB CONVERT TO BINARY
LR 4,5 LOAD LENGTH IN R4
BCTR 4,0 ADJUST LENGTH BY -1
STH 4,4(6) STORE LENGTH IN TABLE
***********************************************************************
* CALCULATE/LOAD PRINT LENGTH IN TABLE *
***********************************************************************
MVC 12(1,6),E35FMT MOVE PRINT FORMAT
CLI E35FMT,C'S' PRINT IN HEX FORMAT ???
BE *+12 YES - CONTINUE PLEASE
CLI E35FMT,C'X' PRINT IN HEX FORMAT ???
BNE *+6 NO - PRINTING LENGTH SET
AR 4,5 DOUBLE LENGTH FOR HEX
CLI E35FMT,C'S' OMIT SIGN-FIELD ???
BNE *+6 NO - CONTINUE PLEASE
BCTR 4,0 YES - DECREMENT PRT LENGTH
STH 4,6(6) STORE PRT LENGTH IN TABLE
***********************************************************************
* STORE PRINT ADDRESS IN TABLE *
***********************************************************************
STH 4,PRTLEN SAVE PRINT LENGTH
L 4,PRTADDR LOAD PRINT START ADDRESS
ST 4,8(6) STORE PRINT ADDRESS IN TAB
***********************************************************************
* TEST IF PRTLINE EXCEEDED/TABLE FULL?? *
***********************************************************************
AH 4,PRTLEN ADD PRT LEN TO PRT ADDR
C 4,=A(PRT+132) EXCEEDS 132 BYTE LIMIT ???
BNL E35EOF YES - EXIT - ERASE ENTRY
LA 6,16(,6) BUMP TO NEXT TABLE ENTRY
ST 6,TABPTR STORE NEXT ENTRY ADDRESS
CLI 0(6),X'FF' REPORT TABLE FULL ???
BE E35EOF YES - EXIT TABLE LOADING
***********************************************************************
* FORMAT COLUMN HEADING *
***********************************************************************
L 6,PRTADDR POINT TO PRINT LINE
LA 5,E35REC+14 POINT TO COLUMN HEADING
LH 4,PRTLEN SET UP MAX PRINT LENGTH
CH 4,=H'58' COMPARE TO MAX.COL.HEADER
BNH *+8 LQ - CONTINUE PLEASE
LH 4,=H'58' GT - SET MAX.COL.HEADER
EX 4,MVCPRT MOVE COLUMN HEADING
***********************************************************************
* CALCULATE NEXT PRTLINE ADDRESS *
***********************************************************************
AH 6,PRTLEN ADD NEW DISPLACEMENT
AH 6,=H'2' +1 (ADJ) / +1 (SPACING)
ST 6,PRTADDR STORE NEXT PRTLINE ADDRESS
B GETE35 READ NEXT E35 CARD
***********************************************************************
E35EOF EQU *
L 6,TABPTR LOAD CURRENT TABLE POINTER
MVI 0(6),X'FF' MARK END-OF-TABLE
CLOSE E35IN CLOSE E35 'SYSIN' FILE
CLI E35TAB,X'FF' TABLE EMPTY ???
BNE E35SPECX NO - CONTINUE WITH PGM
ABEND 35 YES - ABEND NO. 35 PLEASE
E35SPECX EQU *
MVC COLS,PRT MOVE PRINT LINE TO COLS
MVC PRT,PRT-1 CLEAR PRINT LINE
MVI OVFL,C'O' SET FOR PAGE BREAK
***********************************************************************
* BUILD ASTERISK LINE *
***********************************************************************
LA 7,E35TAB POINT TO E35 TABLE
ASTLOOP EQU *
CLI 0(7),X'FF' END OF TABLE ???
BE ASTEXIT YES - ASTERK LINE BUILT
L 6,8(7) LOAD PRTLINE ADDRESS
LA 5,AST POINT TO ASTERISKS
LH 4,6(7) LOAD PRINT LENGTH
EX 4,MVCPRT MOVE ASTERISKS TO PRTLINE
LA 7,16(,7) BUMP TO NEXT TABLE ENTRY
B ASTLOOP TEST/BUILD NEXT ENTRY
ASTEXIT EQU *
MVC ASTLINE,PRT MOVE PRT TO ASTLINE
MVC PRT,PRT-1 CLEAR PRINT LINE
COMRG OBTAIN SYSTEM DATE
MVC E35DATE,0(1) SAVE SYSTEM DATE
***********************************************************************
LM 0,15,E35SAVE RESTORE ALL REGISTERS
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
***********************************************************************
* NUMERIC TEST *
***********************************************************************
CNOP 0,4 SUBROUTINE ALLIGNMENT
TESTNUM EQU *
CLI 0(5),X'F0' LESS THAN ZERO ???
BL TESTNUMX YES - ERROR - NOT-NUMERIC
CLI 0(5),X'F9' MORE THAN NINE ???
BH TESTNUMX YES - ERROR - NOT-NUMERIC
LA 5,1(5) BUMP TO NEXT DIGIT
BCT 4,TESTNUM LOOP TIL ALL DIGITS TESTED
LA 6,4(6) GOOD RETURN NEEDS +4
TESTNUMX EQU *
BR 6 BRANCH ON LINK REG
***********************************************************************
EJECT
***********************************************************************
* WORKING STORAGE *
***********************************************************************
TPRNT
LTORG
***********************************************************************
* E35 REPORT PROCESSING *
***********************************************************************
E35IN DCB DDNAME=E35IN,DSORG=PS,MACRF=(GM),EODAD=E35EOF
E35REC DC CL80' '
E35POS DC CL3'000'
E35LEN DC CL3'000'
E35FMT DC CL1'C'
PGCT DC PL3'0'
LIMIT DC PL3'0'
E35DATE DC CL8'MM/DD/YY'
HD1 DC CL50' '
HD2 DC CL50' '
COLS DC CL132' '
HOLDPRT DC CL132' '
ASTLINE DC CL132' '
AST DC 132C'*'
***********************************************************************
DUBB DC D'0'
RECLEN DC H'0'
MAXLEN DC H'4096'
PRTLEN DC H'0'
PRTADDR DC A(PRT)
TABPTR DC A(E35TAB)
E35TAB EQU * MUST BE ON FULLWORD
DC 200F'0' 50 ENTRIES (4 FWORDS EACH)
DC X'FF' END-OF-TABLE MARKER
***********************************************************************
SRTREC DC 4096X'00' SORT INPUT BUFFER
***********************************************************************
EJECT
***********************************************************************
* E35TAB DSECT (FOR REFERENCE ONLY - NOT USED IN PROGRAM) *
***********************************************************************
DSECT
X35DSECT DS 0CL16 DSECT FOR "E35TAB"
X35FLD DS CL4 DATA FIELD ADDRESS
X35FLDL DS CL2 DATA FIELD LENGTH
X35PRTL DS CL2 PRINT FIELD LENGTH
X35PRT DS CL4 PRINT FIELD ADDRESS
X35FMT DS CL1 PRINT FORMAT
X35FILL DS CL3 FILLER
***********************************************************************
END E35RPT
For such a simple routine it had a lot of mileage over the years... the requests could be easily configured using the E35IN DD parameters & not a single line of code was needed. Keep in mind this was back in the days when ready-made solutions didn't exist (or weren't readily available)... unless you created them yourself. I miss the good old days...
When I joined a division of GE in October 1989 we had a similar environment except there were no reporting tools. Also, we utilized Roscoe instead of TSO/ISPF but that's another matter. Although we were committed to modernizing all our systems (& would eventually obtain Eazytrieve Plus along the way) that was little help when currently deluged with report & extract requests. Marie in Accounting frequently needed extracts for GL, asset management, payroll, etc. The CFO stopped by frequently for data. The PC revolution was taking off & it seemed more & more users wanted data, ideally on a 5.25 or 3.5 inch disk to import into Alpha-Four.
The situation can be broken down as follows:
- Users make frequent adhoc requests for system data with little turnaround time.
- Data must be in columns & often requires multiple levels of sorting.
- Not practical to produce Assembler program for each & every one-time request.
- At the time there are no other reporting tools available.
- Requires some thought & resourcefulness.
A Resourceful Solution - DFSORT's E35 Exit Routine Capability!
At GE, IBM's DFSORT product was used extensively. It commonly appears in our batch JCL processes (often multiple times within a single job). It reads in the file designated by SORTIN, performs the defined sort & writes the output as designated by SORTOUT. You can add criteria to OMIT/INCLUDE records. DFSORT also provides a facility where you can code a custom exit routine - E35 is specifically for sorted output. The E35 routine capability would make DFSORT a perfect custom utility for our purposes...
The idea is to code a routine that allows dynamic column definitions to extract/format the sorted data & write to a file (or print if that's the requirement). The input DD name will be called E35IN & contains the position, length, format & heading of the desired columns. Also, any page headings & page limits (for testing). The extract output will be directed to the DD name of PRINTER.
Sample JCL:
Pulling customer lease data & directing desired columns to a file (specified by PRINTER).
//SORT EXEC PGM=ICEMAN
//MODLIB DD DISP=SHR,DSN=GF.LOAD.LIB
//PRINTER DD SYSOUT=*
//SYSIN DD *
SORT FIELDS=(1,3,BI,A)
RECORD TYPE=F,LENGTH=35
MODS E35=(E35RPT,,MODLIB)
/*
//E35IN DD *
NOHEAD -SUPPRESS HEADING (OPTION)
LEN:0035 -RECORD LENGTH (REQUIRED)
LIM:00100 -REPORT LIMIT (#PAGES)
HD1:E35 ROUTINE - TEST RUN -HEADING 1 UP TO 50 CHARS
HD2:REPORT FORMATTING MODULE -HEADING 2 UP TO 50 CHARS
***:***,***,*,**********************************************
RPT:001,001,X,CO -COL.01 = 'RPT'
RPT:002,002,S,BR -COL.05 = POSITION
RPT:004,004,S,CUST# -COL.09 = LENGTH
RPT:008,004,S,LEASE# -COL.13 = DATA TYPE C,X,S
RPT:012,001,X,SQ -COL.15 = COLUMN HEADINGS
RPT:013,020,C,CUSTOMER NAME -TRUNCATED IF > FIELD LEN.
***:***,***,*,**********************************************
/*
The E35IN definitions are read & stored on the first SORT output pass - all records are then formatted/written based on those definitions. The SYSIN parameters are the same as usual with the exception of the MODS E35=(E35RPT,,MODLIB) definition. All other SORT parameters may be leveraged to further qualify the output data such as OMIT/INCLUDE conditions.
SAMPLE OUTPUT:
CO BR CUST# LEASE# SQ CUSTOMER NAME
** *** ******* ******* ** ********************
02 120 0000014 0769456 99 JOE'S TRUCKING
02 120 0000023 0770034 35 ACME PRODUCTS
02 150 0000345 0880023 30 COMPANY XYZ
...
...
Below is the full E35RPT Module - the macro TPRNT is used to write to the PRINTER DD name via the call to the W09 routine (adheres to the print standards of the organization).
TITLE 'E35RPT - SORT E35 EXIT - FORMAT/PRINT REPORT'
***********************************************************************
* *
* MODULE: E35RPT. *
* AUTHOR: TONY DELIA. *
* DATE: 06/26/90. *
* DESC: DFSORT E35 EXIT - REPORT FORMATTER. *
* *
***********************************************************************
* INSTRUCTIONS/JCL: (INCLUDE WITH STANDARD SORT JCL) *
***********************************************************************
* *
* //SORT EXEC PGM=ICEMAN *
* //MODLIB DD DISP=SHR,DSN=GF.LOAD.LIB *
* //PRINTER DD SYSOUT=* *
* *
* //SYSIN DD * *
* SORT FIELDS=(1,3,BI,A) *
* RECORD TYPE=F,LENGTH=35 *
* MODS E35=(E35RPT,,MODLIB) *
* /* *
* *
* //E35IN DD * *
* NOHEAD -SUPPRESS HEADING (OPTION) *
* LEN:0035 -RECORD LENGTH (REQUIRED) *
* LIM:00100 -REPORT LIMIT (#PAGES) *
* HD1:E35 ROUTINE - TEST RUN -HEADING 1 UP TO 50 CHARS *
* HD2:REPORT FORMATTING MODULE -HEADING 2 UP TO 50 CHARS *
* ***:***,***,*,********************************************** *
* RPT:001,001,X,CO -COL.01 = 'RPT' *
* RPT:002,002,S,BR -COL.05 = POSITION *
* RPT:004,004,S,CUST# -COL.09 = LENGTH *
* RPT:008,004,S,LEASE# -COL.13 = DATA TYPE C,X,S *
* RPT:012,001,X,SQ -COL.15 = COLUMN HEADINGS, *
* RPT:013,020,C,CUSTOMER NAME -TRUNCATED IF > FIELD LEN. *
* ***:***,***,*,********************************************** *
* /* *
* *
***********************************************************************
EJECT
***********************************************************************
* E 3 5 R P T P R O G R A M *
***********************************************************************
PRINT NOGEN
E35RPT CSECT ENTER PROGRAM
STM 14,12,12(13) SAVE REGISTERS
LR 12,15 LOAD PROGRAM ENTRY POINT
USING E35RPT,12 SET UP BASE NUMBER 1
L 11,BASE2 LOAD BASE 2 ADDRESS
USING E35RPT+4096,11 SET UP BASE NUMBER 2
ST 13,SAVE+4 SAVE EXTERNAL SAVE AREA
LR 14,13 HOLD EXTERNAL ADDR IN R14
LA 13,SAVE LOAD INTERNAL SAVE AREA
ST 13,8(14) SAVE INTERNAL ADDRESS
B GO BEGIN MAINLINE PROGRAM
***********************************************************************
RETURN EQU *
L 13,SAVE+4 RESTORE EXTERNAL SAVE ADDR
LM 14,10,12(13) RESTORE ORIGINAL REGISTERS
L 15,RC R15= DFSORT RETURN CODE
L 1,RECADDR R1 = CURRENT RECORD ADDR
LM 11,12,64(13) BASEREGS RESTORED LAST
BR 14 BRANCH BACK TO PLSORT
***********************************************************************
SAVE DC 18F'0' REGISTER PRESERVATION AREA
BASE2 DC A(E35RPT+4096*1) BASE REGISTER 2
RECADDR DC A(0) CURRENT RECORD ADDRESS
RC DC A(0) RETURN CODE AREA
RC0 DC A(0) RETURN CODE = "PROCESS"
RC8 DC A(8) RETURN CODE = "END E35"
RC12 DC A(12) RETURN CODE = "INSERT "
***********************************************************************
EJECT
***********************************************************************
* MAINLINE SECTION *
***********************************************************************
GO EQU *
LM 2,3,0(1) LOAD CURRENT/PREVIOUS ADDR
L 3,RECADDR LOAD PREVIOUS RECORD
ST 2,RECADDR STORE CURRENT RECORD
LTR 2,2 END-OF-FILE ???
BZ ENDFLE YES - WRAP UP LOOSE ENDS
LTR 3,3 1ST TIME THROUGH ???
BNZ *+8 NO - PROCESS SORT RECORD
BAL 6,E35SPEC YES - OBTAIN REPORT SPECS
*
LIMSW BC 15,LIMOK IF NO REPORT LIMIT -BYPASS
CLI OVFL,C'O' PAGE BREAK TIME ???
BNE *+14 NO - PROCESS AS PLANNED
CP PGCT,LIMIT YES - TEST PAGE LIMIT
BNL ENDFLE LIMIT MET- E35RPT COMPLETE
LIMOK EQU *
LA 4,SRTREC POINT TO SORT INPUT BUFFER
LH 5,MAXLEN BUFFER LENGTH IS 4096
LH 3,RECLEN LOAD SORT INPUT LENGTH
ICM 3,B'1000',=X'00' PAD CHARACTER IS HEX ZERO
MVCL 4,2 MOVE SORT INPUT TO BUFFER
*
LA 7,E35TAB POINT TO E35 TABLE
PROCLOOP EQU *
CLI 0(7),X'FF' END-OF-TABLE ???
BE PROCEXIT YES - EXIT LOOP
L 5,0(7) LOAD DATA FIELD ADDRESS
CLI 12(7),C'S' PACKED PRINT FORMAT ???
BE *+12 YES - CONVERT TO HEXPRINT
CLI 12(7),C'X' HEX PRINT FORMAT ???
BNE *+8 NO - SKIP HEX ROUTINE
BAL 6,HEXFMT YES - CONVERT TO HEXPRINT
LH 4,6(7) LOAD PRINT LENGTH
L 6,8(7) LOAD PRINT ADDRESS
EX 4,MVCPRT MOVE DATA TO PRTLINE
LA 7,16(,7) BUMP TO NEXT TABLE ENTRY
B PROCLOOP TEST/BUILD NEXT ENTRY
PROCEXIT EQU *
BAL 6,HEADING CHECK FOR HEADINGS
BAL 6,W09 PRINT - SPACE 1 LINE
MVC RC,RC0 MOVE RETURN CODE 0
B RETURN RETURN TO SORT PROGRAM
***********************************************************************
ENDFLE EQU *
BAL 6,WXX CLOSE PRINT FILE
MVC RC,RC8 MOVE RETURN CODE 8
B RETURN RETURN TO SORT PROGRAM
***********************************************************************
MVCPRT MVC 0(0,6),0(5) R4=LEN/R5=DATA/R6=PRTADDR
***********************************************************************
EJECT
***********************************************************************
* CONVERT DATA TO HEX FORMAT *
***********************************************************************
DC F'0' RETURN ADDRESS SAVE AREA
HEXFMT EQU *
ST 6,*-4 SAVE RETURN ADDRESS
*
LH 4,4(7) LOAD FIELD LENGTH
LA 4,1(,4) ADJUST BY +1
LA 6,HEXDATA LOAD DESTINATION ADDRESS
HEXLOOP EQU *
MVO ARG(2),0(1,5) ISOLATE ZONE PORTION
NI ARG,X'0F' TURN OFF LEFTMOST BITS
TRT ARG,TRTAB TRANSLATE TO CHARACTER
STC 2,0(6) MOVE CHARACTER TO HEXDATA
*
MVN ARG(2),0(5) ISOLATE NUMERIC PORTION
NI ARG,X'0F' TURN OFF LEFTMOST BITS
TRT ARG,TRTAB TRANSLATE TO CHARACTER
STC 2,1(6) MOVE CHARACTER TO HEXDATA
*
LA 6,2(,6) BUMP HEXDATA ADDRESS BY 2
LA 5,1(,5) BUMP FIELD ADDRESS
BCT 4,HEXLOOP REPEAT TIL FIELD CONVERTED
*
LA 5,HEXDATA POINT TO HEX DATA
HEXFMTX EQU *
L 6,HEXFMT-4 RESTORE LINK REGISTER
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
ARG DC CL2' ' ARGUMENT HOLD AREA
TRTAB DC CL16'0123456789ABCDEF' TRANSLATION TABLE
HEXDATA DC CL150' ' HEX CONVERSION AREA
***********************************************************************
EJECT
***********************************************************************
* HEADINGS *
***********************************************************************
DC F'0' RETURN ADDRESS SAVE AREA
HEADING EQU *
ST 6,*-4 SAVE RETURN ADDRESS
*
HEADSW BC 0,HEADINGX SUPPRESS HEADINGS ???
*
CLI OVFL,C'O' HEADINGS NEEDED ???
BNE HEADINGX NO - EXIT ROUTINE
*
MVC HOLDPRT,PRT SAVE CURRENT PRTLINE
MVC PRT,PRT-1 CLEAR PRINT LINE
MVI OVFL,C' ' CLEAR OVERFLOW SWITCH
ZAP LNCT,=P'0' CLEAR LINE COUNTER
BAL 6,W8B PRINT - PAGE EJECT
*
MVC PRT(12),=C'E35RPT: PAGE' MOVE REPORT TITLE/PAGE
AP PGCT,=P'1' ADD +1 TO PAGE COUNTER
MVC PRT+12(6),=X'402020202120' MOVE EDIT PATTERN
ED PRT+12(6),PGCT EDIT PAGE COUNTER
*
MVC PRT+22(8),E35DATE INIT HEADING 1 AREA
CLI HD1,C' ' HEADING 1 REQUIRED ???
BE *+10 NO - DON'T BOTHER
MVC PRT+22(L'HD1),HD1 MOVE HEADING 1
BAL 6,W11 PRINT - SPACE 2 LINES
*
CLI HD2,C' ' HEADING 2 REQUIRED ???
BE *+20 NO - DON'T BOTHER
MVC PRT(8),E35DATE MOVE SYSTEM DATE
MVC PRT+22(L'HD2),HD2 MOVE HEADING 2
BAL 6,W11 PRINT - SPACE 2 LINES
*
MVC PRT,COLS MOVE COLUMN HEADINGS
BAL 6,W09 PRINT - SPACE 1 LINE
MVC PRT,ASTLINE MOVE COLUMN HEADINGS
BAL 6,W11 PRINT - SPACE 1 LINE
*
MVC PRT,HOLDPRT RESTORE CURRENT PRTLINE
HEADINGX EQU *
L 6,HEADING-4 RESTORE LINK REGISTER
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
***********************************************************************
* READ E35 REPORT SPECIFICATIONS *
***********************************************************************
E35SAVE DC 16F'0' REGISTER SAVE AREA
E35SPEC EQU *
STM 0,15,E35SAVE SAVE ALL REGISTERS
*
OPEN (E35IN,(INPUT)) OPEN E35 'SYSIN' FILE
MVI E35TAB,X'FF' INIT TABLE TO EMPTY
MVC PRT,PRT-1 INIT PRINT LINE
GETE35 EQU *
GET E35IN,E35REC READ E35 INPUT RECORD
CLI E35REC,C'*' COMMENT CARD ???
BE GETE35 YES - READ NEXT E35 RECORD
CLC E35REC(3),=C'LEN' RECORD LENGTH CARD ???
BNE CHKHD1 NO - TEST FOR HD1 CARD
***********************************************************************
* CONVERT RECORD LENGTH *
***********************************************************************
BC 0,GETE35 PASS THROUGH ONLY ONCE
OI *-3,X'F0' REJECT SUBSEQUENT TIMES
PACK DUBB,E35REC+4(4) PACK RECORD LENGTH
CVB 4,DUBB CONVERT TO BINARY
STH 4,RECLEN SAVE RECORD LENGTH
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKHD1 EQU *
CLC E35REC(3),=C'HD1' HEADING 1 CARD ???
BNE CHKHD2 NO - TEST FOR HD2 CARD
MVC HD1,E35REC+4 MOVE HEADING NO. 1
B GETE35 READ NEXT E35 RECORD
CHKHD2 EQU *
CLC E35REC(3),=C'HD2' HEADING 2 CARD ???
BNE CHKLIM NO - TEST FOR RPT LIMIT
MVC HD2,E35REC+4 MOVE HEADING NO. 2
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKLIM EQU *
CLC E35REC(3),=C'LIM' REPORT PAGE LIMIT CARD ??
BNE CHKNOHD NO - TEST FOR NOHEAD CARD
LA 5,E35REC+4 POINT TO REPORT LIMIT
LA 4,5 TEST 5 DIGITS
BAL 6,TESTNUM VALID NUMERIC DIGITS ???
B GETE35 NO - DISREGARD THIS CARD
PACK LIMIT,E35REC+4(5) PACK REPORT LIMIT
CP LIMIT,=P'0' LIMIT MORE THAN 0 ???
BNH GETE35 NO - INVALID LIMIT
NI LIMSW+1,X'00' YES - SET LIMIT LOGIC SW
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKNOHD EQU *
CLC E35REC(6),=C'NOHEAD' SUPPRESS HEADING CARD ???
BNE CHKRPT NO - TEST FOR RPT CARD
MVI HEADSW+1,X'F0' YES - SET SUPPRESS SWITCH
B GETE35 READ NEXT E35 RECORD
***********************************************************************
CHKRPT EQU *
CLC E35REC(3),=C'RPT' REPORT RECORD???
BNE GETE35 NO - READ NEXT E35 RECORD
MVC E35POS,E35REC+4 STORE FIELD POSITION
MVC E35LEN,E35REC+8 STORE FIELD LENGTH
MVC E35FMT,E35REC+12 STORE FIELD DATA TYPE
***********************************************************************
* TEST IF POSITION/LENGTH ARE VALID NUMERICS *
***********************************************************************
CLC E35POS,=C'000' POSITION ZERO ???
BE GETE35 YES - READ NEXT E35 RECORD
CLC E35LEN,=C'000' LENGTH = ZERO ???
BE GETE35 YES - READ NEXT E35 RECORD
LA 5,E35POS POINT TO POSITION/LENGTH
LA 4,6 TEST 6 DIGITS
BAL 6,TESTNUM VALID NUMERIC DIGITS ???
B GETE35 NO - DISREGARD THIS CARD
***********************************************************************
* POINT TO TABLE ENTRY, DETERMINE/LOAD FIELD ADDRESS IN TABLE *
***********************************************************************
L 6,TABPTR LOAD CURRENT TABLE POINTER
PACK DUBB,E35POS PACK POSITION IN DUBBWORD
CVB 5,DUBB CONVERT TO BINARY
L 4,=A(SRTREC) LOAD RECORD ADDRESS
AR 4,5 ADD POSITION DISPLACEMENT
BCTR 4,0 ADJUST ADDRESS BY -1
ST 4,0(6) STORE FIELD ADDRESS
***********************************************************************
* CALCULATE/LOAD FIELD LENGTH (ADJUST BY -1) IN TABLE *
***********************************************************************
PACK DUBB,E35LEN PACK LENGTH IN DUBBWORD
CVB 5,DUBB CONVERT TO BINARY
LR 4,5 LOAD LENGTH IN R4
BCTR 4,0 ADJUST LENGTH BY -1
STH 4,4(6) STORE LENGTH IN TABLE
***********************************************************************
* CALCULATE/LOAD PRINT LENGTH IN TABLE *
***********************************************************************
MVC 12(1,6),E35FMT MOVE PRINT FORMAT
CLI E35FMT,C'S' PRINT IN HEX FORMAT ???
BE *+12 YES - CONTINUE PLEASE
CLI E35FMT,C'X' PRINT IN HEX FORMAT ???
BNE *+6 NO - PRINTING LENGTH SET
AR 4,5 DOUBLE LENGTH FOR HEX
CLI E35FMT,C'S' OMIT SIGN-FIELD ???
BNE *+6 NO - CONTINUE PLEASE
BCTR 4,0 YES - DECREMENT PRT LENGTH
STH 4,6(6) STORE PRT LENGTH IN TABLE
***********************************************************************
* STORE PRINT ADDRESS IN TABLE *
***********************************************************************
STH 4,PRTLEN SAVE PRINT LENGTH
L 4,PRTADDR LOAD PRINT START ADDRESS
ST 4,8(6) STORE PRINT ADDRESS IN TAB
***********************************************************************
* TEST IF PRTLINE EXCEEDED/TABLE FULL?? *
***********************************************************************
AH 4,PRTLEN ADD PRT LEN TO PRT ADDR
C 4,=A(PRT+132) EXCEEDS 132 BYTE LIMIT ???
BNL E35EOF YES - EXIT - ERASE ENTRY
LA 6,16(,6) BUMP TO NEXT TABLE ENTRY
ST 6,TABPTR STORE NEXT ENTRY ADDRESS
CLI 0(6),X'FF' REPORT TABLE FULL ???
BE E35EOF YES - EXIT TABLE LOADING
***********************************************************************
* FORMAT COLUMN HEADING *
***********************************************************************
L 6,PRTADDR POINT TO PRINT LINE
LA 5,E35REC+14 POINT TO COLUMN HEADING
LH 4,PRTLEN SET UP MAX PRINT LENGTH
CH 4,=H'58' COMPARE TO MAX.COL.HEADER
BNH *+8 LQ - CONTINUE PLEASE
LH 4,=H'58' GT - SET MAX.COL.HEADER
EX 4,MVCPRT MOVE COLUMN HEADING
***********************************************************************
* CALCULATE NEXT PRTLINE ADDRESS *
***********************************************************************
AH 6,PRTLEN ADD NEW DISPLACEMENT
AH 6,=H'2' +1 (ADJ) / +1 (SPACING)
ST 6,PRTADDR STORE NEXT PRTLINE ADDRESS
B GETE35 READ NEXT E35 CARD
***********************************************************************
E35EOF EQU *
L 6,TABPTR LOAD CURRENT TABLE POINTER
MVI 0(6),X'FF' MARK END-OF-TABLE
CLOSE E35IN CLOSE E35 'SYSIN' FILE
CLI E35TAB,X'FF' TABLE EMPTY ???
BNE E35SPECX NO - CONTINUE WITH PGM
ABEND 35 YES - ABEND NO. 35 PLEASE
E35SPECX EQU *
MVC COLS,PRT MOVE PRINT LINE TO COLS
MVC PRT,PRT-1 CLEAR PRINT LINE
MVI OVFL,C'O' SET FOR PAGE BREAK
***********************************************************************
* BUILD ASTERISK LINE *
***********************************************************************
LA 7,E35TAB POINT TO E35 TABLE
ASTLOOP EQU *
CLI 0(7),X'FF' END OF TABLE ???
BE ASTEXIT YES - ASTERK LINE BUILT
L 6,8(7) LOAD PRTLINE ADDRESS
LA 5,AST POINT TO ASTERISKS
LH 4,6(7) LOAD PRINT LENGTH
EX 4,MVCPRT MOVE ASTERISKS TO PRTLINE
LA 7,16(,7) BUMP TO NEXT TABLE ENTRY
B ASTLOOP TEST/BUILD NEXT ENTRY
ASTEXIT EQU *
MVC ASTLINE,PRT MOVE PRT TO ASTLINE
MVC PRT,PRT-1 CLEAR PRINT LINE
COMRG OBTAIN SYSTEM DATE
MVC E35DATE,0(1) SAVE SYSTEM DATE
***********************************************************************
LM 0,15,E35SAVE RESTORE ALL REGISTERS
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
***********************************************************************
* NUMERIC TEST *
***********************************************************************
CNOP 0,4 SUBROUTINE ALLIGNMENT
TESTNUM EQU *
CLI 0(5),X'F0' LESS THAN ZERO ???
BL TESTNUMX YES - ERROR - NOT-NUMERIC
CLI 0(5),X'F9' MORE THAN NINE ???
BH TESTNUMX YES - ERROR - NOT-NUMERIC
LA 5,1(5) BUMP TO NEXT DIGIT
BCT 4,TESTNUM LOOP TIL ALL DIGITS TESTED
LA 6,4(6) GOOD RETURN NEEDS +4
TESTNUMX EQU *
BR 6 BRANCH ON LINK REG
***********************************************************************
EJECT
***********************************************************************
* WORKING STORAGE *
***********************************************************************
TPRNT
LTORG
***********************************************************************
* E35 REPORT PROCESSING *
***********************************************************************
E35IN DCB DDNAME=E35IN,DSORG=PS,MACRF=(GM),EODAD=E35EOF
E35REC DC CL80' '
E35POS DC CL3'000'
E35LEN DC CL3'000'
E35FMT DC CL1'C'
PGCT DC PL3'0'
LIMIT DC PL3'0'
E35DATE DC CL8'MM/DD/YY'
HD1 DC CL50' '
HD2 DC CL50' '
COLS DC CL132' '
HOLDPRT DC CL132' '
ASTLINE DC CL132' '
AST DC 132C'*'
***********************************************************************
DUBB DC D'0'
RECLEN DC H'0'
MAXLEN DC H'4096'
PRTLEN DC H'0'
PRTADDR DC A(PRT)
TABPTR DC A(E35TAB)
E35TAB EQU * MUST BE ON FULLWORD
DC 200F'0' 50 ENTRIES (4 FWORDS EACH)
DC X'FF' END-OF-TABLE MARKER
***********************************************************************
SRTREC DC 4096X'00' SORT INPUT BUFFER
***********************************************************************
EJECT
***********************************************************************
* E35TAB DSECT (FOR REFERENCE ONLY - NOT USED IN PROGRAM) *
***********************************************************************
DSECT
X35DSECT DS 0CL16 DSECT FOR "E35TAB"
X35FLD DS CL4 DATA FIELD ADDRESS
X35FLDL DS CL2 DATA FIELD LENGTH
X35PRTL DS CL2 PRINT FIELD LENGTH
X35PRT DS CL4 PRINT FIELD ADDRESS
X35FMT DS CL1 PRINT FORMAT
X35FILL DS CL3 FILLER
***********************************************************************
END E35RPT
For such a simple routine it had a lot of mileage over the years... the requests could be easily configured using the E35IN DD parameters & not a single line of code was needed. Keep in mind this was back in the days when ready-made solutions didn't exist (or weren't readily available)... unless you created them yourself. I miss the good old days...
Subscribe to:
Posts (Atom)