Date: 3/29/2002
Time: 9:59:06 PM
Remote Name: 209.178.164.237
[ Home | Contents | Search | Post | Reply | Next | Previous | Up ]
From:
Date: 3/29/2002
Time: 9:59:06 PM
Remote Name: 209.178.164.237
Here it is:
TELRPLMD TITLE 'TELRPLMD - FIND DFHRPL FOR PROGRAM'
***********************************************************************
* SWA STORAGE *
***********************************************************************
SWADSECT DSECT
SWASTART EQU *
EPA DS CL28
SWEPAPTR DS F
SWAPARMS SWAREQ MF=L
SWALENG EQU *-SWASTART
***********************************************************************
* PROGRAM STORAGE *
***********************************************************************
DFHEISTG DSECT
HEADERA DS CL5
HEADERT DS CL8
HEADERB1 DS CL24
HEADERC DS CL6
HEADERS DS CL4
HEADERB2 DS CL24
HEADERD DS CL8
HEADERNL DS CL2
PGMNAMCA DS CL5
PGMNAMC DS CL8
PGMNAMA DS CL2
PGMNAM DS CL8
PGMNAMEA DS CL2
HEADERLE EQU *-HEADERA
TEXTLEN DS H
TEXTPTR DS F
ABSTIME DS D
DSNAME DS CL44
CONCAT DS CL4
DDNAME DS CL8
SERV1SAV DS F
TCBSAVE DS F
BLDLAREA DS CL20
REGSTORE DS 16F
MVSREGSA DS 18F
TEXTOUT DS CL256
***********************************************************************
* PROGRAM LOGIC *
***********************************************************************
TELRPLMD DFHEIENT CODEREG=(R3,R4),DATAREG=(R12),EIBREG=(R8)
TELIN
CLI EIBAID,DFHCLEAR IS THIS CLEAR?
BE MAIN0910 YES, RETURN AND END
CLI EIBAID,DFHPF3 PF3?
BE MAIN0910 YES, RETURN AND END
CLI EIBAID,DFHPF15 PF3?
BE MAIN0910 YES, RETURN AND END
B PROC1000
***********************************************************************
* EXIT LOGIC *
***********************************************************************
MAIN0900 EXEC CICS RETURN TRANSID(EIBTRNID)
MAIN0910 EXEC CICS SEND CONTROL ERASE FREEKB
EXEC CICS RETURN
***********************************************************************
* MAIN LOGIC *
***********************************************************************
PROC1000 OC PGMNAM,=CL8' ' CLEAR PGMNAM
EXEC CICS RECEIVE SET(R10) LENGTH(TEXTLEN)
CLC 0(4,R10),EIBTRNID IS THIS UNFORMATTED?
BE PROC2000 YES, GO SEND INITIAL
LH R2,TEXTLEN GET LENGTH OF TEXT
SH R2,=H'3' SUBTRACT 3 TO BYPASS FIRST SA
BNP PROC1020 NOT > 0, GO DO PROCESS
LA R1,PGMNAM GET STARTING ADDRESS OF PGMNAM
LA R10,3(R10) BUMP PAST SA
PROC1010 MVC 0(1,R1),0(R10) MOVE IN PGMNAM
LA R1,1(R1) GO TO NEXT BYTE TO MOVE TO
LA R10,1(R10) GO TO NEXT BYTE TO MOVE FROM
BCT R2,PROC1010 GO DO NEXT BYTE
B PROC1020 GO PROCESS
***********************************************************************
* PROCESS PGMNAM FOUND IN ENTERED COMMAND *
***********************************************************************
PROC1020 MVC TEXTOUT(DSNAMEL),DSNAMES MOVE IN SEND TEXT
MVC DDNAME,=CL8'DFHRPL' GET DFHRPL FIRST
BAL R1,SERV1000 GET DFHRPL FIRST
LA R10,TEXTOUT GET OUTPUT AREA
MVC DFHRPLO-DSNAMES(L'DFHRPLO,R10),DSNAME MOVE DSNAME
MVC CONCATDO-DSNAMES(L'CONCATDO,R10),CONCAT MOVE CONCAT #
* MVC DDNAME,=CL8'STEPLIB' GET STEPLIB NEXT
MVC DDNAME,=XL8'0000000000000000' GET STEPLIB NEXT
BAL R1,SERV1000 GET STEPLIB NEXT
LA R10,TEXTOUT GET OUTPUT AREA
MVC STEPLIBO-DSNAMES(L'STEPLIBO,R10),DSNAME MOVE DSNAME
MVC CONCATSO-DSNAMES(L'CONCATSO,R10),CONCAT MOVE CONCAT #
***********************************************************************
* SEND THE CREATED TEXT *
***********************************************************************
MVC TEXTLEN,=AL2(DSNAMEL) MOVE SEND LENGTH
EXEC CICS SEND TEXT FROM(TEXTOUT) LENGTH(TEXTLEN) ERASE
***********************************************************************
* BUILD AND SET FIRST SCREEN *
***********************************************************************
PROC2000 XC TEXTLEN,TEXTLEN CLEAR TEXT LENGTH
LA R0,TEXTOUT GET ADDRESS OF OUTPUT TEXT
ST R0,TEXTPTR STORE ADDRESS OF OUTPUT TEXT
MVI HEADERA,STFIELD MOVE IN START FIELD
MVI HEADERA+1,DFHBMASK MOVE IN ASKIP
MVI HEADERA+2,DFHSA MOVE IN SET ATTRIBUTE
MVI HEADERA+3,DFHCOLOR MOVE IN COLOR
MVI HEADERA+4,DFHTURQ MOVE IN COLOR TURQUOISE
MVC HEADERC,=CL6'SYSID=' INDICATE SYSID
EXEC CICS ASSIGN SYSID(HEADERS)
EXEC CICS ASKTIME ABSTIME(ABSTIME)
EXEC CICS FORMATTIME ABSTIME(ABSTIME) X
TIME(HEADERT) TIMESEP MMDDYY(HEADERD) DATESEP
MVC HEADERB1,=CL24' '
MVC HEADERB2,=CL24' '
MVI HEADERNL,NEWLINE MOVE NEW LINE AFTER LINE1
MVI HEADERNL+1,NEWLINE MOVE NEW LINE AFTER LINE1
MVC PGMNAMCA,HEADERA MOVE IN DEFAULT DISPLAY ATTRIBUTE
MVC PGMNAMC,=CL8'PGNNAME:'
MVI PGMNAMA,STFIELD MOVE IN START FIELD
MVC PGMNAMA+1(1),=AL1(DFHBMUNP+DFHBMFSE+DFHBMBRY)
MVI PGMNAMEA,STFIELD MOVE IN START FIELD
MVI PGMNAMEA+1,DFHBMASK MOVE IN ASKIP
LH R1,TEXTLEN GET TEXT LENGTH
LA R1,HEADERLE(R1) ADD LENGTH OF HEADER
STH R1,TEXTLEN STORE TEXT LENGTH
L R1,TEXTPTR GET OUTPUT LOCATION
MVC 0(HEADERLE,R1),HEADERA MOVE OUTPUT LINE
LA R1,HEADERLE(R1) BUMP UP MVC LENGTH
ST R1,TEXTPTR
EXEC CICS SEND TEXT FROM(TEXTOUT) LENGTH(TEXTLEN) X
FREEKB CURSOR(=AL2(171))
B MAIN0900
***********************************************************************
* GET DSNAME AND CONCAT FORM DDNAME *
***********************************************************************
SERV1000 ST R1,SERV1SAV STORE RETURN ADDRESS
MVC CONCAT,=CL4' '
USING PSA,R0
SERV1010 L R1,PSATOLD DDNLOOP - GET TCB'S ADDRESS
USING TCB,R1
SERV1020 ST R1,TCBSAVE TCBLOOP
SR R2,R2 CLEAR R2
ICM R2,B'1111',TCBDEB GET FIRST DEB ADDRESS
BZ SERV1050 INDICATE DFHRPL NOT FOUND
L R5,TCBTIO GET TIOT ADDRESS
DROP R1
USING DEBBASIC,R2
SERV1030 SR R1,R1 DEB LOOP - CLEAR R1
ICM R1,B'0111',DEBDCBB GET DCB ADDRESS
BZ SERV1040 ZERO, GO GET NEXT DEB
USING IHADCB,R1
LH R10,DCBTIOT GET OFFSET INTO TIOT FOR THIS ENTRY
AR R10,R5 GET TRUE TIOT ENTRY
USING TIOENTRY,R10
CLC TIOEDDNM,DDNAME DDNAME FOUND?
BE SERV1100
SERV1040 SR R1,R1 NEXT DEB - CLEAR R1
ICM R1,B'0111',DEBDEBB GET NEXT DEB ADDRESS
BZ SERV1050 INDICATE DFHRPL NOT FOUND
LR R2,R1 GET DEB ADDRESS
B SERV1030 GO GET'EM TIGER
DROP R1,R2
SERV1050 L R2,TCBSAVE GET TCB'S ADDRESS
USING TCB,R2
SR R1,R1
ICM R1,B'1111',TCBBACK GET NEXT TCB
DROP R2
BZ SERV1060 NO, CONTINUE TO SERV1100
C R1,PSATOLD SEE IF WE'VE HIT END
BNE SERV1020
SERV1060 MVC DSNAME,=CL44'DCB NOT FOUND '
B SERV1140
SERV1100 STM R0,R15,REGSTORE STORE REGISTERS
LA R13,MVSREGSA GET ADDRESS OF MVS SA
MVC BLDLAREA(2),=H'1' INDICATE 1 ENTRY
MVC BLDLAREA+2(2),=H'14' 14 BYTE ENTRY
MVC BLDLAREA+4(8),PGMNAM MOVE IN PROGRAM NAME
BLDL (R1),BLDLAREA GO DO BLDL
LM R0,R14,REGSTORE STORE REGISTER
LTR R15,R15 TEST R15
BNZ SERV1130 NOT FOUND
USING IHADCB,R1
LH R10,DCBTIOT GET OFFSET INTO TIOT FOR THIS ENTRY
DROP R1
L R1,PSATOLD
USING TCB,R1
L R5,TCBTIO GET TIOT ADDRESS
AR R10,R5 GET TRUE TIOT ENTRY
DROP R1
SR R1,R1 CLEAR R1
ICM R1,B'0001',BLDLAREA+15 GET CONCATENATION NUMBER
CVD R1,ABSTIME CONVERT TO DECIMAL
UNPK CONCAT+1(3),ABSTIME+6(2) UNPACK
OI CONCAT+3,C'0' FORCE X'F0'
MVI CONCAT,C'+'
SERV1110 CH R1,=H'1' COMPARE WITH H'1'
BL SERV1120 LOW, FOUND DSNAME
BCTR R1,0 SUBTRACT COUNT BY ONE
SR R0,R0 CLEAR R0
IC R0,TIOELNGH GET TIOE LENGTH
AR R10,R0 BUMP UP TO NEXT TIOT ENTRY
B SERV1110
SERV1120 EXEC CICS GETMAIN SET(R6) BELOW FLENGTH(=A(SWALENG))
USING SWADSECT,R6
LA R5,EPA GET ADDRESS OF THE EPA
ST R5,SWEPAPTR INITIALIZE EPA POINTER
USING ZB505,R5 ESTABLISH ADDRESSABILITY TO EPA
* XC SWAEPA,SWAEPA INITIALIZE THE EPA
XC SWAEPAX,SWAEPAX INITIALIZE THE EPA
* USING TIOT1,R10 ESTABLISH ADDRESSABILITY TO TIOT
MVC SWVA,TIOEJFCB MV SVA OF JFCB INTO EPA
STM R0,R15,REGSTORE STORE REGISTERS
LA R13,MVSREGSA GET ADDRESS OF MVS SA
SWAREQ FCODE=RL,EPA=SWEPAPTR,UNAUTH=YES,MF=(E,SWAPARMS)
LM R0,R14,REGSTORE STORE REGISTER
LTR R15,R15 TEST R15
BNZ SERV1130 NOT FOUND
L R7,SWBLKPTR SET THE POINTER TO THE JFCB
USING INFMJFCB,R7 ESTABLISH ADDRESSABILITY TO JFCB
MVC DSNAME,JFCBDSNM MOVE IN DSNAME
EXEC CICS FREEMAIN DATAPOINTER(R6)
DROP R5,R6,R7
B SERV1140
SERV1130 MVC DSNAME,=CL44'PROGRAM NOT FOUND IN CONCATENATION'
SERV1140 L R1,SERV1SAV GET RETURN ADDRESS
BR R1 RETURN
***********************************************************************
* WORK AREAS *
***********************************************************************
DSNAMES DC XL6'151515151515'
DC AL1(STFIELD,DFHBMASK,DFHSA,DFHCOLOR,DFHTURQ)
DC C' DFHRPL: '
DFHRPLO DS CL44
DC C' CONCAT: '
CONCATDO DS CL4
DC XL6'1515'
DC AL1(STFIELD,DFHBMASK,DFHSA,DFHCOLOR,DFHTURQ)
DC C'STEPLIB: '
STEPLIBO DS CL44
DC C' CONCAT: '
CONCATSO DS CL4
DSNAMEL EQU *-DSNAMES
***********************************************************************
* CONSTANTS AND EQUATES *
***********************************************************************
NEWLINE EQU X'15'
STFIELD EQU X'1D'
COPY DFHAID
COPY DFHBMSCA
DCBD DSORG=PO,DEVD=DA
IEFTIOT1
IEZDEB LIST=YES
IHAPSA LIST=YES
IKJTCB LIST=YES
CVT DSECT=YES,LIST=YES
IEFJESCT
IEFZB505 LOCEPAX=YES
IEFJFCBN LIST=YES
END