/****************************************************************/
/* */
/* NAME: R2COB4 */
/* TITLE: PROGRAM 'R2COB4', A PART OF 'COB2SAS, RELEASE 2' */
/* PRODUCT: SAS */
/* SYSTEM: CMS MVS VSE VMS */
/* DATA: COB2SAS, RELEASE 2 */
/* */
/* AUTHOR: GREG HESTER */
/* SUPPORT: TOM ZACK UPDATE: 22JUL90 */
/* REF: COB2SAS, RELEASE 2 DOCUMENTATION */
/* MISC: WHEN USING, INVOKE SAS WITH THE SYSTEM OPTIONS: */
/* 'DQUOTE MACRO' */
/* */
/* PURPOSE: THIS ROUTINE CONVERTS COBOL DATA NAMES TO VALID */
/* SAS LANGUAGE VARIABLE NAMES. */
/* */
/****************************************************************/
/* THE CHARCODE OPTION IS SET SO THAT THE STRINGS, '?/?/', */
/* '?(', AND '?)' ARE PROPERLY INTERPRETED. */
OPTIONS CHARCODE;
/****************************************************************/
/* READ IN THE OUTPUT FILE CREATED BY COB2. */
/****************************************************************/
DATA NAMES;
SET DICTNRY;
__RECNO + 1;
KEEP FILENAME LEVEL NST_DPTH DATANAME USAGE PICTURE INFMT
OCR_BASE ITM_DISP ATBYTE BYTES OCR_VAL RDF_NAME __RECNO;
RUN; /* DATA NAMES */
/****************************************************************/
/* CONVERT A COBOL-LIKE DATA DESCRIPTOR TO 8 CHARS OR LESS. */
/****************************************************************/
DATA NEWNAMES;
SET NAMES;
KEEP FILENAME LEVEL NST_DPTH DATANAME NEWNAME USAGE PICTURE
INFMT OCR_BASE ITM_DISP ATBYTE BYTES OCR_VAL RDF_NAME
__RECNO;
LENGTH TEMPNAME $30 NEWNAME $8;
/* THE CHARCODE OPTION IS SET SO THAT THE STRINGS, '?/?/', */
/* '?(', AND '?)' ARE PROPERLY INTERPRETED. */
/* DO NOT ALTER 'FILLER'. */
IF DATANAME = 'FILLER' THEN DO;
NEWNAME = 'FILLER';
RETURN;
END; /* IF DATANAME = 'FILLER' */
TEMPNAME=TRANSLATE(DATANAME,'_','-');
LEN=LENGTH(TEMPNAME);
IF LEN <=8 THEN DO;
NEWNAME=TEMPNAME;
RETURN;
END;
ELSE DO;
LINK CNT_UND;
IF UND=0 THEN LINK NO_UND;
ELSE LINK UND;
END;
RETURN;
/* PROCESS NAMES THAT HAVE NO DASHES */
NO_UND:
PIECE=TEMPNAME;
LINK VOW_STRP;
LEN=LENGTH(PIECE);
IF LEN <=8 THEN DO;
NEWNAME=PIECE;
RETURN;
END;
/* IF NAME HAS LEN 9 OR 10 GET RID OF MIDDLE 2 CHARS */
IF LEN=9 THEN
NEWNAME=TRIM(SUBSTR(PIECE,1,4))?/?/SUBSTR(PIECE,6,4);
ELSE IF LEN=10 THEN
NEWNAME=TRIM(SUBSTR(PIECE,1,4))?/?/SUBSTR(PIECE,7,4);
ELSE DO;
MID=INT(LEN/2);
NEWNAME=TRIM(SUBSTR(PIECE,1,2))?/?/
TRIM(SUBSTR(PIECE,MID-1,2))?/?/
TRIM(SUBSTR(PIECE,MID+1,2))?/?/
SUBSTR(PIECE,LEN-1,2);
END;
RETURN;
/* PROCESS NAMES THAT HAVE ONE OR MORE DASHES */
UND:
/* DETERMINE IF STRIPING THE UNDERSCORES WOULD FIX IT */
IF (LEN-UND) <= 8 THEN DO;
NEWNAME=COMPRESS(TEMPNAME,'_');
RETURN;
END;
/* TAKE VOWELS OUT OF EACH PIECE */
DO I=1 TO UND+1;
PIECE=SCAN(TEMPNAME,I,'_');
LINK VOW_STRP;
IF I=1 THEN TNAME=PIECE;
ELSE TNAME=TRIM(TNAME)?/?/'_'?/?/PIECE;
END;
/* IF LESS THAN 8 THEN RETURN */
LEN=LENGTH(TNAME);
IF LEN <= 8 THEN DO;
NEWNAME=TNAME;
RETURN;
END;
/* DETERMINE IF STRIPING THE UNDERSCORES WILL FIX IT */
IF (LEN-UND) <= 8 THEN DO;
NEWNAME=COMPRESS(TNAME,'_');
RETURN;
END;
/* OTHERWISE, SUBSTR BASED ON NUMBER OF UNDERSCORES */
/* ALSO, GET RID OF UNDERSCORES */
IF UND=1 THEN DO;
PIECE1=SCAN(TNAME,1,'_');
PIECE2=SCAN(TNAME,2,'_');
IF LENGTH(PIECE1) > 4 THEN
PIECE1=SUBSTR(PIECE1,1,4);
IF LENGTH(PIECE2) > 4 THEN
PIECE2=TRIM(SUBSTR(PIECE2,1,2))?/?/
SUBSTR(PIECE2,LENGTH(PIECE2)-1,2);
NEWNAME=TRIM(PIECE1)?/?/PIECE2;
END;
ELSE IF UND = 2 THEN DO;
PIECE1=SCAN(TNAME,1,'_');
PIECE2=SCAN(TNAME,2,'_');
PIECE3=SCAN(TNAME,3,'_');
IF LENGTH(PIECE1) > 3 THEN
PIECE1=SUBSTR(PIECE1,1,3);
IF LENGTH(PIECE2) > 2 THEN
PIECE2=SUBSTR(PIECE2,1,2);
IF LENGTH(PIECE3) > 3 THEN
PIECE3=TRIM(SUBSTR(PIECE3,1,1))?/?/
SUBSTR(PIECE3,LENGTH(PIECE3)-1,2);
NEWNAME=TRIM(PIECE1)?/?/TRIM(PIECE2)?/?/PIECE3;
END;
ELSE IF UND = 3 THEN DO;
PIECE1=SCAN(TNAME,1,'_');
PIECE2=SCAN(TNAME,2,'_');
PIECE3=SCAN(TNAME,3,'_');
PIECE4=SCAN(TNAME,4,'_');
IF LENGTH(PIECE1) > 2 THEN
PIECE1=SUBSTR(PIECE1,1,2);
IF LENGTH(PIECE2) > 2 THEN
PIECE2=TRIM(SUBSTR(PIECE2,1,2));
IF LENGTH(PIECE3) > 2 THEN
PIECE3=SUBSTR(PIECE3,1,2);
IF LENGTH(PIECE4) > 2 THEN
PIECE4=SUBSTR(PIECE4,LENGTH(PIECE4)-1,2);
NEWNAME=TRIM(PIECE1)?/?/TRIM(PIECE2)?/?/
TRIM(PIECE3)?/?/PIECE4;
END;
ELSE IF UND >= 4 THEN DO;
PIECE1=SCAN(TNAME,1,'_');
PIECE2=SCAN(TNAME,UND+1,'_');
IF LENGTH(PIECE1) > 4 THEN
PIECE1=SUBSTR(PIECE1,1,4);
IF LENGTH(PIECE2) > 4 THEN
PIECE2=TRIM(SUBSTR(PIECE2,1,2))?/?/
SUBSTR(PIECE2,LENGTH(PIECE2)-1,2);
NEWNAME=TRIM(PIECE1)?/?/PIECE2;
END;
RETURN;
/* COUNT THE NUMBER OF UNDERSCORES IN THE NAME IF ANY */
CNT_UND:
/* COUNT THE NUMBER OF UNDERSCORES */
UND=0;
DO I=1 TO LEN;
IF SUBSTR(TEMPNAME,I,1)='_' THEN UND+1;
END;
RETURN;
/* STRIP OUT ALL OF THE VOWELS FROM A PIECE. HOWEVER, IF A */
/* VOWEL APPEARS IN POSITION 1, DO NOT GET RID OF IT. */
VOW_STRP:
PLEN=LENGTH(PIECE);
IF PLEN > 1 THEN DO;
TPIECE=COMPRESS(SUBSTR(PIECE,2,PLEN-1),'AEIOU');
PIECE=TRIM(SUBSTR(PIECE,1,1))?/?/TRIM(TPIECE);
END;
RETURN;
RUN; /* DATA NEWNAMES */
/****************************************************************/
/* INSURE THAT NONE OF THE NEWNAMES ARE DUPLICATES. */
/****************************************************************/
PROC SORT DATA=NEWNAMES;
BY NEWNAME;
RUN; /* PROC SORT DATA=NEWNAMES */
DATA NODUP;
KEEP FILENAME LEVEL NST_DPTH DATANAME NEWNAME USAGE PICTURE
INFMT OCR_BASE ITM_DISP ATBYTE BYTES OCR_VAL RDF_NAME
__RECNO;
SET NEWNAMES;
BY NEWNAME;
/* DO NOT ALTER 'FILLER'. */
IF NEWNAME = 'FILLER' THEN
RETURN;
LIST=REVERSE('_ABCDEFGHIJKLMNOPQRSTUVWXYZ');
IF FIRST.NEWNAME AND LAST.NEWNAME THEN DO;
I=1;
RETURN;
END;
ELSE DO;
IF LENGTH(NEWNAME) < 8 THEN
REP=LENGTH(NEWNAME)+1;
ELSE
REP=6;
IF FIRST.NEWNAME THEN
I = 1;
SUBSTR(NEWNAME,REP,1)=SUBSTR(LIST,I,1);
IF I LT 27 THEN
I+1;
END;
RUN; /* DATA NODUP */
PROC SORT DATA=NODUP OUT=DICTNRY;
BY __RECNO;
RUN; /* PROC SORT DATA=NODUP */
/* THE NOCHARCODE OPTION IS SET SO THAT STRINGS LIKE, '?)', ARE */
/* NOT MISINTERPRETED. */
OPTIONS NOCHARCODE;
RUN; /* PROGRAM R2COB4 */