/*%NOCOMMENT REXX RECORD CALCULATOR ROUTINE

*/
/* USE THIS EXEC TO CALCULATE THE LENGTH OF A COBOL RECORD
*/
/* LAYOUT OR WORK AREA. ALL OR PART OF THE AREA MAY BE
*/
/* CALCULATED. TO USE THIS EXEC TYPE IN 'CC' IN THE PREFIX
*/
/* ON THE COBOL LINE YOU WANT THE CALCULATION TO START AND
*/
/* 'CC' IN THE PREFIX ON THE LINE YOU WANT THE CALCULATION
*/
/* TO END. THEN ISSUE 'RLCL' ON THE COMMAND LINE AND THE
*/
/* LENGTH (OR AN ERROR MESSAGE) WILL BE RETURNED. THIS EXEC */
/* TAKES COMP-3 INTO ACCOUNT AS WELL AS OCCURS. IT SEEMS TO */
/* WORK PRETTY DANG GOOD. *NOTE - THE LEVEL NBR OF THE
*/
/* STARTING MUST NOT BE A HIGHER LEVEL NBR THEN THE END LINE */
/* EXAMPLE(START LVL 10 AND END LVL 05 IS INVALID)
*/
/* THIS EXEC IS GOOD FOR FINDING OUT WHAT POSITION A CERTAIN */
/* FIELD STARTS IN. SO YOU DONT HAVE TO USE YOUR ABACUS !
*/
/*
*/
/* IF ALSO TAKES STRAIGHT COMP (BINARY) FIELDS INTO ACCOUNT */
/*
*/
/* IF THERE ARE ERRORS IN YOUR DEFINITION THEN THE RESULTS
*/
/* OF THE LENGTH CALC MAY BE INACCURATE.
*/
/*
*/
/**************************************************************/
/* WRITTEN BY MARK HARRINGTON ON 07/01/91 FOR CMS
*/
/* MODIFIED BY MARK HARRINGTON ON 10/18/95 FOR MVS (A326)
*/
/* YALL HAVE A REAL NICE DAY !
*/
/**************************************************************/
/*
*/
/********THIS IS NOW FIXED !!!!!! M.H., 05/02/97***************/
/* IF THE LENGTH OF THE SUBJECT OF A REDEFINES CLAUSE IS LESS */
/* THEN THE OBJECT OF THE REDEFINES THIS EXEC WILL USE THE
*/
/* LENGTH OF THE SUBJECT IN THE CALCULATION (SINCE THE REC- */
/* ORDS ARE BEING READ LIFO HE USES THE FIRST ONE HE COMES TO */
/* WHICH IS ALWAYS THE SUBJECT) SO BE WARY.
*/
/**************************************************************/
/* MODIFIED ON 06-05-96 BY M.H. I TURBO CHARGED THE
*/
/* WAY IT TOTALS UP A FIELD LENGTH
*/
/* REFERENCES : THE SECTION ENTITLED-> PICTURE:
*/
/**************************************************************/
/* MODIFIED BY MARK HARRINGTON ON 11/20/96 SWSCI4
*/
/* FOUND A SMALL BUG. IF THE LITTERAL IN A VALUE CLAUSE
*/
/* CONTAINED A TWO DIGIT NUMBER > 0 AND LT 99 THE PROGRAM
*/
/* ASSUMED THAT IT WAS A COBOL LEVEL NBR AND WOULD ISSUE THE */
/* 'PERIOD MISSING' ERROR MESSAGE, I REMOVED THE LITTERAL
*/
/* IN THE COBOL LINE
*/
/* REF: LITCHK:
*/
/**************************************************************/
/* MODIFIED BY MARK HARRINGTON ON 03/21/97 SWSCI4
*/
/* FOUND ANOTHER BUG (ACTUALLY JOHNNY CHOE FOUND IT).
*/
/* IF THE LAST LINE OF THE CALCULATION WAS MISSING A PERIOD */
/* HE WOULD NEVER INCLUDE THAT LINE IN THE CALCULATION NOR
*/
/* WOULD HE ISSUE AN ERROR MESSAGE. I ADDED A SW TO TELL HIM */
/* THAT THE LAST LINE DID OR DIDN'T HAVE A PERIOD.
*/
/* REF: JUST FIND 03-21-97
*/
/**************************************************************/
/* MODIFIED BY MARK HARRINGTON ON 05/02/97 SWSCI4
*/
/* (*(*&(*&% OH BOY OH BOY OH BOY
*/
/* IF HAVE FIGURED OUT HOW TO ELIMINATE THE REDEFINES PROBLEM !!!*/
/* NO LONGER WILL THIS EXEC GIVE A SHORT CALCULATION IF THE */
/* SUBJECT OF THE REDEFINES IS SHORTER THAN THE OBJECT.
*/
/* OH YEAH OH YEAH OH YEAH
*/
/* REF: JUST FIND 05-02-97
*/

/**************************************************************/
/* MODIFIED BY MARK HARRINGTON ON 05/22/97 SWSCI4
*/
/* (*(*&(*&% OH BOY OH BOY OH BOY
*/
/* WELL THERE WAS ONE MORE TWEAK FOR THE REDEFINES
*/
/* NOW I CALCULATE REDFINES IF THE REDEFINE LEVEL IS A LOWER */
/* LEVEL THEN THE PREVIOUS REDFINES OTHERWISE I DON'T
*/
/* CALCULTE
*/
/* REF: JUST FIND 05-22-97
*/
/**************************************************************/
/* MODIFIED BY MARK HARRINGTON ON 11/20/01 LAMWH
*/
/* AND EMBEDED PERIOD IN A VALUE LITERAL CERTAINLY WAS A
*/
/* PROBLEM SINCE IT KEYS ON A PERIOD TO KNOW IF IT IS THE
*/
/* END OPF A COBOL STATEMENT I THINK I HAVE FIXED THIS
*/
/* REF: JUST FIND 11-20-01
*/
/**************************************************************/
/* THIS EXEC W-I-L-L NOT GIVE YOU A SHORT CALULATION AS FAR */
/* AS THE LOCATION OF A FIELD BUT IT MAY GIVE YOU A SHORT
*/
/* CALCULATION IF THE WHOLE RECORD IS CALCULATED IF THE ENDING*/
/* CC IS IN A REDEINFES THAT IS SHORTER THEN THE OBJECT
*/
/* BUT THE REST HAS BEEN FIXED
*/
/**************************************************************/
/* DO NOT START TRACING BEFORE THE FIRST DO LOOP OR YOU'LL
/*
B-E
S-O-R-R-Y !
(SEE BELOW)

*/
*/

ADDRESS ISPEXEC
'ISREDIT MACRO NOPROCESS'
'ISREDIT PROCESS RANGE C'
'ISREDIT (FIRST) = LINENUM .ZFRANGE'
'ISREDIT (LAST) = LINENUM .ZLRANGE'
'ISREDIT (NUM1,NUM2) = NUMBER'
PDLINE = ' '
PICLEN = 0
/******************LOOP 60 TIMES !!!!*********************/
DO X = 1 TO 60
LEVEL.X = 0
END
/********************************************************/
/*
YOU CAN START TRACE FROM HERE AND FORWARD
*/
TRACE OFF
/********************************************************/
DTO
= ''
CURRLVL = ''
PREVLVL = ''
LOWLVL = ''
HILVL
= ''
REDEFINE = ''
PLINE
= ''
REFLVL = ''
/* 05-22-97 */
FRSTRC = ''
/* 05-22-97 */
DO FOREVER
/*************************************************************/
/* READ A LINE FROM THE VIRTUAL FILE (SCREEN)
*/
/*************************************************************/
IF FIRST > LAST THEN DO
QUEUE ''
LEAVE
END
'ISREDIT (DATA) = LINE' FIRST

IF RC <> 0 THEN DO
QUEUE ''
LEAVE
END
IF DATA = '' THEN DO
FIRST = FIRST + 1
ITERATE
END
COB1 = POS('NOCOB',NUM2)
COMM = SUBSTR(DATA,7,1)
IF NUM1 = 'ON' & COB1 = 0 THEN COMM = SUBSTR(DATA,1,1)
IF COMM <> ' ' & COMM <> '-' THEN DO
FIRST= FIRST + 1
ITERATE
END
DATA = SUBSTR(DATA,1,72)
IF NUM1 = 'ON' & COB1 = 0 THEN DATA = SUBSTR(DATA,2,67)
ELSE DATA = SUBSTR(DATA,7,67)
IF COMM = '-' THEN DO
DATA = STRIP(DATA,'L','-')
DATA = ' ' || DATA
END
IF DATA = 'EJECT' | DATA = 'SKIP1' | DATA = 'SKIP2' | DATA = 'SKIP3' THEN DO
FIRST = FIRST + 1
ITERATE
END
IF PLINE = '' THEN ELINE = FIRST
PLINE = PLINE || DATA
PLINE = STRIP(PLINE,'T')
/********************************************************************/
/* PUT THE WHOLE LINE TOGETHER AS ONE (CONCATINATE LINES UNTIL '.') */
/* WE ARE GONNA STACK THEM LIFO
*/
/********************************************************************/
/* MOD: 11-20-01 */
PLENGTH = LENGTH(PLINE)
PCK = POS('.',PLINE,PLENGTH)
PLINE = TRANSLATE(PLINE,' ','.')
/* END MOD 11-20-01 */
IF PCK = 0 THEN DO
FIRST = FIRST + 1
PDLINE = 'X'
ITERATE
END
PLINE = SUBSTR(PLINE,2,PCK)
PLINE = STRIP(PLINE,'L')
PLINE = STRIP(PLINE,'T')
LCHK = SUBSTR(PLINE,1,2)
IF LCHK = '88' THEN DO
PLINE = ''
FIRST = FIRST + 1
ITERATE
END
IF LCHK = '77' THEN DO
ZEDLMSG = '77 LEVELS ARE NOT NOT ALLOWED,SORRY'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT

END
PLINE = ELINE PLINE || '.' /* MOD 11-20-01 */
/* PUT BACK THE ENDINF PERIOD NOW THAT */
/* YOU KNOW THERE ARE KNOW OTHER PERIODS*/
CALL LITCHK
PUSH PLINE
PDLINE = ' '
PLINE = ''
FIRST = FIRST + 1
END
/********************03-21-97**CHECK*FOR*LAST*LINE*HAVING*PERIOD**/
IF PDLINE = 'X' THEN DO
ERRLINE = ELINE
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
/*************END*OF*MOD*032197***************************/
TRACE OFF
DO FOREVER
/*********************************************************/
/*
GET A LINE OFF THE STACK IN 3 WORDS
*/
/*
ELINE = THE ERROR LINE NUMBER (IF NEEDED)
*/
/*
WRD = THE LEVEL NUMBER (THE FIRST TIME THROUGH) */
/*
REST = THE REST OF THE LINE
*/
/*
WE WILL CHEW THE REST OFF ONE WORD AT A TIME LATER */
/*
REMEMBER THE LAST LINE COMES FIRST
*/
/*********************************************************/
WRD
= ''
CURRLVL = ''
PIC
= ''
DTNAME = ''
PULL ELINE WRD REST
IF ELINE = '' THEN LEAVE
ERRLINE = ELINE
REST
= STRIP(REST,'T')
/* STIP OUT TRAILING BLANKS */
CHKP = POS('.',REST)
IF CHKP = 0 THEN DO
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
REST
= STRIP(REST,'T','.') /* WE DON'T NEED THE PERIOD ANYMORE*/
OCCURS = 1
CALL GET_COBOL_WORDS
/* START CHEWING */
PLINE
= ''
END
/*********************************************************/
/*
WELL WE ARE ALL DONE WITH THE CACULATION
*/
/*
SO, EITHER RETURN THE LENGTH OR AN ERROR MESSGAE */
/*********************************************************/
IF PREVLVL > LOWLVL THEN DO
CALL DRPBF
ZEDLMSG = 'LINE 'ERRLINE 'LOWER LEVEL FOUND BEFORE HIGHER ONE'
'ISPEXEC SETMSG MSG(ISRZ000)'

EXIT
END
DO X = HILVL TO LOWLVL BY -1
IF X = LOWLVL
THEN LEAVE
IF LEVEL.X = 0 THEN ITERATE
LN = LENGTH(X)
XD = X
IF LN = 1 THEN XD = '0' || X
ZEDLMSG = 'LINE 'ERRLINE 'LOWER LEVEL FOUND BEFORE HIGHER ONE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
IF REDEFINE <> '' THEN DO
ZEDLMSG = 'LENGTH IS ' LEVEL.PREVLVL 'WARN REDEFINES UNRESOLVED'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
IF DTO = 'TO' THEN DO
ZEDLMSG = 'LENGTH IS ' LEVEL.PREVLVL 'WARN DEPENDING ON IS UNRESOLVED'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
ZEDLMSG = 'YOUR DATA DEFINITION LENGTH IS ' LEVEL.PREVLVL
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
/***************************************************************/
/******************END OF EXEC RLCL*****************************/
/***************************************************************/
/*
**************************************************
*/
/*
************************************
*/
/*
************************
*/
/*
************
*/
/*
*****
*/
/* IT STOPS HERE
*
SUB ROUTINES FOLLOW
*/
/***************************************************************/
GET_COBOL_WORDS:
/*****************************************************************/
/* GET NEEDED COBOL CLAUSES AND VALUES FROM THE REST OF THE LINE */
/* ONE WORD AT A TIME
*/
/*****************************************************************/
DO FOREVER
IF WRD = '' THEN DO
/* NO MORE WORDS ? THEN CALCULATE */
CALL CALCIT
LEAVE
END
IF WRD = 'COMP-3' THEN COMP3 = 'X'
IF WRD = 'COMP' THEN COMP = 'X'
CHK = DATATYPE(WRD)
IF (WRD >= '01' & WRD < '99') & CHK = 'NUM' THEN DO
IF CURRLVL <> '' THEN DO
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END

CURRLVL = WRD
IF FRSTRC = '' THEN DO /* 05-22-97 */
REFLVL = WRD
FRSTRC = 'X'
END
/* END 05-22-97 */
PUSH REST
PULL DTNAME REST
IF REDEFINE <> '' THEN DO
IF REDEFINE = DTNAME THEN DO
RED = POS('REDEFINES ',REST)
IF RED <> 0 THEN DO
REST = SUBSTR(REST,RED,60)
PUSH REST
PULL . REDEFINE
LEAVE
END
ELSE DO
REDEFINE = ''
LEAVE
END
END
ELSE DO
LEAVE
END
END
END
IF WRD = 'VALUE' | WRD = 'VALUES' THEN DO
PUSH REST
PULL VALUE REST
IF VALUE = '' THEN DO
ZEDLMSG = 'LINE 'ERRLINE 'VALUE CLAUSE HAS NO VALUE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
END
IF WRD = 'OCCURS' THEN DO
PUSH REST
PULL OCCURS REST
DEP = POS(' DEPENDING ',REST)
IF DEP <> 0 THEN DO
PUSH REST
PULL DTO REST
PUSH REST
PULL OCCURS REST
END
END
IF WRD = 'PIC' THEN DO
IF PIC <> '' THEN DO
ZEDLMSG = 'LINE 'ERRLINE 'PIC HAS BEEN DEFINED TWICE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
PUSH REST
PULL PIC REST
END
IF WRD = 'PICTURE' THEN DO
PUSH REST
PULL PIC REST

IF PIC = 'IS' THEN DO

PUSH REST
PULL PIC REST
END
END
IF WRD = 'REDEFINES' THEN DO
PUSH REST
PULL REDEFINE REST
END
PUSH REST
PULL WRD REST
END
RETURN
CALCIT:
/**************************************************************/
/*
CALCULATE THE PIC LENGTH AND/OR GROUP FIELD LENGTH */
/**************************************************************/
CURRLVL = STRIP(CURRLVL,'L','0')
IF PREVLVL = '' THEN DO
PREVLVL = CURRLVL
LOWLVL = CURRLVL
HILVL = CURRLVL
END
IF CURRLVL >= PREVLVL & PIC = '' THEN DO
ZEDLMSG = 'AROUND LINE 'ERRLINE 'ELEMENTRY WITH NO PICTURE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
IF CURRLVL < PREVLVL & PIC <> '' THEN DO
ZEDLMSG = 'AROUND LINE 'ERRLINE 'GROUP ITEM HAS A PICTURE,BONEHEAD'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
/*****05-02-97**FIX*REDEFINE*PROBLEM*******/
IF (CURRLVL < PREVLVL) THEN DO
IF REDEFINE <> '' & CURRLVL >= REFLVL THEN DO /* 05-22-97 */
LEVEL.PREVLVL = 0
PREVLVL = CURRLVL
REDEFINE = ''
END
/******************************************/
ELSE DO
CALL GROUP_COMP_3
CALL GROUP_COMP_BIN
LEVEL.CURRLVL = LEVEL.CURRLVL + (LEVEL.PREVLVL * OCCURS)
LEVEL.PREVLVL = 0
PREVLVL = CURRLVL
IF CURRLVL < LOWLVL THEN LOWLVL = CURRLVL
/* 05-22-97 */
IF REDEFINE <> '' & CURRLVL < REFLVL THEN REFLVL = CURRLVL
END
RETURN
END
CALL PICTURE
/****************05-02-97***FIX*REDEFINE***PROB**/
IF REDEFINE = '' THEN PREVLVL = CURRLVL
REDEFINE = ''

/************************************************/
IF CURRLVL > HILVL THEN HILVL = CURRLVL
RETURN
PICTURE:
/**************************************************************/
/* FIND THE LENGTH OF THE ACTUAL PICTURE CLAUSE
*/
/**************************************************************/
PIC = STRIP(PIC,'L','S')
PICLEN = 0
PIC = TRANSLATE(PIC,' ','V')
IF POS(')',PIC) = 0 THEN PICLEN = LENGTH(WORD(PIC,1))+LENGTH(WORD(PIC,2))
ELSE DO
PIC = TRANSLATE(PIC,' ',')')
DO WRDNBR = 1 TO WORDS(PIC)
SPEC = WORD(PIC,WRDNBR)
IF POS('(',SPEC) = 0 THEN PICLEN = PICLEN + LENGTH(SPEC)
ELSE DO
SPEC = TRANSLATE(SPEC,' ','(')
PICLEN = PICLEN + LENGTH(WORD(SPEC,1)) + WORD(SPEC,2) - 1
END
END
END
CALL FIELD_COMP_3
CALL FIELD_COMP_BIN
/******************05-02-97***FIX*REDEFINE*PROBLEM*******/
IF REDEFINE = '' THEN DO
LEVEL.CURRLVL = LEVEL.CURRLVL + (PICLEN * OCCURS)
END
/******************************************/
RETURN
FIELD_COMP_3:
/******************************************************/
/*
PACK THE FIELD LENGTH IF NEEDED
*/
/******************************************************/
IF COMP3 <> 'X' THEN RETURN
PICLEN = (PICLEN % 2 ) + 1
COMP3 = ''
RETURN
GROUP_COMP_3:
/******************************************************/
/*
PACK THE GROUP FIELD LENGTH IF NEEDED */
/******************************************************/
IF COMP3 <> 'X' THEN RETURN
LEVEL.PREVLVL = (LEVEL.PREVLVL % 2) + 1
COMP3 = ''
RETURN
FIELD_COMP_BIN:
/******************************************************/
/*
DETERMINE THE BINARY FIELD LENGTH IF NEEDED
*/
/******************************************************/
IF COMP <> 'X' THEN RETURN
IF PICLEN > = 1 & PICLEN < = 4 THEN PICLEN = 2
IF PICLEN > = 5 & PICLEN < = 9 THEN PICLEN = 4
IF PICLEN > = 10 & PICLEN < = 18 THEN PICLEN = 8
IF PICLEN > = 19 & PICLEN < = 20 THEN PICLEN = 2

IF PICLEN > 20 THEN DO

CALL DRPBF
ZEDLMSG = 'COMP FIELD EXCEEDS 20 CHARACTERS'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
COMP = ''
RETURN
GROUP_COMP_BIN:
/************************************************************/
/*
DETERMINE THE BINARY GROUP FIELD LENGTH IF NEEDED
*/
/************************************************************/
IF COMP <> 'X' THEN RETURN
IF LEVEL.PREVLVL > = 1 & LEVEL.PREVLVL < = 4 THEN LEVEL.PREVLVL
IF LEVEL.PREVLVL > = 5 & LEVEL.PREVLVL < = 9 THEN LEVEL.PREVLVL
IF LEVEL.PREVLVL > = 10 & LEVEL.PREVLVL < = 18 THEN LEVEL.PREVLVL
IF LEVEL.PREVLVL > = 19 & LEVEL.PREVLVL < = 20 THEN LEVEL.PREVLVL
IF LEVEL.PREVLVL > 20 THEN DO
CALL DRPBF
ZEDLMSG = 'COMP FIELD EXCEEDS 20 CHARACTERS'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
COMP = ''
RETURN
LITCHK:
LITCHK = POS("'",PLINE)
IF LITCHK = 0 THEN RETURN
LITCHK = LITCHK + 1
LITCHK2 = POS("'",PLINE,LITCHK)
LITCHK = LITCHK - 2
IF LITCHK2 = 0 THEN RETURN
LITLEN = LITCHK2 + 3
PLINEA = SUBSTR(PLINE,1,LITCHK)
/*********DONT DECOMMENT THIS********************/
/* LITCHK2 = LITCHK2 + 1
*/
/*********OR YOU'LL BE SORRY*********************/
/* I AM LEAVING ONE OF THE ' AS A VALUE OR YOULL*/
/* GET A 'VALUE CLAUSE WITH NO VALUE' ERROR MSG */
/************************************************/
PLINEB = SUBSTR(PLINE,LITCHK2)
PLINE = PLINEA PLINEB
RETURN
DRPBF:
/************************************************************/
/*
CLEAR THE STACK OUT
*/
/************************************************************/
DO QUEUED()
PULL DUMMY
END
RETURN

=
=
=
=

2
4
8
2