ANFUXHDR TITLE 'Begin Data Set Exit' ****** START OF SPECIFICATIONS **************************************** * * * MODULE NAME = ANFUXHDR * * * * DESCRIPTIVE NAME = Begin Data Set exit * * * * COPYRIGHT= 5695040 (c) COPYRIGHT IBM CORPORATION 1996, 1997 * * * * STATUS = VERSION 1, RELEASE 1, LEVEL 0 * * * * FUNCTION = Begin Data Set exit for putting out banner page * * * * This exit produces: * * 1. A separator/banner with all the information that * * is also produced with a JES2 or PSF/MVS attached * * printer, see below. * * * * The output of this exits is as follows: * * start banner, which looks like: * * * * +-------------------------------------------------+ * * | | * * | ROOM in grote blokletter (= lijstnr) | * * | | * * | | * * | | * * | | * * | | * * | | * * | | * * | | * * | | * * | +----------------------------------------+ | * * | - - | * * | - Datum : - | * * | - - | * * | - Tijd : - | * * | - - | * * | - Jobnaam : - | * * | - - | * * | - Job id. : - | * * | - - | * * | - Lijstnr. : - | * * | - - | * * | - Overzicht: - | * * | - - | * * | - Afdeling : - | * * | - - | * * | - - | * * | - - | * * | +----------------------------------------+ | * * | | * * +-------------------------------------------------+ * * * * * * NOTES = * * * * ANSI defined Printer Control Characters: * * Blank = Space 1 line * * 0 = Space 2 line * * - = Space 3 line * * + = Suppress space * * 1 = Skip to line 1 on new page * * * * DEPENDENCIES = none * * * * MODULE TYPE = PROCEDURE * * PROCESSOR = Assembler * * ATTRIBUTES = * * REENTRANT * * AMODE(31) * * RMODE(ANY) * * * * PATCH LABEL = none * * * * ENTRY POINT = * * ANFUXHDR * * * * LINKAGE = * * LOAD ANFUXHDR * * CALL ANFUXHDR(addr(ANFUEXTP)) * * calling module passes address of Common Parameter * * area. * * * * INITIAL VERSION: November 1997 @jdr * * CHANGE ACTIVITY = * * * ***** END OF SPECIFICATIONS ******************************************* EJECT , ANFUXHDR CSECT , Establish the csect ANFUXHDR AMODE ANY It addresses all storage ANFUXHDR RMODE ANY It can reside anywhere USING ANFUXHDR,R15 Establish temporary X addressability to module B BDSINIT Branch around copyright ANFUXHDR MODID BR=NO information eyecatcher info DC C' This module has been developed ' DC C'by Jan de Rover, (SE) Printing ' DC C'Systems Division (PSD) Amst' DC C'erdam in the Netherlands ' DC C'This code is not considered Type 1 ' DC C'code of IBM. Also it has not been ' DC C'submitted to any formal IBM test. ' DC C'Distribution is on an "as is" ' DC C'basis without any warranty either ' DC C'expressed or implied. ' PRINT ON,NOGEN *********************************************************************** * * * ANFUXHDR Module entry point * * * *********************************************************************** BDSINIT DS 0H STM R14,R12,12(R13) Save callers registers LR R12,R15 Move base register to R12 DROP R15 Done with this register USING ANFUXHDR,R12 R12 is base reg for program code L R4,0(R1) Get address of parm area USING ANFUEXTP,R4 R4 is base for parm area ST R13,XTPSAVE+4 Chain save areas LA R15,XTPSAVE Get my save area ST R15,8(R13) Point callers save area to it LR R13,R15 Point R13 to my save area *********************************************************************** * * * Get storage for work area * * * *********************************************************************** SLR R2,R2 Get a zero L R9,XTPWORK1 Get working storage addr CR R9,R2 Has work area been gotten? BNE BDSDOIT Yes, skip this LA R2,BUFWRKL Get length of DSECT GETMAIN RU,LV=(2),LOC=ANY Get program storage area BDSGOTIT DS 0H ST R1,XTPWORK1 Save my work area LR R9,R1 Put it in the correct reg EJECT , *********************************************************************** * * * Actual work - call to get block characters * * * *********************************************************************** BDSDOIT DS 0H USING BUFWRK,R9 USING IAZJSPA,R11 L R11,XTPJSPAP Get address of jspa area TM XTPDSFLG,XTPDSJOB First data set in job? BNO GETOUT No, don't produce banner TM XTPRCFLG,XTPRDFST First call for data set? BNO ENDINIT No, don't do init stuff *********************************************************************** * * * First call only routine * * * *********************************************************************** CLC BDSWORKB(SETUPLEN),SETUPSTR BE NEXTA MVC BDSWORKB(SETUPLEN),SETUPSTR LA R5,BDSWORKB ST R5,XTPERPTR LA R5,SETUPLEN ST R5,XTPERLEN MVI XTPRCFLG,0 OI XTPRCFLG,XTPRCTRN OI XTPRCFLG,XTPRCEXT B GETOUT NEXTA DS 0H MVI BDSWORKD,0 State is need first userid line MVI BDSWORKE,0 SWB error flag MVI XTPBIFLG,X'00' Default formatting stuff OI XTPBIFLG,XTPBPRFM Narrow letters OI XTPBIFLG,XTPBLJST On left margin OI XTPBIFLG,XTPBFRST First call for the string *********************************************************************** * * * End first call only routine * * * *********************************************************************** EJECT , *********************************************************************** * * * Build the blockletters for the banner * * * *********************************************************************** ENDINIT DS 0H BAL R14,CLRLINE Clear printline *********************************************************************** * * * FUNCTION: * * * * This routine will retrieve the JCL keywords: * * * * * BUILDING * * * DEPARTMENT * * * TITLE * * * ROOM * * * NAME * * * ADDRESS * * * * and saves them in storage varables. The keywords * * are retrieved using the Scheduler JCL Facility * * SWBTUREQ macro. * * * * Storage located at the end of PRTBUF: * * * * * SWBTUREQ Parameter List * * * SWBTUREQ Work Area * * * Keylist * * * List of SWBTU pointers * * * * Storage located in the area pointed to by OUTTUWS: * * * * * SWBTUREQ OUTPUT AREA * * * * OTHER CONSIDERATIONS: none * * * *********************************************************************** * * * Fill in the SWBTUREQ RETRIEVE parameter list, IEFSJTRP. * * * *********************************************************************** XC SJTRP(SJTRLGTH),SJTRP Clear parameter list MVC SJTRID,=A(SJTRCID) Assign function MVI SJTRVERS,SJTRCVER Assign version number LA R1,SJTRLGTH Set parameter list STH R1,SJTRLEN length EJECT , *********************************************************************** * * * The Work Area is a 1K work area in PRTBUF that is used as * * a work area by the SWBTUREQ macro. * * * *********************************************************************** LA R1,SWBTUWS Set work area ST R1,SJTRSTOR address LA R1,L'SWBTUWS Set work area STH R1,SJTRSTSZ length LA R1,1 Indicate only ONE STH R1,SJTRSWBN SWBTU pointer LA R1,SBTLAREA Set SWBTU addr. list ST R1,SJTRSWBA address (SJTRSBTL) LA R1,6 Indicate six keys in STH R1,SJTRKIDN key list LA R1,KEYLIST Set key list ST R1,SJTRKIDL address ST R1,WRKKYLST Save keylist address *********************************************************************** * * * This is a 1K Text Unit Output Area where the parameters are * * returned by the SWBTUREQ macro. * * * *********************************************************************** LA R1,OUTTUWS Set output area ST R1,SJTRAREA address LA R1,L'OUTTUWS Set output area STH R1,SJTRSIZE length *********************************************************************** * * * Initialize the SWBTU pointer list * * * *********************************************************************** USING SJTRSBTL,R7 Establish LA R7,SBTLAREA addressability XC SBTLAREA(L'SBTLAREA),SBTLAREA Clear SWBTU list EJECT , *********************************************************************** * * * Set the address of the area containing the SWBTU data * * from the JCL for the SWBTUREQ macro. * * * *********************************************************************** MVC SJTRSTUP,XTPSWBTP Set input SWBTU ptr DROP R7 *********************************************************************** * * * Insert the keys for all of the ESS * * parameters being used into the key list. * * * *********************************************************************** $JTRKEYL DS 0H USING SJTRKEYL,R7 Establish L R7,WRKKYLST addressability XC SJTRKEYL(6*SJTRKLEN),SJTRKEYL Clear key list LA R1,DOTITLE Request STH R1,SJTRKYID+KYLSTTL TITLE key LA R1,DONAME Request STH R1,SJTRKYID+KYLSTNM NAME key LA R1,DOROOM Request STH R1,SJTRKYID+KYLSTRM ROOM key LA R1,DOBUILD Request STH R1,SJTRKYID+KYLSTBL BUILDING key LA R1,DODEPT Request STH R1,SJTRKYID+KYLSTDP DEPARTMENT key LA R1,DOADDRES Request STH R1,SJTRKYID+KYLSTAD Address key DROP R7 EJECT , *********************************************************************** * * * INVOKE the SWBTUREQ REQUEST=RETRIEVE Macro * * ------------------------------------------ * * * * Set up R1 to point to a word of storage that * * contains the address of the parameter list, IEFSJTRP. * * * *********************************************************************** MVI SWBERR,C'N' Initialize to no * SWBTUREQ error LA R1,SJTRP Address of ST R1,WRKPLPTR the SWBTUREQ LA R1,WRKPLPTR parameter list SWBTUREQ REQUEST=RETRIEVE INVOKE the Macro C R15,FOUR Check return code BL CONTINUE GOOD retrieval *********************************************************************** * * * No keys matched indicates that none of the JCL keywords * * were specified on the OUTPUT JCL. No error message is * * printed. Instead the keywords are just left blank on the * * header sheet. * * * *********************************************************************** CLC SJTRREAS,=A(SJTRNOKY) No keys matched? BE CONTINUE YES--- EJECT , *********************************************************************** * * * If the SWBTUREQ returns an error, the detail box is * * still printed. An error message is printed on the * * ADDRESS line. * * * * NOTE: This exit should not receive any errors from * * the SWBTUREQ. This code is mainly supplied * * for diagnostic purposes when changing the exit. * * * *********************************************************************** REQ_BAD DS 0H CVD R15,DBLWORD Convert to pkd dec. MVC FULLWORD,DBLWORD+4 Move packed ret. cde UNPK DBLWORD,FULLWORD Unpack return code MVZ DBLWORD+7(1),DBLWORD+6 Correct the sign MVC SWBRC(4),DBLWORD+4 Save return code LH R1,SJTRREAS Load reason code CVD R1,DBLWORD Convert to pkd dec. MVC FULLWORD,DBLWORD+4 Move packed reas. cde UNPK DBLWORD,FULLWORD Unpack reason code MVZ DBLWORD+7(1),DBLWORD+6 Correct the sign MVC SWBRS(4),DBLWORD+4 Save reason code MVI SWBERR,C'Y' Indicate a SWBTUREQ * error occurred and * a msg is required CONTINUE DS 0H CLI BDSWORKD,1 Done with last line of 1e block BH DOSECOND Yes, do 2nd blockletter USING SJTRKEYL,R2 Base KEYLIST ICM R2,B'1111',WRKKYLST Load KEYLIST address BZ NOXXXX Branch if NO KEYLIST LA R2,KYLSTRM(,R2) Locate addr. of ROOM * key in the KEYLIST ICM R1,B'1111',SJTRTPAD Load ROOM TU address BZ NOXXXX Branch if NO ROOM LA R1,DOCNTENT-DOCNUNIT(,R1) Addr. of TEXT UNIT BAL R8,MOVETU Get ROOM data MVC XTPBSTRG,BOXINFO Move ROOM for conversion B *+10 DROP R2 NOXXXX DS 0H MVC BOXINFO,=CL55' ' * Call the block letter routine ST R4,WRKSAVE Save addr of parm LA R1,WRKSAVE L R15,=V(ANFUBLK) Get address of block builder BALR R14,R15 CLI BDSWORKD,0 First line first block? BH DOREMDR No, do remainder of block MVI XTPBOUTP,C' ' Space 1 line carriage control MVI BDSWORKD,1 Finished first 1e blk line DOREMDR DS 0H TM XTPBOFLG,XTPBLAST Last one of this block? BNO PRINTIT No, don't do next blk init MVI BDSWORKD,2 Saw last rec, OI XTPBIFLG,XTPBFRST First call for the string B PRINTIT EJECT , *********************************************************************** * * * Prepare to print the second block letter * * * *********************************************************************** DOSECOND DS 0H CLI BDSWORKD,3 Done with last line of 2e block BH DOTHIRD Yes, do 3e block * Call the block letter routine ST R4,WRKSAVE Save addr of parm LA R1,WRKSAVE L R15,=V(ANFUBLK) Get address of block builder BALR R14,R15 CLI BDSWORKD,2 First line second block? BH DOREMDR2 No, do remainder of second blk MVI XTPBOUTP,X'F0' Skip line carriage control MVI BDSWORKD,3 Finished first line second blk DOREMDR2 DS 0H TM XTPBOFLG,XTPBLAST Last one of this block? BNO PRINTIT No, don't do next line init MVI BDSWORKD,4 Finished second block SETUNKWN DS 0H OI XTPBIFLG,XTPBFRST First call for the string B PRINTIT Write last line sec block EJECT , *********************************************************************** * * * Prepare to print the third block letter * * * *********************************************************************** DOTHIRD DS 0H CLI BDSWORKD,5 Done with last line of 3e block BH DETAIL0 Yes, do next * Call the block letter routine ST R4,WRKSAVE Save addr of parm LA R1,WRKSAVE L R15,=V(ANFUBLK) Get address of block builder BALR R14,R15 CLI BDSWORKD,4 First line second block? BH DOREMDR3 No, do remainder of third blk MVI XTPBOUTP,X'F0' Skip line carriage control MVI BDSWORKD,5 Finished first line third blk DOREMDR3 DS 0H TM XTPBOFLG,XTPBLAST Last one? BNO PRINTIT No, don't do next line init MVI BDSWORKD,6 Finished third block B PRINTIT Write last line third block EJECT , *********************************************************************** * * * Prepare to print detail records * * * * The branch tabel below MUST be keep in the same order * * to prevent formating errors * * Every routine at the designated label will set the * * BDSWORKD switch. That switch will be used when this * * module is called again. * * * *********************************************************************** DETAIL0 SLR R3,R3 Get a zero ICM R3,1,BDSWORKD Get the footprint SLL R3,2 Multiply with 4 for B-tabel B BTABEL(R3) Go to the correct rtn BTABEL DS 0F DC 6F'0' Routines already done B DODETAIL BDSWORKD=6 B DOBOXL1 BDSWORKD=7 Start box B DOBOXL2 BDSWORKD=8 Blank line B DOBOXL3 BDSWORKD=9 Date line B DOBLANK3 BDSWORKD=10 Blank line B DOBOXL4 BDSWORKD=11 Time line B DOBLANK4 BDSWORKD=12 Blank line B DOBOXL5 BDSWORKD=13 Jobname line B DOBLANK5 BDSWORKD=14 Blank line B DOBOXL6 BDSWORKD=15 Jobid line B DOBLANK6 BDSWORKD=16 Blank line B DOBOXL7 BDSWORKD=17 Room line B DOBLANK7 BDSWORKD=18 Blank line B DOBOXL8 BDSWORKD=19 Printer line B DOBLANK8 BDSWORKD=20 Blank line B DOBOXL9 BDSWORKD=21 Title line B DOBLANK9 BDSWORKD=22 Blank line B DOBOXL10 BDSWORKD=23 Department line B DOBLANKA BDSWORKD=24 Blank line B DOBOXL11 BDSWORKD=25 Name line B DOBOXL12 BDSWORKD=26 Building line B DOBOXL13 BDSWORKD=27 Address line B DOBOXL14 BDSWORKD=28 Address line B PRADDR BDSWORKD=29 Address line B SKIPSPAC BDSWORKD=30 End box B SPACE1L BDSWORKD=31 B DOLAST BDSWORKD=32 *********************************************************************** * * * End of Branch tabel * * * *********************************************************************** EJECT , *********************************************************************** * * * First space 1 line * * * *********************************************************************** DODETAIL DS 0H MVI WRKCC,C' ' Space 1 line LA R5,1 ST R5,XTPERLEN ST R9,XTPERPTR OI XTPRCFLG,XTPRCTRN Translate it to ASCII OI XTPRCFLG,XTPRCCC Assume it has carriage control OI XTPRCFLG,XTPRCEXT Print the record MVI BDSWORKD,7 B GETOUT EJECT , *********************************************************************** * * * Obtain time and date (year 2000 ready) * * Routine called if BDSWORKD=7 * * * *********************************************************************** DOBOXL1 DS 0H XC WRKY2000(16),WRKY2000 Clear TIME DEC,WRKY2000,LINKAGE=SYSTEM,MF=(E,TIME1) L R0,WRKY2000+8 Point to date 0YYYYDDD SLL R0,4 R0=YYYYDDD0 SLR R1,R1 R1=00000000 IC R1,=X'0F' R1=0000000F OR R0,R1 R0=YYYYDDDF ST R0,WRKDATE Save date packed decimal L R0,WRKY2000 Point to time HHMMSSTT *********************************************************************** * * * Adjust time for am/pm * * * *********************************************************************** LA R2,WRKTIME Get address of work area LA R1,WRKAMPM Get address of AM/PM workarea MVC WRKAMPM(2),AM Set AM/PM to AM CL R0,=X'12000000' Test for zero hours BL PMORNING Branch if AM MVI 0(R1),C'P' Change from AM to PM SL R0,=X'12000000' Subtract twelve hours PMORNING ST R0,0(,R2) Store adjusted time CLI 0(R2),X'00' Test for zero hours BNE PADJERR Br if not to test adj err MVI 0(R2),X'12' Convert zero to twelve PADJERR TM 0(R2),X'08' Test for adjustment errors BZ PEDTIME Branch if no error NI 0(R2),X'09' Correct for binary substr. err PEDTIME DS 0H *********************************************************************** * * * Unpack hours minutes seconds * * * *********************************************************************** MVI WRKTH,X'0C' Reset low order 2 bytes * with sign for packed decimal UNPK WRKUTIME(7),WRKTIME(4) Unpack time CLI WRKHR,X'F0' If hour has leading zero BNE NEXTJ MVC WRKHR(1),BLANK Change zero to blank EJECT , *********************************************************************** * * * Obtain month, day and year * * * *********************************************************************** NEXTJ LA R1,JULTABEL Addressability to Julian table MVC WRKJTBL(48),DAYTBL(R1) Copy table for leap year * adjustment MVC WRKWORK+4(4),WRKDATE Obtain date from saved area TM WRKWORK+5,X'01' test BO NOLEAPYR for TM WRKWORK+5,X'12' leap BM NOLEAPYR year MVI WRKJTBL+4,29 Adjust feb for leap year NOLEAPYR MVC WRKYY(4),=X'20202020' Place pattern for edit ED WRKYY(4),WRKWORK+4 Edit the year MVC WRKWORK(6),ZEROES Reset all but julian date SLR R0,R0 Clear for ic CVB 1,WRKWORK Convert to binary day LA 2,WRKJTBL-4 Address od date conversion * table SEARCH SLR R1,R0 convert LA R2,4(,R2) julian day IC R0,0(,R2) to CLR R0,R1 standard day BL SEARCH CVD 1,WRKWORK Convert to decimal day UNPK WRKDD(2),WRKWORK+6(2) Unpack the day OI WRKDD+1,X'F0' Insure sign nibble MVC WRKMMM(3),1(R2) Set ebcidic alpha month EJECT , *********************************************************************** * * * Start buiding the Box now: * * * * Build and print top line * * * *********************************************************************** TOPLINE DS 0H BAL R14,CLRLINE Clear printline MVI BOXLINE,C'+' Left corner MVI BOXLINE+1,C'-' MVC BOXLINE+2(L'BOXLINE-2),BOXLINE+1 Propogate - char. MVI BOXLINE+74,C'+' Right corner MVI BDSWORKD,8 B GETOUT *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=8 * * * *********************************************************************** DOBOXL2 DS 0H * BAL R14,CLRLINE Clear printline MVI BDSWORKD,9 B GETOUT EJECT , *********************************************************************** * * * Build and print DATE (of printer) * * Routine called if BDSWORKD=9 * * * *********************************************************************** DOBOXL3 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBPRDATE Put PRINT DATE label MVC BOXDD,WRKDD Set print DAY MVC BOXMMM,WRKMMM Set print MONTH MVC BOXYYYY,WRKYY Set print YEAR MVI BDSWORKD,10 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * Routine called if BDSWORKD=10 * * * *********************************************************************** DOBLANK3 DS 0H BAL R14,CLRLINE Clear printline MVI BDSWORKD,11 B GETOUT EJECT , *********************************************************************** * * * Build and print Time (of printer) * * Routine called if BDSWORKD=11 * * * *********************************************************************** DOBOXL4 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBPRTIME Put PRINT TIME label CLC WRKHR(1),BLANK If hour has leading blank BNE HROKAY NO - then branch MVI WRKHR,X'F0' Change blank to zero HROKAY MVC BOXHR(2),WRKHR Set current hour MVI BOXTS1,X'7A' Set time separator MVC BOXMIN(2),WRKMIN Set current minute MVI BOXTS2,X'7A' Set time separator MVC BOXSEC(2),WRKSEC Set current second MVC BOXAMPM(2),WRKAMPM Set current AM/PM MVI BDSWORKD,12 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=12 * * * *********************************************************************** DOBLANK4 DS 0H BAL R14,CLRLINE Clear printline MVI BDSWORKD,13 B GETOUT EJECT , *********************************************************************** * * * Build and print JOB NAME line * * Routine called if BDSWORKD=13 * * * *********************************************************************** DOBOXL5 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBJOBNAM Put JOB NAME label MVC BOXINFO(8),JSPAJBNM Put JOBNAME into box MVI BDSWORKD,14 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=14 * * * *********************************************************************** DOBLANK5 DS 0H BAL R14,CLRLINE Clear printline MVI BDSWORKD,15 B GETOUT EJECT , *********************************************************************** * * * Build and print JOB ID. line * * Routine called if BDSWORKD=15 * * * *********************************************************************** DOBOXL6 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBJOBID Put Job id. label MVC BOXINFO(8),JSPAJBID Put JOBID into box MVI BDSWORKD,16 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=16 * * * *********************************************************************** DOBLANK6 DS 0H BAL R14,CLRLINE Clear printline MVI BDSWORKD,17 B GETOUT EJECT , *********************************************************************** * * * Build and print LIJSTNR line * * Routine called if BDSWORKD=17 * * * *********************************************************************** DOBOXL7 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBROOM Put LIJSTNR. label USING SJTRKEYL,R2 Base KEYLIST ICM R2,B'1111',WRKKYLST Load KEYLIST address BZ NOKEY Branch if NO KEYLIST LA R2,KYLSTRM(,R2) Locate addr. of ROOM * key in the KEYLIST ICM R1,B'1111',SJTRTPAD Load ROOM TU address BZ NOROOM Branch if NO ROOM LA R1,DOCNTENT-DOCNUNIT(,R1) Addr. of TEXT UNIT BAL R8,MOVETU Get ROOM data B PRROOM DROP R2 Drop KEYLIST NOKEY DS 0H MVC BOXINFO,=CL55' ' B PRROOM NOROOM DS 0H MVC BOXINFO,=CL55' ' PRROOM DS 0H MVI BDSWORKD,18 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=18 * * * *********************************************************************** DOBLANK7 DS 0H BAL R14,CLRLINE Clear printline MVI BDSWORKD,19 B GETOUT EJECT , *********************************************************************** * * * Build and print PRT line * * Routine called if BDSWORKD=19 * * * *********************************************************************** DOBOXL8 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBPRNAME Put SYSOUT CLASS label MVC BOXINFO(8),JSPADEVN Put device name MVI BDSWORKD,20 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=20 * * * *********************************************************************** DOBLANK8 DS 0H BAL R14,CLRLINE Clear printline MVI BDSWORKD,21 B GETOUT EJECT , *********************************************************************** * * * Build and print TITLE line * * Routine called if BDSWORKD=21 * * * *********************************************************************** DOBOXL9 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBTITLE Put TITLE label USING SJTRKEYL,R2 Base KEYLIST ICM R2,B'1111',WRKKYLST Load KEYLIST address BZ NOTITLE Branch if NO KEYLIST LA R2,KYLSTTL(,R2) Locate addr. of TITLE * key in the KEYLIST ICM R1,B'1111',SJTRTPAD Load TITLE TU address BZ NOTITLE Branch if NO TITLE LA R1,DOCNTENT-DOCNUNIT(,R1) Addr. of TEXT UNIT BAL R8,MOVETU Get TITLE data B PRTITLE DROP R2 Drop KEYLIST NOTITLE DS 0H MVC BOXINFO,=CL55' ' PRTITLE DS 0H MVI BDSWORKD,22 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=22 * * * *********************************************************************** DOBLANK9 DS 0H BAL R14,CLRLINE Clear printline MVI BDSWORKD,23 B GETOUT EJECT , *********************************************************************** * * * Build and print Department line * * Routine called if BDSWORKD=23 * * * *********************************************************************** DOBOXL10 DS 0H BAL R14,CLRLINE Clear printline MVC BOXDESC,LBDEPT Put DEPT label USING SJTRKEYL,R2 Base KEYLIST ICM R2,B'1111',WRKKYLST Load KEYLIST address BZ NODEPT Branch if NO KEYLIST LA R2,KYLSTDP(,R2) Locate addr. of Department * key in the KEYLIST ICM R1,B'1111',SJTRTPAD Load TITLE TU address BZ NODEPT Branch if NO TITLE LA R1,DOCNTENT-DOCNUNIT(,R1) Addr. of TEXT UNIT BAL R8,MOVETU Get TITLE data B PRDEPT DROP R2 Drop KEYLIST NODEPT DS 0H MVC BOXINFO,=CL55' ' PRDEPT DS 0H MVI BDSWORKD,24 B GETOUT EJECT , *********************************************************************** * * * Build and print 1 blank line * * (Frame characters in box cols 01 & 75) * * Routine called if BDSWORKD=24 * * * *********************************************************************** DOBLANKA DS 0H * BAL R14,CLRLINE Clear printline MVI BDSWORKD,25 B GETOUT EJECT , *********************************************************************** * * * Build and print Name line * * Routine called if BDSWORKD=25 * * * *********************************************************************** DOBOXL11 DS 0H BAL R14,CLRLINE Clear printline USING SJTRKEYL,R2 Base KEYLIST ICM R2,B'1111',WRKKYLST Load KEYLIST address BZ NONAME Branch if NO KEYLIST LA R2,KYLSTNM(,R2) Locate addr. of Name * key in the KEYLIST ICM R1,B'1111',SJTRTPAD Load NAME TU address BZ NONAME Branch if NO NAME LA R1,DOCNTENT-DOCNUNIT(,R1) Addr. of TEXT UNIT BAL R8,MOVETU Get NAME data B PRNAME DROP R2 Drop KEYLIST NONAME DS 0H MVC BOXINFO,=CL55' ' PRNAME DS 0H MVI BDSWORKD,26 B GETOUT EJECT , *********************************************************************** * * * Build and print Building line * * Routine called if BDSWORKD=26 * * * *********************************************************************** DOBOXL12 DS 0H BAL R14,CLRLINE Clear printline USING SJTRKEYL,R2 Base KEYLIST ICM R2,B'1111',WRKKYLST Load KEYLIST address BZ NOBLDG Branch if NO KEYLIST LA R2,KYLSTBL(,R2) Locate addr. of BUILDING * key in the KEYLIST ICM R1,B'1111',SJTRTPAD Load BUILDING TU address BZ NOBLDG Branch if NO BUILDING LA R1,DOCNTENT-DOCNUNIT(,R1) Addr. of TEXT UNIT BAL R8,MOVETU Get BUILDING data B PRBLDG DROP R2 Drop KEYLIST NOBLDG DS 0H MVC BOXINFO,=CL55' ' PRBLDG DS 0H MVI BDSWORKD,27 B GETOUT EJECT , *********************************************************************** * * * Build and print Address line * * Routine called if BDSWORKD=27 * * * *********************************************************************** DOBOXL13 DS 0H MVC WRKADNUM(2),XZERO Zero number of lines BAL R14,CLRLINE Clear printline USING SJTRKEYL,R2 Base KEYLIST ICM R2,B'1111',WRKKYLST Load KEYLIST address BZ NOADDR Branch if NO KEYLIST LA R2,KYLSTAD(,R2) Locate addr. of ADDRESS * key in the KEYLIST ICM R1,B'1111',SJTRTPAD Load ADDRESS TU address BZ NOADDR Branch if NO ADDRESS LH R7,DOCNTNUM-DOCNUNIT(,R1) Number of lines used CL R7,FOUR Is number > 4 ? BNH SAVENUML NO, save number of lines LA R7,4 Yes, set to max of 4 SAVENUML DS 0H STH R7,WRKADNUM Save number of lines LTR R7,R7 Number > 0 ? BZ PRADDR No, print lines DROP R2 LA R1,DOCNTENT-DOCNUNIT(,R1) Addr. of TEXT UNIT USING DOCNTFLD,R1 ADDRLOOP DS 0H LR R6,R1 Save the TU address BAL R8,MOVETU Get ADDRESS data ST R6,WRKSAVR6 ST R7,WRKSAVR7 MVI BDSWORKD,28 B GETOUT EJECT , *********************************************************************** * * * Build and print 2e ADDRESS line * * Routine called if BDSWORKD=28 * * * *********************************************************************** DOBOXL14 DS 0H L R6,WRKSAVR6 L R7,WRKSAVR7 LR R1,R6 Restore TU address LH R15,DOCNTLEN Bump down to next LA R1,L'DOCNTLEN(R15,R1) Address length/data pair BAL R14,CLRLINE Clear printline BCT R7,ADDRLOOP Loop again if more DROP R1 Drop addressability MVI BDSWORKD,29 EJECT , *********************************************************************** * * * Loop to Build/Print Multiple Blank Address lines * * Routine called if BDSWORKD=29 * * * *********************************************************************** NOADDR DS 0H MVC BOXINFO,=CL55' ' PRADDR DS 0H LA R6,4 Load MAX # of lines LH R7,WRKADNUM Restore # of address * lines used SR R6,R7 Find number unused * lines LA R6,1(R6) Add 1 for extra blank line BLKLINE DS 0H ST R6,WRKSAVR6 MVI BDSWORKD,30 B GETOUT Print it *********************************************************************** * * * Build and print bottom line * * Routine called if BDSWORKD=30 * * * *********************************************************************** SKIPSPAC DS 0H BAL R14,CLRLINE Clear printline MVI BOXLINE,C'+' Left corner MVI BOXLINE+1,C'-' MVC BOXLINE+2(L'BOXLINE-2),BOXLINE+1 Propogate - char MVI BOXLINE+74,C'+' Rigth corner MVI BDSWORKD,31 B GETOUT Printit EJECT , *********************************************************************** * * * Space 1 line * * Routine called if BDSWORKD=31 * * * *********************************************************************** SPACE1L DS 0H MVI WRKCC,C' ' Space 1 line LA R5,1 ST R5,XTPERLEN ST R9,XTPERPTR OI XTPRCFLG,XTPRCTRN Translate it to ASCII OI XTPRCFLG,XTPRCCC Assume it has carriage control OI XTPRCFLG,XTPRCEXT Print the record MVI BDSWORKD,32 B GETOUT EJECT , *********************************************************************** * * * Prepare to print the record * * * *********************************************************************** PRINTIT DS 0H LA R5,XTPBOUTP Get record address ST R5,XTPERPTR Put it in XTP area SLR R5,R5 Get a zero IC R5,XTPBLENG Get record length ST R5,XTPERLEN Set length to print OI XTPRCFLG,XTPRCTRN Translate it to ASCII OI XTPRCFLG,XTPRCCC Assume it has carriage control OI XTPRCFLG,XTPRCEXT Print the record B GETOUT *********************************************************************** * * * Prepare to print the last record with page eject * * Routine called if BDSWORKD=32 * * * *********************************************************************** DOLAST OI XTPRCFLG,XTPRLAST Don't call again LA R5,XTPBOUTP Get record address ST R5,XTPERPTR Put it in XTP area MVI XTPBOUTP,X'F1' Page eject carriage control LA R5,1 Get length of record ST R5,XTPERLEN Set length to print OI XTPRCFLG,XTPRCTRN Translate it to ASCII OI XTPRCFLG,XTPRCCC Assume it has carriage control OI XTPRCFLG,XTPRCEXT Print the record *********************************************************************** * * * Return to caller * * * *********************************************************************** GETOUT DS 0H L R13,XTPSAVE+4 Get address of caller save area LM R14,R12,12(R13) Restore caller registers BR R14 Return to MVS EJECT , *********************************************************************** * * * CLRLINE - Clears the separator page line and * * inserts the box frame characters. * * * * FUNCTION: * * * * This subroutine is called to clear the separator * * page line. This is necessary so as to avoid * * printing detail box information left over from * * previous processing with the current line. * * * * LINKAGE: * * * * Accessed via BAL using the label as the entry address * * and register 14 as the return address. * * * * INPUT: * * The separator page line/box buffer (BUFWRK). * * * * OUTPUT: * * The separator page line is cleared and the frame * * characters inserted in columns 1 and 75 of the * * detail box. * * * * XTPERPTR - Address of the separator page line * * XTPERLEN - Length of the separator page line * * XTPRCFLG=XTPRCTRN - Translate it to ASCII * * XTPRCFLG=XTPRCCC - Assume it has carriage control * * XTPRCFLG=XTPRCEXT - Print the record * * * * REGISTER USAGE: * * * * REG VALUE ON ENTRY VALUE ON EXIT * * * * R1-R7 N/A Unchanged * * R8 N/A Destroyed * * R9-R13 N/A Unchanged * * R14 Return address Unchanged * * R15 N/A Unchanged * * * * RETURN CODES: * * * * None * * * * OTHER CONSIDERATIONS: * * * * None * * * *********************************************************************** EJECT , CLRLINE DS 0H MVI WRKCC,C' ' Set CC to write 1 line MVI PAGELINE,C' ' Clear 1st printline character MVC PAGELINE+1(L'PAGELINE-1),PAGELINE Propogate space MVI BOXCOL1,C'|' Insert box MVI BOXCOL75,C'|' frame character ST R9,XTPERPTR Store record address MVC XTPERLEN(4),ESSLLEN Get length of record OI XTPRCFLG,XTPRCTRN Translate it to ASCII OI XTPRCFLG,XTPRCCC Assume it has carriage control OI XTPRCFLG,XTPRCEXT Print the record BR R14 Return to caller EJECT , *********************************************************************** * * * MOVETU - Move the TU text from the TU output area to the * * detail line DSECT. * * FUNCTION: * * * * This subroutine is called to move the TU text from the * * TU output area to the detail line DSECT area. Since * * TUs are variable length (up to sixty characters long), * * the detail line is padded with blanks on the right after * * the move is performed. * * * * LINKAGE: * * * * Accessed via BAL using the label as the entry address * * and register 8 as the return address. * * * * INPUT: * * R1 - Address of TU length/parameter pair * * * * OUTPUT: * * The text from the TU parameter is copied into the * * detail line DSECT area ( BOXINFO ). * * * * REGISTER USAGE: * * * * REG VALUE ON ENTRY VALUE ON EXIT * * * * R0 N/A Destroyed * * R1 Length/Parameter Pair Destroyed * * R2-R7 N/A Unchanged * * R8 Return Address Unchanged * * R9-R13 N/A Unchanged * * R14-R15 N/A Destroyed * * * * RETURN CODES: * * * * None * * * * OTHER CONSIDERATIONS: * * * * None * * * *********************************************************************** USING DOCNTFLD,R1 MOVETU LA R14,DOCNTPRM Load TU text address LH R15,DOCNTLEN Length of TU text ICM R15,B'1000',BLANKS Set pad char to blank LA R0,BOXINFO Set up the LA R1,L'BOXINFO receiving field MVCL R0,R14 Move the text BR R8 Return to caller DROP R1 *********************************************************************** * * * Constants and Literals * * * *********************************************************************** * * * ANSI defined Printer Control Characters: * * Blank = Space 1 line * * 0 = Space 2 line * * - = Space 3 line * * + = Suppress space * * 1 = Skip to line 1 on new page * * * *********************************************************************** SETUPSTR DC 0C DC X'27' escape DC X'50' ampersand DC C'n6Wdxxxxx' set papertype to Plain SETUPLEN EQU *-SETUPSTR DS 0D * JULTABEL DS 0H DC AL1(31),CL3'JAN',AL1(28),CL3'FEB' JULIAN DC AL1(31),CL3'MAR',AL1(30),CL3'APR' DAY DC AL1(31),CL3'MAY',AL1(30),CL3'JUN' AND DC AL1(31),CL3'JUL',AL1(31),CL3'AUG' MONTH DC AL1(30),CL3'SEP',AL1(31),CL3'OCT' CONVERSION DC AL1(30),CL3'NOV',AL1(255),CL3'DEC' TABLE EJECT , *********************************************************************** * * * Misc constants and equates * * * *********************************************************************** XZERO DC F'0' FOUR DC F'4' ESSLLEN DC F'76' ZEROES DC X'000000000000' BLANK DC X'40' BLANKS DC CL8' ' AM DC CL2'AM' MAXSEG# DC PL8'99999' PZERO DC PL8'00000' DAYTBL EQU 0 *********************************************************************** * * * All labels that will appear in the detailbox are listed below* * * *********************************************************************** LBJOBID DC CL(L'BOXDESC)'Job id :' LBJOBNAM DC CL(L'BOXDESC)'Jobnaam :' LBROOM DC CL(L'BOXDESC)'Lijstnr :' LBPRTIME DC CL(L'BOXDESC)'Tijd :' LBPRDATE DC CL(L'BOXDESC)'Datum :' LBPRNAME DC CL(L'BOXDESC)'Printer :' LBTITLE DC CL(L'BOXDESC)'Overzicht:' LBDEPT DC CL(L'BOXDESC)'Afdeling :' LBMSG DC CL(L'BOXMSG)'EXIT ERROR -- SWBTUREQ MACRO FAILED' LBRC DC CL(L'BOXRCLB)'RETURN CODE:' LBRS DC CL(L'BOXRSLB)'REASON CODE:' EJECT , *********************************************************************** * * * Ltorg pool * * * *********************************************************************** LTORG *********************************************************************** * * * Key list equates * * * *********************************************************************** KYLSTTL EQU 0*SJTRKLEN Title key KYLSTNM EQU 1*SJTRKLEN Name key KYLSTRM EQU 2*SJTRKLEN Room key KYLSTBL EQU 3*SJTRKLEN Building key KYLSTDP EQU 4*SJTRKLEN Dept key KYLSTAD EQU 5*SJTRKLEN Address key *********************************************************************** * * * Equates for registers 0-15 * * * *********************************************************************** R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 EJECT , *********************************************************************** * * * ANFUXHDR work buffer * * * *********************************************************************** BUFWRK DSECT WRKCC DS CL1 Carriage control WRKDATA DS CL75 Data line WRKARORG DS 0CL1 Work area ORG BUFPRT EQU WRKDATA ORG WRKDATA *********************************************************************** * * * Begin separator page line & detail box mapping * * * *********************************************************************** ORG WRKDATA Separator page line & PAGELINE DS 0CL75 BOXLINE DS 0CL75 * COL DESCRIPTION BOXCOL1 DS CL1 1 Frame Character DS CL1 2 Blank BOXDESC DS CL13 3-15 Line Description DS CL1 16 Blank BOXINFO DS CL55 17-66 Line Information DS CL3 66-69 Blanks BOXCOL75 DS CL1 75 Frame Character ORG BOXINFO Output Group area BOXJNAME DS CL8 17-24 JOE name BOXGSEP1 DS CL1 25 Group separator BOXJID1 DS 0CL5 26-30 JOE ID 1 DS CL4 26-29 BOXJZON1 DS CL1 30 Byte field for MVZ BOXGSEP2 DS CL1 31 Group separator BOXJID2 DS 0CL5 32-36 JOE ID 2 DS CL4 32-35 BOXJZON2 DS CL1 36 Byte field for MVZ ORG BOXINFO Print Time Area BOXTIME DS 0CL11 17-27 BOXHR DS CL2 17-18 Print Hour BOXTS1 DS CL1 19 Separator BOXMIN DS CL2 20-21 Print Minute BOXTS2 DS CL1 22 Separator BOXSEC DS CL2 23-24 Print Second DS CL1 25 BOXAMPM DS CL2 26-27 AM / PM ORG BOXINFO Print Date Area BOXDATE DS 0CL9 17-25 Printing Date BOXDD DS CL2 17-18 Printing Day DS CL1 19 BOXMMM DS CL3 20-22 Printing Month DS CL1 23 BOXYYYY DS CL4 24-27 Printing Year ORG BOXINFO SWBTUREQ Error Msg Area BOXMSG DS 0CL40 17-56 BOXMSG1 DS CL40 17-56 Static msg text ORG BOXINFO BOXRCLB DS CL12 17-28 RETURN CDE label DS CL1 29 BOXRC DS CL4 30-33 SWBTUREQ ORG BOXINFO BOXRSLB DS CL12 17-28 REASON CDE label DS CL1 29 BOXRS DS CL4 30-33 SWBTUREQ *********************************************************************** * * * End separator page line & detail box mapping * * * *********************************************************************** EJECT , *********************************************************************** * * * Work Areas * * * *********************************************************************** WRKAREAS EQU WRKARORG ORG WRKARORG DS 0F WRKDATE DS CL4 Current date - packed WRKTIME DS CL4 Current time - packed ORG WRKTIME DS CL3 Hours minutes seconds WRKTH DS CL1 Tenths and hundredths WRKUDATE DS CL8 Current date - unpacked ORG WRKUDATE WRKMMM DS CL3 Month WRKDD DS CL2 Day WRKYY DS CL4 Year DS CL1 Reserved WRKAMPM DS CL2 Current AM/PM WRKUTIME DS CL7 Current time - unpacked ORG WRKUTIME WRKHR DS CL2 Hour WRKMIN DS CL2 Minute WRKSEC DS CL2 Second DS CL1 Sign byte DS CL1 Reserved WRKJID1 DS F Work area for JOE id 1 WRKJID2 DS F Work area for JOE id 2 DS 0D Alignment WRKJIDEC DS CL8 Work area JOE id to decimal WRKJID1Z DS CL8 Work area JOE id 1 to zoned WRKJID2Z DS CL8 Work area JOE id 2 to zoned WRKWORK DS CL8 Work area for conversion WRKJTBL DS CL48 Julian conversion table WRKY2000 DS CL16 Time SVC work area TIME1 TIME LINKAGE=SYSTEM,MF=L Year 2000 ready DS 10F Alignment WRKSAVR6 DS F Work area save reg 6 WRKSAVR7 DS F Work area save reg 7 WRKSAVE DS F Work area save reg BDSWORKD DS 8BL1 BDSWORKE DS 8BL1 EJECT , *********************************************************************** * * * SWBTUREQ declares * * * *********************************************************************** DS 0F WRKADNUM DS H Number of ADDRESS lines WRKPLPTR DS F Address of SWBTUREQ parmlist WRKKYLST DS F Keylist address OUTTUWS DS CL1024 SWBTUREQ Output Area FULLWORD DS F Full word work area DBLWORD DS D Double word work area SWBRC DS F SWBTUREQ return code SWBRS DS F SWBTUREQ reason code SWBERR DS CL1 SWBTUREQ error = "Y" DS 0F KEYLIST DS CL64 SJTRKEYL Area SBTLAREA DS CL16 SJTRSBTL Area SWBTUWS DS CL1024 SWBTUREQ Work Area BDSWORKB DS CL256 AREA FOR OUTPUT RECORD TESTLEN EQU *-BUFWRK BUFWRKL EQU 4000 *********************************************************************** * * * Even though the SWBTUREQ parameter list is invoked * * with DSECT=NO, there are still DSECTs in the macro. * * Therefore do NOT attempt to add DCs or DSs after this * * macro that are not part of a DSECT. * * * *********************************************************************** * * * Total length of the work buffer (BUFWRK) is BUFWRKL. * * This includes also DC and DS in the next macro: IEFSJTRP * * IEFSJTRP consists (with DSECT=NO) of the parm list * * and two DSECTS: SJTRSBTL and SJTRKEYL. * * The SWBTUREQ parm list must be part of the work buffer (BUFWRK) * * * *********************************************************************** IEFSJTRP DSECT=NO SWBTUREQ parm. list *********************************************************************** * * * End of ANFUXHDR work buffer * * * *********************************************************************** TITLE 'Dsects' IEFDOTUM Text unit mapping IEFDOKEY OUTPUT key mapping IEFSJTRC SWBTUREQ return codes ANFUEXTP IEFJMR IAZJSPA LIST=YES CVT DSECT=YES Required for SWBTUREQ IEFJESCT Required for SWBTUREQ END , End of ANFUXHDR module