00001 IDENTIFICATION DIVISION. 03/30/04 00002 PROGRAM-ID. DTSCU040. DTSCU040 00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV012 00004 DATE-WRITTEN. NOVEMBER 1991. DTSCU040 00005 DATE-COMPILED. DTSCU040 00006 SKIP3 DTSCU040 00007 ***** DTSCU040 00008 * DTSCU040 00009 * FUNCTION: NAICS CODE EDIT/DESCRIPTION. DTSCU040 00010 * DTSCU040 00011 * DTSCU040 00012 * MODIFICATION LOG: DTSCU040 00013 * DTSCU040 00014 * 09/13/1998 INITIAL DEVELOPMENT. COPIED FROM DTSCU039. DTSCU040 00015 * WORK ORDER: PROGRAMMER: ZL1 DTSCU040 00016 * DTSCU040 00017 * 03/26/2004 REVISED FOR NEW FORMAT OF VSAM NAICS FILE. DTSCU040 00018 * WORK ORDER: PROGRAMMER: GD DTSCU040 00019 * DTSCU040 00020 * DTSCU040 00021 * XX/XX/XXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSCU040 00022 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSCU040 00023 * WORK ORDER: PROGRAMMER: XXX DTSCU040 00024 * DTSCU040 00025 * DTSCU040 00026 * DESCRIPTION: DTSCU040 00027 * DTSCU040 00028 * DTSCU040 EDITS NAICS CODE. DTSCU040 00029 * DTSCU040 00030 * DTSCU040 RETURNS A RESULT INDICATOR, A SHORT DESCRIPTION DTSCU040 00031 * OF THE CODE VALUE, AND A LONG DESCRIPTION OF THE CODE DTSCU040 00032 * VALUE. DTSCU040 00033 * DTSCU040 00034 ***** DTSCU040 00035 SKIP3 DTSCU040 00036 ENVIRONMENT DIVISION. DTSCU040 00037 SKIP3 DTSCU040 00038 DATA DIVISION. DTSCU040 00039 SKIP3 DTSCU040 00040 WORKING-STORAGE SECTION. DTSCU040 000405 77 PAN-VALET PICTURE X(24) VALUE '012DTSCU040 03/30/04'. DTSCU040 00041 SKIP3 DTSCU040 00042 01 WRK-AREA. DTSCU040 00043 05 WRK-ABEND-CODE PIC X(04) VALUE 'U040'. DTSCU040 00044 EJECT DTSCU040 00045 01 L834-COMM-AREA. DTSCU040 00046 05 L834-CONTROL-BLOCK. DTSCU040 00047 ++INCLUDE DTSIL834 DTSCU040 00048 SKIP3 DTSCU040 00049 05 XNIC-REC. DTSCU040 00050 ++INCLUDE DTSIXNIC DTSCU040 00051 EJECT DTSCU040 00052 LINKAGE SECTION. DTSCU040 00053 SKIP3 DTSCU040 00054 01 DFHCOMMAREA. DTSCU040 00055 ++INCLUDE DTSIL040 DTSCU040 00056 EJECT DTSCU040 00057 PROCEDURE DIVISION. DTSCU040 00058 DTSCU040 00059 DTSCU040 00060 PERFORM P1000-PROCESS THRU P1000-EXIT DTSCU040 00061 DTSCU040 00062 DTSCU040 00063 EXEC CICS DTSCU040 00064 RETURN DTSCU040 00065 END-EXEC. DTSCU040 00066 DTSCU040 00067 DTSCU040 00068 GOBACK. DTSCU040 00069 EJECT DTSCU040 00070 P1000-PROCESS. DTSCU040 00071 SET L040-NAICS-NOT-VALID TO TRUE. DTSCU040 00072 DTSCU040 00073 MOVE 'NOT VALID' TO L040-NAICS-SHORT-DSCR DTSCU040 00074 L040-NAICS-LONG-DSCR. DTSCU040 00075 DTSCU040 00076 DTSCU040 00077 *****SET L040-OWN-NOT-VALID TO TRUE. DTSCU040 00078 DTSCU040 00079 *****MOVE 'NOT VALID' TO L040-OWN-SHORT-DSCR DTSCU040 00080 *************************L040-OWN-LONG-DSCR. DTSCU040 00081 DTSCU040 00082 DTSCU040 00083 MOVE SPACES TO L040-MSG-AREA. DTSCU040 00084 DTSCU040 00085 DTSCU040 00086 PERFORM P1100-NAICS-CD THRU P1100-EXIT. DTSCU040 00087 DTSCU040 00088 DTSCU040 00089 *****PERFORM P1200-OWN-CD THRU P1200-EXIT. DTSCU040 00090 P1000-EXIT. DTSCU040 00091 EXIT. DTSCU040 00092 EJECT DTSCU040 00093 P1100-NAICS-CD. DTSCU040 00094 IF L040-NAICS-CD NUMERIC DTSCU040 00095 NEXT SENTENCE DTSCU040 00096 ELSE DTSCU040 00097 GO TO P1100-EXIT. DTSCU040 00098 DTSCU040 00099 IF L040-NAICS-CD = '999999' DTSCU040 00100 MOVE 'NOT DETRM' TO L040-NAICS-SHORT-DSCR DTSCU040 00101 MOVE 'NOT DETERMINED' TO L040-NAICS-LONG-DSCR DTSCU040 00102 SET L040-NAICS-VALID TO TRUE DTSCU040 00103 GO TO P1100-EXIT. DTSCU040 00104 DTSCU040 00105 MOVE L040-NAICS-CD TO XNIC-KEY-AREA. DTSCU040 00106 DTSCU040 00107 SET L834-READ-88 TO TRUE. DTSCU040 00108 DTSCU040 00109 PERFORM S834-NAICS-I THRU S834-EXIT. DTSCU040 00110 DTSCU040 00111 IF L834-FILE-CLOSED-88 DTSCU040 00112 SET L040-NAICS-FILE-CLOSED TO TRUE DTSCU040 00113 MOVE L834-MSG-AREA TO L040-MSG-AREA DTSCU040 00114 GO TO P1100-EXIT. DTSCU040 00115 DTSCU040 00116 IF L834-NO-REC-88 DTSCU040 00117 GO TO P1100-EXIT. DTSCU040 00118 DTSCU040 00119 MOVE XNIC-NIC-DSCR TO L040-NAICS-SHORT-DSCR DTSCU040 00120 L040-NAICS-LONG-DSCR. DTSCU040 00121 DTSCU040 00122 SET L040-NAICS-VALID TO TRUE. DTSCU040 00123 P1100-EXIT. DTSCU040 00124 EXIT. DTSCU040 00125 SKIP3 DTSCU040 00126 S834-NAICS-I. DTSCU040 00127 EXEC CICS DTSCU040 00128 LINK DTSCU040 00129 PROGRAM ('DTSCU834') DTSCU040 00130 COMMAREA (L834-COMM-AREA) DTSCU040 00131 END-EXEC. DTSCU040 00132 S834-EXIT. DTSCU040 00133 EXIT. DTSCU040