Attached is the VBSFIX program.
Thanks
-----Original Message-----
From: IBM Mainframe Discussion List [mailto:IBM-MAIN@LISTSERV.UA.EDU] On Behalf
Of Carmen Vitullo
Sent: Monday, April 02, 2018 10:34 AM
To: IBM-MAIN@LISTSERV.UA.EDU
Subject: Re: VBSFIX Program
DFsort and syncsort can correct some bad record formats in SMF
//SYSIN DD *
INCLUDE COND=ALL
OPTION COPY,VLSHRT
Carmen Vitullo
----- Original Message -----
From: "Veryl Ellis" <veryl.el...@sungardas.com>
To: IBM-MAIN@LISTSERV.UA.EDU
Sent: Monday, April 2, 2018 10:22:23 AM
Subject: VBSFIX Program
Does anyone have a copy of the IBM module VBSFIX?
I have short record(s) in my SMF dump dataset, which is prohibiting me from
doing my monthly SCRT thing.
I've seen information that this program can resolve this issue.
Anyone out there have this program and are willing to share?
Thanks,
S. Veryl Ellis
Sungard Availability Services.
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions, send email to
lists...@listserv.ua.edu with the message: INFO IBM-MAIN
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions, send email to
lists...@listserv.ua.edu with the message: INFO IBM-MAIN
*** Disclaimer ***
This communication (including all attachments) is solely for the use of the
person to whom it is addressed and is a confidential AAA communication. If you
are not the intended recipient, any use, distribution, printing, or copying is
prohibited. If you received this email in error, please immediately delete it
and notify the sender.
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to lists...@listserv.ua.edu with the message: INFO IBM-MAIN
VBSF TITLE 'PROGRAM TO READ VBS RECORDS AND CLEAN UP BAD SEGMTS'
***********************************************************************
* *
* THIS PROGRAM IS DISTRIBUTED ON AN "AS IS" BASIS. IBM MAKES NO *
* WARRANTIES, EITHER EXPRESSED OR IMPLIED, AS TO ITS USABILITY OR *
* SUITABILITY FOR ANY PURPOSE WHATSOEVER. THE USER OF THIS PROGRAM *
* ACCEPTS FULL RESPONSIBILITY FOR ANY DAMAGES THAT MAY RESULT FROM *
* THE USE OF THIS PROGRAM, AND IBM SHALL NOT BE HELD LIABLE FOR ANY *
* DAMAGES -- EITHER DIRECT OR CONSEQUENTIAL -- WHICH MAY RESULT FROM *
* ITS USE. *
* *
***********************************************************************
* *
* *
* FUNCTION - THIS PROGRAM IS DESIGNED TO READ A VBS DATASET (NON- *
* VSAM) AND CHECK ON VALID SDW'S. *
* INVALID SEGMENTS ARE CONVERTED TO VB OUTPUT IN FILE 'BADRECS'. *
* VALID RECORDS ARE COPIED TO FILE 'OUTPUT'. *
* *
* EXEC PARMS: 'SMF' - THIS CAUSES THE PROGRAM TO DISPLAY THE SMF *
* RECORD ID (BYTE 2) AS PART OF ERROR MESSAGES. *
* *
* INPUT - VBS FILE TO BE CHECKED : 'INPUT' *
* *
* OUTPUT- VBS FILE FOR GOOD RECORDS : 'OUTPUT' *
* V(B) FILE WITH BAD SEGMENTS : 'BADRECS' *
* ERROR MESSAGE FILE : 'SYSPRINT' *
* *
* METHODOLOGY - THE INPUT FILE IS READ IN ONE SEGMENT AT A TIME *
* (LOCATE MODE). *
* SEGMENTS ARE CHECKED MANUALLY, AND A NEW LOGICAL *
* RECORD IS CREATED AND WRITTEN TO OUTPUT. *
* SEGMENTS WHICH DON'T MATCH UP ARE WRITTEN INTACT TO FILE *
* BADRECS FOR LATER ANALYSIS. *
* A DESCRIPTIVE ERROR MESSAGE IS WRITTEN TO SYSPRINT FOR EACH *
* BAD RECORD DETECTED. *
* *
* AUTHOR - B. K. PIERCE, WASHINGTON SYSTEMS CENTER. *
* *
* MAINTENANCE HISTORY - (ORIGINAL DATE - 4/28/80) *
* V1M1 (12/06/81): ERROR IN RECORD UNSTACK ROUTINE. *
* SUPPORT FOR SYNAD EXIT AND ERROR MESSAGES *
* V1M2 (02/05/82): ADD SYNAD SUPPORT FOR OUTPUT DATASET *
* V1M3 (04/22/85): FIXUP SYNAD ROUTINES FOR REG SAVE/RESTORE *
* V1M4 (05/08/85): ADD MISC. COUNTS AND SET MAXCC RETURN CODE *
* V1M5 (09/24/92): FIX RECORD COUNT IN ERROR MESSAGES, ADD A MAX I/O *
* ERROR COUNT, CURRENT IS 6. *
* V1M5A(03/02/93): FIX THE TOTAL RECORD COUNT (WAS COUNTING 2X) *
* V1M6 (04/19/96): DO MORE WORK ON THE SYNAD ROUTINES *
* *
***********************************************************************
SPACE
***********************************************************************
* IN-LINE MACRO TO INCREMENT COUNTERS (USING R15). *
***********************************************************************
SPACE
MACRO
&LABEL ADD1 &FIELD
&LABEL L 15,&FIELD GET CURRENT VALUE
LA 15,1(,15) ADD 1 TO COUNT
ST 15,&FIELD SAVE NEW VALUE
MEND
SPACE
***********************************************************************
* IN-LINE MACRO TO SET MAXCC VALUE (USING R15). *
***********************************************************************
SPACE
MACRO
&LABEL SETCC &CC
&LABEL LA 15,&CC GET CURRENT VALUE
C 15,MAXCC COMPARE AGAINST PREV. VALUE
BNH *+8 IF NOT HIGHER, QUIT
ST 15,MAXCC SAVE NEW VALUE
MEND
SPACE
***********************************************************************
* GENERAL PURPOSE REGISTER USAGE (FP REGS ARE NOT USED) *
***********************************************************************
SPACE
R0 EQU 0 PARM REG
R1 EQU 1 PARM REG
R2 EQU 2 WORK REG
R3 EQU 3 WORK REG
R4 EQU 4 WORK REG
R5 EQU 5 WORK REG
R6 EQU 6 WORK REG
R7 EQU 7 WORK REG
R8 EQU 8 WORK REG
R9 EQU 9 BAD BLOCK COUNTER
R10 EQU 10 LINKAGE REGISTER
R11 EQU 11 RECORD COUNTER
R12 EQU 12 PRIMARY BASE REG
R13 EQU 13 SAVE AREA POINTER/SEC. BASE REG
R14 EQU 14 SYSTEM LINKAGE REG
R15 EQU 15 EP / RETURN CODE REG
SPACE 2
***********************************************************************
* PROGRAM INITIALIZATION CODE: ADDRESSIBILITY, SAVE AREAS, ETC *
***********************************************************************
SPACE
VBSFIX CSECT
SAVE (14,12),,*
LR R12,R15 GET EP ADDRESS
USING VBSFIX,R12 SET BASE ADDRESSING
LA R2,SAVEAREA GET A(SAVE AREA)
ST R13,4(,R2) SAVE A(HSA)
ST R2,8(,R13) AND A(LSA)
LR R13,R2 GET SAVE IN R13
SPACE
L R1,0(,R1) GET A(PARM)
LH R2,0(,R1) GET PARM LENGTH
LTR R2,R2 TEST FOR ZERO
BZ NOPARM YES, NO PARM SUPPLIED
CLC 2(3,R1),=C'SMF' TEST FOR SMF
BNE NOPARM NO, IGNORE IT
OI OPTIONS,SMF SET SMF SWITCH
NOPARM DS 0H
SPACE
***********************************************************************
* OPEN ALL DATASETS, AND ISSUE ERROR MESSAGES IF ANY FAIL TO OPEN. *
***********************************************************************
SPACE
OPEN (SYSPRINT,OUTPUT) OPEN MESSAGES D/S
LA R2,SYSPRINT GET ADDRESS
USING IHADCB,R2 ADDRESSIBILITY
TM DCBOFLGS,DCBOFOPN TEST FOR OPEN
BO HEADER YES, BYPASS ERROR
WTO 'VBSFIX: OPEN FAILED FOR SYSPRINT, ENDED.', X
ROUTCDE=11
LA R15,16 SET RETURN
B RETURN GOTO EXIT
HEADER DS 0H
PUT SYSPRINT,HEADER1 PUT OUT HEADER
PUT SYSPRINT,HEADER2 AND SPACER
OPNALL DS 0H
OPEN (INPUT,INPUT,OUTPUT,OUTPUT,BADRECS,OUTPUT)
LA R2,INPUT GET ADDRESS
TM DCBOFLGS,DCBOFOPN TEST FLAGS
BO OPNCHK1 YES, BYPASS ERROR
PUT SYSPRINT,=CL121'0*** OPEN FAILED FOR INPUT, ENDED.'
SETCC 16
B RETURN
OPNCHK1 DS 0H
LA R2,OUTPUT GET ADDRESS
TM DCBOFLGS,DCBOFOPN TEST FLAGS
BO OPNCHK2 YES, BYPASS ERROR
PUT SYSPRINT,=CL121'0*** OPEN FAILED FOR OUTPUT, ENDED.'
SETCC 16
B RETURN
OPNCHK2 DS 0H
LA R2,BADRECS GET ADDRESS
TM DCBOFLGS,DCBOFOPN TEST FLAGS
BO OPNCHK3 YES, BYPASS ERROR
PUT SYSPRINT,=CL121'0*** OPEN FAILED FOR BADRECS, ENDED.'
SETCC 16
B RETURN
DROP R2
OPNCHK3 DS 0H
SPACE
***********************************************************************
* ALL DATASETS ARE NOW OPEN, PROCEED TO INITIALIZE POINTERS AND READ *
* A RECORD FROM INPUT. *
* IF THERE IS NO SEGMENTATION INVOLVED, SIMPLY MOVE THE RECORD TO *
* OUTPUT AREA. *
* ELSE GO AND PROCESS AS SEGMENTED RECORD. *
***********************************************************************
SPACE
XC ANCHOR,ANCHOR CLEAR ANCHOR POINTER
MVI SEGSW,1 CLEAR SWITCH
READIN DS 0H
GET INPUT READ A SEGMENT
CLC SKIPRECS,ERRMAX CHECK # OF ERRORS
BH ERRINPUT IF TOO HIGH, QUIT
LR R2,R1 SAVE POINTER
ADD1 TOTSEG ADD TO REC COUNT
CLI SEGSW,2 TEST FOR SEGMENTATION
BE PROCSEG YES, GO TO PROCESS
CLI 2(R2),0 TEST FOR SEGMENTED RECORD
BNE FIRSTSEG YES, GO TO PROCESS
PUTOUT DS 0H
ADD1 TOTRECG ADD ONE TO GOOD RECORDS
LA R0,RECORD MOVE OUTPUT POINTER
LH R1,0(,R2) GET LENGTH
LR R3,R1 INTO FIRST & SEC OP REGS
LR R9,R1 SAVE THE CURRENT RECL LENGTH
MVCL R0,R2 MOVE RECORD TO OUTPUT
C R9,MIN TEST AGAINST MINIMUM
BNL *+8 NOT LOW, BYPASS CHANGE
ST R9,MIN SAVE NEW VALUE
C R9,MAX TEST AGAINST MAX
BNH *+8 NOT HIGH, BYPASS CHANGE
ST R9,MAX SAVE NEW VALUE
PUT OUTPUT,RECORD PUT RECORD TO OUTPUT
B READIN GOTO PROCESS NEXT INPUT
SPACE
***********************************************************************
* FIRST SEGMENT OF A RECORD DETECTED: SET SWITCH AND START BUFFER *
* CHAIN. *
***********************************************************************
SPACE
FIRSTSEG DS 0H
CLI 2(R2),1 TEST FOR FIRST SEGMENT
BE F1SEG YES, IT IS AN OK SEGMENT
BAL R10,ERRMSG PUT ERROR MESSAGE
PUT BADRECS,(R2) PUT TO BAD FILE
ADD1 BADSEG BUMP BAD REC COUNTER
B READIN GOTO NEXT RECORD
F1SEG DS 0H
CLC ANCHOR,=F'0' CHECK ANCHOR POINT
BNE ABEND100 NO, LOGIC ERROR 100
MVI SEGSW,2 SET SWITCH TO INDICATE EXPECTED NEXT
ADD1 TOTREC ADD ONE TO TOTAL RECORDS IN
TM OPTIONS,SMF IS SMF OPTION ACTIVE
BZ *+10 NO, BYPASS MOVE
MVC STYPE(1),5(R2) MOVE TYPE BYTE
BAL R10,STACK GOTO ADD SEGMENT TO BUFFER RTN
B READIN GOTO GET NEXT SEGMENT
SPACE
ABEND100 ABEND 100,DUMP ANCHOR SHOULD BE ZERO, IS NOT.
SPACE
***********************************************************************
* PROCESS SUBSEQUENT SEGMENTS: FOR CONTINUING SEGMENTS, ADD TO CHAIN. *
* FOR LAST SEGMENT, CONSTRUCT OUTPUT RECORD FOR OUTPUT DATASET. *
* *
***********************************************************************
SPACE
PROCSEG DS 0H
CLI 2(R2),0 TEST FOR UNSEGMENTED
BE P0SEG YES, GO TO PROCESS
CLI 2(R2),1 TEST FOR UNSEGMENTED
BE P1SEG YES, GO TO PROCESS
CLI 2(R2),2 TEST FOR LAST SEGMENT
BE P2SEG YES GO TO PROCESS
CLI 2(R2),3 TEST FOR CONT SEGMENT
BE P3SEG YES, GO TO PROCESS
SPACE
ABEND 200,DUMP SEGMENT DESC OF OTHER THAN 0,1,2,3
SPACE
***********************************************************************
* UNSEGMENTED RECORD ENCOUNTERED WHEN CONT SEGMENT EXPECTED. *
* FLUSH STACK TO BR FILE *
* RE-INITIALIZE TO NEW RECORD. *
***********************************************************************
SPACE
P0SEG DS 0H
SETCC 0 MFS CHANGED TO ZERO
* SETCC 4
BAL R10,ERRMSG PUT ERROR MESSAGE
BAL R10,FLUSH GO TO FLUSH STACK TO BADRECS
MVI SEGSW,1 RESET SWITCH
B PUTOUT GOTO PUT OUT RECORD
SPACE
***********************************************************************
* FIRST SEGMENT RECORD ENCOUNTERED WHEN CONT SEGMENT EXPECTED. *
* FLUSH STACK TO BAD RECORD FILE. *
* RE-INTIALIZE SEGMENT STACK. *
***********************************************************************
SPACE
P1SEG DS 0H
SETCC 0 MFS CHANGED TO ZERO
* SETCC 4
BAL R10,ERRMSG PUT OUT ERROR MESSAGE
BAL R10,FLUSH FLUSH OUT SEGMENTS TO BADRECS
B F1SEG GO TO PROCESS AS FIRST SEGMENT
SPACE
***********************************************************************
* END SEGMENT FOUND, CONTINUE SEGMENT EXPECTED. THIS IS NORMAL, *
* STACK THIS SEGMENT. THEN CALL UNSTACK ROUTINE TO CONSTRUCT *
* OUTPUT RECORD. *
***********************************************************************
SPACE
P2SEG DS 0H
BAL R10,STACK STACK RECORD
BAL R10,UNSTACK CONSTRUCT OUTPUT RECORD
MVI SEGSW,1 RESET SEGMENT SWITCH
B READIN GO TO NEXT RECORD
SPACE
***********************************************************************
* CONTINUE SEGMENT FOUND, CONTINUE SEGMENT EXPECTED, ADD TO STACK. *
* THEN READ ANOTHER SEGMENT. *
***********************************************************************
SPACE
P3SEG DS 0H
BAL R10,STACK STACK RECORD
B READIN GO AND READ ANOTHER
SPACE
***********************************************************************
* INPUT END OF FILE ROUTINE - CLOSE FILES, WRITE GOODBYE MESSAGE *
* AND RETURN. *
***********************************************************************
SPACE
EOFIN DS 0H
CLC ANCHOR,=F'0' TEST FOR STACK
BE CLOSES NO, CLOSE FILES
PUT SYSPRINT,=CL121'0*** EOF ON INPUT FILE, NOT AT END OF REX
CORD.***'
BAL R10,FLUSH FLUSH THE STACK
B CLOSES GOTO CLOSE FILES
ERRINPUT DS 0H
PUT SYSPRINT,=CL121'0*** MAX. ERRORS EXCEEDED ON INPUT FILE,X
PROGRAM TERMINATED.'
SETCC 16
CLC ANCHOR,=F'0' TEST FOR STACK
BE CLOSES NO, CLOSE FILES
BAL R10,FLUSH FLUSH THE STACK
CLOSES DS 0H
CLOSE (INPUT,,OUTPUT,,BADRECS)
L R11,TOTREC GET TOTAL COUNT
BCTR R11,0 SUBTRACT 'CAUSE I STARTED AT 1
CVD R11,DWORD CONVERT REC NUM
ED TRLNUM,DWORD+3 EDIT ANSWER
L R9,TOTRECB GET BAD RECORDS
CVD R9,DWORD CONVERT BAD REC COUN
ED TRLBNUM,DWORD+4 EDIT RESULT
L R9,SKIPRECS GET BAD RECORDS
CVD R9,DWORD CONVERT BAD REC COUN
ED TRLSKIP,DWORD+4 EDIT RESULT
PUT SYSPRINT,TRAILR1 PUT TRAILER
L R3,MIN GET REC MIN
CVD R3,DWORD CONVERT TO DEC
ED T2MIN,DWORD+5 EDIT RESULT
L R3,MAX GET REC MAX
CVD R3,DWORD CONVERT TO DEC
ED T2MAX,DWORD+5 EDIT RESULT
PUT SYSPRINT,TRAILR2 PUT TRAILER
CLOSE (SYSPRINT)
RETURN DS 0H
L R15,MAXCC GET RETURN CODE
L R13,4(,R13) RESTORE SAVE
RETURN (14,12),RC=(15)
TITLE 'SUBROUTINES CALLED BY MAIN LINE CODE'
***********************************************************************
* STACK: THIS ROUTINE GETMAINS AN AREA AND STACKS THE SEGMENT POINTED *
* TO IN R2 INTO THIS AREA AND CHAINS IT ONTO THE END OF THE EXISTING *
* CHAIN. *
***********************************************************************
SPACE
STACK DS 0H
LH R3,0(,R2) GET SEGMENT SIZE
LA R3,4(,R3) ADD 4 FOR CHAIN FIELD
GETMAIN R,LV=(R3),SP=100 GET STORAGE FOR BUFFER
LA R3,ANCHOR GET ANCHOR POINT
STLOOP DS 0H
L R4,0(,R3) GET CHAIN VALUE
LTR R4,R4 TEST FOR ZERO
BZ STEND YES, END OF CHAIN
LR R3,R4 MOVE VALUE TO POINTER
B STLOOP GO TO NEXT POINTER
STEND DS 0H
ST R1,0(,R3) STORE NEW BUFFER IN CHAIN
XC 0(4,R1),0(R1) CLEAR CHAIN PTR IN NEW BUFFER (EOL)
LA R0,4(,R1) SET R0 TO POINT TO 4 PAST START
LH R3,0(,R2) GET SEGMENT LENGTH AGAIN
LR R1,R3 PUT IN BOTH LENGTH REGS
MVCL R0,R2 MOVE SEGMENT
STRTRN BR R10 RETURN TO CALLER
SPACE
***********************************************************************
* FLUSH: THIS ROUTINE TAKES SEGMENTS FROM THE STACK AND PUTS THEM TO *
* THE BADRECS FILE, AND FREES THE STORAGE USED FOR BUFFERS. *
***********************************************************************
SPACE
FLUSH DS 0H
CLC ANCHOR,=F'0' TEST FOR ZERO POINTER
BE ABEND300 WHOOPS, THIS SHOULDNT HAPPEN
ADD1 TOTRECB ADD ONE TO BAD RECORD COUNT
L R4,ANCHOR GET SEGMENT
FLLOOP DS 0H
LA R0,4(,R4) POINT TO START OF SEGMENT
PUT BADRECS,(0) PUT TO BAD RECS FILE
ADD1 BADSEG ADD ONE TO BAD SEG COUNT
LH R3,4(,R4) GET SEG SIZE
LA R3,4(,R3) ADD 4 FOR CHAIN POINTER
CLC =F'0',0(R4) CHECK CHAIN FIELD
BE FLRTRN ZERO, GO TO END
L R4,0(,R4) GET NEXT POINTER
B FLLOOP NO, GO TO PROCESS NEXT
FLRTRN DS 0H
FREEMAIN R,SP=100 FREE WHOLE SUBPOOL
XC ANCHOR,ANCHOR CLEAR POINTER
BR R10
SPACE
ABEND300 ABEND 300,DUMP FLUSH WITHOUT A STACK
SPACE
***********************************************************************
* UNSTACK: THIS ROUTINE TAKES THE SEGMENTS STACKED IN BUFFERS, AND *
* PUTS THEM INTO A NEW OUTPUT RECORD. *
***********************************************************************
SPACE
UNSTACK DS 0H
CLC ANCHOR,=F'0' TEST FOR ZERO POINTER
BE ABEND400 WHOOPS, THIS SHOULDNT HAPPEN
XR R6,R6 CLEAR LENGTH REGISTER
LA R8,RECORD SET START POINTER
LA R4,4(,R8) LOAD START POINTER OF DATA
L R7,ANCHOR GET SEGMENT
UNLOOP DS 0H
LA R2,8(,R7) POINT TO START OF DATA (CHAIN+SDW)
LH R3,4(,R7) GET SEG SIZE
S R3,=F'4' SUB SDW LENGTH
AR R6,R3 BUMP TOTAL LENGTH
LR R5,R3 MOVE TO OTHER LENGTH REG
MVCL R4,R2 MOVE DATA
CLC =F'0',0(R7) CHECK FOR ZERO CHIAN
BE UNEND YES, GO TO ENDUP
L R7,0(,R7) GET CHAIN POINTER
B UNLOOP NO, GO TO NEXT
SPACE
UNEND DS 0H
XC 0(4,R8),0(R8) CLEAR NEW RDW
LA R6,4(,R6) ADD 4 TO DATA LENGTH
STH R6,0(R8) STORE LENGTH IN RDW
C R6,MIN TEST AGAINST MINIMUM
BNL *+8 NOT LOW, BYPASS CHANGE
ST R6,MIN SAVE NEW VALUE
C R6,MAX TEST AGAINST MAX
BNH *+8 NOT HIGH, BYPASS CHANGE
ST R6,MAX SAVE NEW VALUE
C R6,=F'32760' TEST AGAINST MAX REC
BNH *+10 NOT TOO HIGH, BYPASS DECREASE
MVC 0(2,R8),=H'32760' DECREASE TO MAX REC LENGTH
PUT OUTPUT,RECORD PUT REBUILD LOG REC TO OUTPUT
ADD1 TOTRECG ADD ONE TO OUTPUT REC COUNT
FREEMAIN R,SP=100 FREE ALL STORAGE
XC ANCHOR,ANCHOR CLEAR ANCHOR POINTER
UNRTRN BR R10 RETURN TO CALLER
SPACE
ABEND400 ABEND 400,DUMP UNSTACK WITHOUT A STACK
SPACE
***********************************************************************
* ERRMSG: THIS ROUTINE PUTS OUT A GENERALIZED ERROR MESSAGE TO THE *
* SYSPRINT DATASET. *
***********************************************************************
SPACE
ERRMSG DS 0H
L R11,TOTREC GET CURRENT COUNT
CVD R11,DWORD CONVERT CURR REC COUNT
MVC OHNUM(12),=X'402020206B2020206B202120'
ED OHNUM,DWORD+3 EDIT NUMBER
MVC OHEXPT,SEGSW MOVE SWITCH SET
OI OHEXPT,C'0' FORCE SIGN
MVC OHRECV,2(R2) MOVE SDW TYPE
OI OHRECV,C'0' FORCE SIGN
TM OPTIONS,SMF TEST FOR SMF OPTION
BZ ERRPUT NO, BYPASS CHANGE
XR R3,R3 CLEAR REG
IC R3,STYPE GET TYPE
CVD R3,DWORD CVT TO DEC
UNPK DWORD(3),DWORD+6(2)
MVC SMFTYPE(2),DWORD+1 MOVE TO MSG
OI SMFTYPE+1,C'0' FORCE SIGN
MVC OHSMF(12),SMFOVLY MOVE OVERLAY TO MSG
ERRPUT PUT SYSPRINT,OHOHMSG
ERRTRN BR R10 RETURN TO CALLER
TITLE 'SYNAD ROUTINES'
***********************************************************************
* THIS ROUTINE GETS CONTROL AS A SYNAD EXIT FOR THE INPUT DCB. *
* IT USES THE SYNADAF SERVICE TO FORMAT AND DISPLAY AN ERROR MESSAGE *
***********************************************************************
DROP R12
USING INERROR,R15 ADDRESSABILITY
INERROR DS 0H
STM R13,R15,SYNADSAV
SYNADAF ACSMETH=QSAM ISSUE SYNADAF MACRO
STM R14,R12,12(R13) SAVE REGS
BALR R12,0 GET A NEW SAVE AREA
DROP R15
USING *,R12 USE IT
LA R2,7(,R1) BUMP PAST BDW+RDW-1
MVC 0(30,R2),=CL30'0I/O ERROR ON DDNAME=INPUT'
* PUT SYSPRINT,(2) PUT MESSAGE
ADD1 SKIPRECS COUNT IT
SETCC 8
LM R14,R12,12(13) RESTORE REGS
DROP R12
USING INERROR,R15 ADDRESSABILITY
SYNADRLS , RELEASE BUFFER ETC
LM R13,R15,SYNADSAV
BR R14 RETURN TO SYSTEM
DROP R15
SPACE 2
***********************************************************************
* THIS ROUTINE GETS CONTROL AS A SYNAD EXIT FOR THE OUTPUT DCB. *
* IT USES THE SYNADAF SERVICE TO FORMAT AND DISPLAY AN ERROR MESSAGE *
***********************************************************************
USING OUTERROR,R15
OUTERROR DS 0H
STM R13,R15,SYNADSAV
SYNADAF ACSMETH=QSAM ISSUE SYNADAF MACRO
STM R14,R12,12(R13) SAVE REGS
BALR R12,0 GET A NEW SAVE AREA
DROP R15
USING *,R12 USE IT
* IGNORE RETURN CODES AND PRINT MESSAGE
LA R2,7(,R1) BUMP PAST BDW+RDW-1
MVC 0(30,R2),=CL30'0I/O ERROR ON DDNAME=OUTPUT'
PUT SYSPRINT,(2) PUT MESSAGE
SETCC 16
LM R14,R12,12(13) RESTORE REGS
DROP R12
USING OUTERROR,R15 ADDRESSABILITY
SYNADRLS , RELEASE BUFFER ETC
LM R13,R15,SYNADSAV
BR R14 RETURN TO SYSTEM
DROP R15
USING VBSFIX,R12 SET BASE ADDRESSING
TITLE 'DCBEXIT ROUTINE(S)'
***********************************************************************
* DCB EXIT ROUTINE TO FILL IN BLOCKSIZE FROM LRECL IF BLKSIZE IS NOT *
* OTHERWISE SUPPLIED. *
***********************************************************************
SPACE
DCBEXIT1 DS 0H
USING IHADCB,R1
CLC DCBBLKSI(2),=H'0' TEST FOR BLKSIZE FILLED IN
BNER R14 YES, RETURN TO CALLER
MVC DCBBLKSI(2),DCBLRECL NO, MOVE IN LRECL
BR R14 RETURN TO CALLER
SPACE 2
TITLE 'DCB''S AND CONSTANTS AREA'
PUSH PRINT
PRINT NOGEN
INPUT DCB DSORG=PS,MACRF=(GL),DDNAME=INPUT,RECFM=VBS,LRECL=X, X
EODAD=EOFIN,EROPT=SKP
SPACE 2
OUTPUT DCB DSORG=PS,MACRF=PM,RECFM=VBS,DDNAME=OUTPUT, X
SYNAD=OUTERROR
SPACE 2
BADRECS DCB DSORG=PS,MACRF=PM,DDNAME=BADRECS
SPACE 2
SYSPRINT DCB DSORG=PS,MACRF=PM,RECFM=FBA,LRECL=121,DDNAME=SYSPRINT, X
EXLST=EXLST1
POP PRINT
SPACE 3
HEADER1 DC CL121'1 **** VBS FIXUP PROGRAM - V1M6 ***'
HEADER2 DC CL121'0'
TRAILR1 DS 0CL121
DC C'0*** END OF JOB,'
TRLNUM DC X'402020206B2020206B202120'
DC C' RECORDS PROCESSED,'
TRLBNUM DC X'40206B2020206B202120'
DC C' RECORDS IN ERROR,'
TRLSKIP DC X'40206B2020206B202120'
DC C' RECORDS SKIPPED.'
DC (TRAILR1+121-*)C' '
TRAILR2 DS 0CL121
DC C' *** MINIMUM SIZE='
T2MIN DC X'4020206B202120'
DC C', MAXIMUM SIZE='
T2MAX DC X'4020206B202120'
DC C'.'
DC (TRAILR2+121-*)C' '
OHOHMSG DS 0CL121
DC C'0*** ERROR RECORD #'
OHNUM DC X'402020206B2020206B202120'
DC C', EXPECTED: '
OHEXPT DC C' '
DC C', RECEIVED: '
OHRECV DC C' '
DC C'. '
OHSMF DC CL12'.'
DC (OHOHMSG+121-*)C' '
EXLST1 DS 0F
DC X'85'
DC AL3(DCBEXIT1)
SMFOVLY DS 0CL12
DC C'(SMFTYPE='
SMFTYPE DC C' '
DC C')'
LTORG
TITLE 'WORKING STORAGE SECTION'
SAVEAREA DS 18F REGULAR SAVE AREA
SYNADSAV DS 4F SYNAD SAVE AREA
ANCHOR DC F'0'
MIN DC F'999999'
MAX DC F'0'
TOTREC DC F'1' COUNT OF TOTAL SEGMENTS READ
TOTSEG DC F'0' COUNT OF TOTAL SEGMENTS READ
TOTRECG DC F'0' TOTAL GOOD RECORDS
TOTRECB DC F'0' TOTAL BAD RECORDS
BADSEG DC F'0' NUMBER OF BAD SEGMENTS
SKIPRECS DC F'0' NUMBER OF SKIPPED (I/O ERR) RECS
ERRMAX DC F'6' MAX NUMBER OF I/O ERRORS ALLOWED
MAXCC DC F'0' RETURN CODE
DWORD DS D
SEGSW DC X'00'
OPTIONS DC X'00'
SMF EQU 128
STYPE DC C' '
RECORD DS 32767C LOGICAL RECORD BUILD AREA
PRINT NOGEN
DCBD DSORG=QS
END VBSFIX
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to lists...@listserv.ua.edu with the message: INFO IBM-MAIN
