/****************************************************************/
/* */
/* NAME: R2COB5 */
/* TITLE: PROGRAM 'R2COB5', A PART OF 'COB2SAS, RELEASE 2' */
/* PRODUCT: SAS */
/* SYSTEM: CMS MVS VSE VMS */
/* DATA: COB2SAS, RELEASE 2 */
/* */
/* AUTHOR: TOM ZACK */
/* SUPPORT: TOM ZACK UPDATE: 22JUL90 */
/* REF: COB2SAS, RELEASE 2 DOCUMENTATION */
/* MISC: WHEN USING, INVOKE SAS WITH THE SYSTEM OPTIONS: */
/* 'DQUOTE MACRO' */
/* */
/****************************************************************/
/* THE CHARCODE OPTION IS SET SO THAT THE STRINGS, '?/?/', */
/* '?(', AND '?)' ARE PROPERLY INTERPRETED. */
OPTIONS CHARCODE;
/* */
/* EXPAND OCCURS VARIABLES. */
/* */
DATA DICTNRY;
KEEP FILENAME LEVEL NST_DPTH DATANAME NEWNAME USAGE PICTURE
INFMT OCR_BASE ITM_DISP ATBYTE BYTES OCR_VAL RDF_NAME;
/* */
/* THE CHARCODE OPTION IS SET SO THAT THE STRINGS, '?/?/', */
/* '?(', AND '?)' ARE PROPERLY INTERPRETED. */
/* */
/* EXPAND MODE */
RETAIN XPNDMODE 'NOT EXPANDING';
/* OCCURS-STACK INDEX */
/* OCCURS-STACK LEVEL, OCCURS-STACK NUMERIC LEVEL */
/* OCCURS-STACK ATBYTE, OCCURS-STACK BYTES */
/* OCCURS-STACK OCCURS VALUE */
RETAIN OK_NDX 0;
RETAIN OK_LVL1-OK_LVL49 0;
RETAIN OK_BSE1-OK_BSE49 0;
RETAIN OK_BYT1-OK_BYT49 0;
RETAIN OK_USG1-OK_USG49 ' ';
RETAIN OK_OCR1-OK_OCR49 0;
ARRAY OK_LVL?(49?) OK_LVL1-OK_LVL49;
ARRAY OK_BSE?(49?) OK_BSE1-OK_BSE49;
ARRAY OK_BYT?(49?) OK_BYT1-OK_BYT49;
ARRAY OK_USG?(49?) $8 OK_USG1-OK_USG49;
ARRAY OK_OCR?(49?) OK_OCR1-OK_OCR49;
/* OCCURS STRING, TEMP OCCURS, TEMP NAME */
LENGTH OCR_STR $12 TEMP_OCR 8 TEMPNAME $8;
SET DICTNRY;
LVL = INPUT(LEVEL,12.);
IF LVL = 1 THEN DO;
OK_NDX = 0;
XPNDMODE = 'NOT EXPANDING';
END; /* IF LVL = 1 */
IF OK_NDX = 0 THEN DO;
IF OCR_VAL NE ' ' THEN DO;
/* PUSH THE FIRST ITEM ONTO THE STACK. */
OK_NDX = 1;
OK_LVL?(OK_NDX?) = LVL;
OK_BSE?(OK_NDX?) = OCR_BASE;
OK_BYT?(OK_NDX?) = BYTES;
OK_USG?(OK_NDX?) = USAGE;
OK_OCR?(OK_NDX?) = INPUT(OCR_VAL,12.);
XPNDMODE = 'EXPANDING';
END; /* IF OCR_VAL NE ' ' */
END; /* IF OK_NDX = 0 */
ELSE IF LVL LE OK_LVL?(OK_NDX?) THEN DO;
DONE = 0;
DO WHILE(NOT DONE);
/* POP ITEMS OFF OF THE STACK. */
OK_NDX = OK_NDX - 1;
IF OK_NDX = 0 THEN DO;
DONE = 1;
XPNDMODE = 'NOT EXPANDING';
END; /* IF OK_NDX = 0 */
ELSE IF LVL GT OK_LVL?(OK_NDX?) THEN
DONE = 1;
END; /* DO WHILE */
IF OK_NDX = 0 THEN DO;
IF OCR_VAL NE ' ' THEN DO;
/* PUSH THE FIRST ITEM ONTO THE STACK. */
OK_NDX = 1;
OK_LVL?(OK_NDX?) = LVL;
OK_BSE?(OK_NDX?) = OCR_BASE;
OK_BYT?(OK_NDX?) = BYTES;
OK_USG?(OK_NDX?) = USAGE;
OK_OCR?(OK_NDX?) = INPUT(OCR_VAL,12.);
XPNDMODE = 'EXPANDING';
END; /* IF OCR_VAL NE ' ' */
END; /* IF OK_NDX = 0 */
END; /* ELSE IF LVL LE OK_LVL?(OK_NDX?) */
ELSE IF LVL GT OK_LVL?(OK_NDX?) THEN DO;
IF OCR_VAL NE ' ' THEN DO;
/* PUSH AN ITEM ONTO THE STACK. */
OK_NDX + 1;
OK_LVL?(OK_NDX?) = LVL;
OK_BSE?(OK_NDX?) = OCR_BASE;
OK_BYT?(OK_NDX?) = BYTES;
OK_USG?(OK_NDX?) = USAGE;
OK_OCR?(OK_NDX?) = INPUT(OCR_VAL,12.);
END; /* IF OCR_VAL NE ' ' */
END; /* ELSE IF LVL GT OK_LVL?(OK_NDX?) */
SELECT (XPNDMODE);
WHEN ('EXPANDING') DO;
IF OK_NDX EQ 1 THEN DO;
TEMPBASE = OK_BSE?(OK_NDX?);
OCR_LEN = OK_BYT?(OK_NDX?)/OK_OCR?(OK_NDX?);
IF OCR_VAL NE ' ' THEN
BYTES = OCR_LEN;
TEMPNAME = TRIM(LEFT(NEWNAME));
TEMP_OCR = OK_OCR?(OK_NDX?);
IF TEMP_OCR LE 999 THEN DO;
DO I = 1 TO OK_OCR?(OK_NDX?);
ATBYTE = TEMPBASE + ITM_DISP;
OCR_VAL = '1';
LINK FIXNAME;
OUTPUT;
TEMPBASE = TEMPBASE + OCR_LEN;
END; /* DO I = 1 TO OK_OCR?(OK_NDX?) */
END; /* IF TEMP_OCR LE 999 */
ELSE IF TEMP_OCR GT 999 THEN DO;
PUT 'ERROR: TABLES WITH MORE THAN 999 OCCURRENCES ' @;
PUT 'ARE NOT EXPANDED.';
PUT @8 NST_DPTH= DATANAME= ATBYTE=;
PUT ;
OUTPUT;
END; /* ELSE IF TEMP_OCR GT 999 */
END; /* IF OK_NDX EQ 1 */
ELSE DO;
PUT 'ERROR: MULTI-DIMENSIONAL TABLES ARE NOT EXPANDED.';
PUT @8 NST_DPTH= DATANAME= ATBYTE=;
PUT ;
OUTPUT;
END; /* ELSE DO */
END; /* WHEN ('EXPANDING') */
WHEN ('NOT EXPANDING') DO;
OUTPUT;
END; /* WHEN ('NOT EXPANDING') */
END; /* SELECT (XPNDMODE) */
FIXNAME:
/* */
/* FIXNAME: */
/* FIX NAME */
/* */
/* PURPOSE: */
/* APPEND AN ORDINAL NUMBER TO THE VALUE IN NEWNAME. */
/* */
IF NEWNAME = 'FILLER' THEN DO;
/* NOTHING */
END; /* IF NEWNAME = 'FILLER' */
ELSE IF TEMP_OCR LE 999 THEN DO;
OCR_STR = PUT(I,12.);
OCR_STR = TRIM(LEFT(OCR_STR));
DO J = 1 TO (3 - LENGTH(OCR_STR));
OCR_STR = '0'?/?/TRIM(LEFT(OCR_STR));
END; /* DO J */
OCR_STR = 'X'?/?/TRIM(LEFT(OCR_STR));
IF LENGTH(TEMPNAME) GT 3 THEN DO;
NEWNAME = SUBSTR(TEMPNAME,LENGTH(TEMPNAME) - 3, 4);
NEWNAME = TRIM(LEFT(OCR_STR))?/?/TRIM(LEFT(NEWNAME));
END; /* IF LENGTH(TEMPNAME) GT 3 */
ELSE DO;
NEWNAME = TRIM(LEFT(OCR_STR))?/?/TRIM(LEFT(TEMPNAME));
END; /* ELSE DO */
END; /* ELSE IF TEMP_OCR LE 999 */
ELSE DO;
/* NOTHING */
END; /* ELSE DO */
RETURN; /* FROM FIXNAME */
RUN; /* DATA EXPAND */
PROC SORT DATA=DICTNRY OUT=DICTNRY;
BY FILENAME ATBYTE;
/* THE NOCHARCODE OPTION IS SET SO THAT STRINGS LIKE, '?)', ARE */
/* NOT MISINTERPRETED. */
OPTIONS NOCHARCODE;
RUN; /* PROGRAM R2COB5 */