135 lines
11 KiB
COBOL
135 lines
11 KiB
COBOL
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
|