126 lines
9.9 KiB
COBOL
126 lines
9.9 KiB
COBOL
00001 IDENTIFICATION DIVISION. 03/30/04
|
|
00002 PROGRAM-ID. DTSBU040. DTSBU040
|
|
00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV014
|
|
00004 DATE-WRITTEN. NOVEMBER 1991. DTSBU040
|
|
00005 DATE-COMPILED. DTSBU040
|
|
00006 SKIP3 DTSBU040
|
|
00007 ***** DTSBU040
|
|
00008 * DTSBU040
|
|
00009 * FUNCTION: NAICS CODE EDIT/DESCRIPTION. DTSBU040
|
|
00010 * DTSBU040
|
|
00011 * DTSBU040
|
|
00012 * MODIFICATION LOG: DTSBU040
|
|
00013 * DTSBU040
|
|
00014 * 02/02/1999 CLONED FROM DTSCU040. DTSBU040
|
|
00015 * REFERENCE: DC DEVELOPMENT PROGRAMMER: EHH DTSBU040
|
|
00016 * DTSBU040
|
|
00017 * 03/26/2004 REVISED FOR NEW FORMAT OF NAICS VSAM FILE DTSBU040
|
|
00018 * REFERENCE: PROGRAMMER: GD DTSBU040
|
|
00019 * DTSBU040
|
|
00020 * MM/DD/YYYY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU040
|
|
00021 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU040
|
|
00022 * REFERENCE: XXXXXXXXXXXXXXX PROGRAMMER: XXX DTSBU040
|
|
00023 * DTSBU040
|
|
00024 * DTSBU040
|
|
00025 * DESCRIPTION: DTSBU040
|
|
00026 * DTSBU040
|
|
00027 * DTSCU040 EDITS NAICS CODE. DTSBU040
|
|
00028 * DTSBU040
|
|
00029 * DTSCU040 RETURNS A RESULT INDICATOR, A SHORT DESCRIPTION DTSBU040
|
|
00030 * OF THE CODE VALUE, AND A LONG DESCRIPTION OF THE CODE DTSBU040
|
|
00031 * VALUE. DTSBU040
|
|
00032 * DTSBU040
|
|
00033 ***** DTSBU040
|
|
00034 SKIP3 DTSBU040
|
|
00035 ENVIRONMENT DIVISION. DTSBU040
|
|
00036 SKIP3 DTSBU040
|
|
00037 DATA DIVISION. DTSBU040
|
|
00038 SKIP3 DTSBU040
|
|
00039 WORKING-STORAGE SECTION. DTSBU040
|
|
000395 77 PAN-VALET PICTURE X(24) VALUE '014DTSBU040 03/30/04'. DTSBU040
|
|
00040 SKIP3 DTSBU040
|
|
00041 01 WRK-AREA. DTSBU040
|
|
00042 05 WRK-ABEND-CODE PIC S9(04) COMP VALUE +040.DTSBU040
|
|
00043 EJECT DTSBU040
|
|
00044 01 L934-LINK-AREA. DTSBU040
|
|
00045 05 L934-CONTROL-BLOCK. DTSBU040
|
|
00046 ++INCLUDE DTSIL934 DTSBU040
|
|
00047 SKIP3 DTSBU040
|
|
00048 01 XNIC-REC. DTSBU040
|
|
00049 ++INCLUDE DTSIXNIC DTSBU040
|
|
00050 EJECT DTSBU040
|
|
00051 LINKAGE SECTION. DTSBU040
|
|
00052 SKIP3 DTSBU040
|
|
00053 01 L040-LINK-AREA. DTSBU040
|
|
00054 ++INCLUDE DTSIL040 DTSBU040
|
|
00055 EJECT DTSBU040
|
|
00056 PROCEDURE DIVISION USING L040-LINK-AREA. DTSBU040
|
|
00057 DTSBU040
|
|
00058 DTSBU040
|
|
00059 PERFORM P1000-PROCESS THRU P1000-EXIT. DTSBU040
|
|
00060 DTSBU040
|
|
00061 DTSBU040
|
|
00062 GOBACK. DTSBU040
|
|
00063 EJECT DTSBU040
|
|
00064 P1000-PROCESS. DTSBU040
|
|
00065 SET L040-NAICS-NOT-VALID TO TRUE. DTSBU040
|
|
00066 DTSBU040
|
|
00067 MOVE 'NOT VALID' TO L040-NAICS-SHORT-DSCR DTSBU040
|
|
00068 L040-NAICS-LONG-DSCR. DTSBU040
|
|
00069 DTSBU040
|
|
00070 DTSBU040
|
|
00071 *****SET L040-OWN-NOT-VALID TO TRUE. DTSBU040
|
|
00072 DTSBU040
|
|
00073 *****MOVE 'NOT VALID' TO L040-OWN-SHORT-DSCR DTSBU040
|
|
00074 *************************L040-OWN-LONG-DSCR. DTSBU040
|
|
00075 DTSBU040
|
|
00076 DTSBU040
|
|
00077 MOVE SPACES TO L040-MSG-AREA. DTSBU040
|
|
00078 DTSBU040
|
|
00079 DTSBU040
|
|
00080 PERFORM P1100-NAICS-CD THRU P1100-EXIT. DTSBU040
|
|
00081 DTSBU040
|
|
00082 DTSBU040
|
|
00083 *****PERFORM P1200-OWN-CD THRU P1200-EXIT. DTSBU040
|
|
00084 P1000-EXIT. DTSBU040
|
|
00085 EXIT. DTSBU040
|
|
00086 EJECT DTSBU040
|
|
00087 P1100-NAICS-CD. DTSBU040
|
|
00088 IF L040-NAICS-CD NUMERIC DTSBU040
|
|
00089 NEXT SENTENCE DTSBU040
|
|
00090 ELSE DTSBU040
|
|
00091 GO TO P1100-EXIT. DTSBU040
|
|
00092 DTSBU040
|
|
00093 IF L040-NAICS-CD = '999999' DTSBU040
|
|
00094 MOVE 'NOT DETRM' TO L040-NAICS-SHORT-DSCR DTSBU040
|
|
00095 MOVE 'NOT DETERMINED' TO L040-NAICS-LONG-DSCR DTSBU040
|
|
00096 SET L040-NAICS-VALID TO TRUE DTSBU040
|
|
00097 GO TO P1100-EXIT. DTSBU040
|
|
00098 DTSBU040
|
|
00099 MOVE L040-NAICS-CD TO XNIC-KEY-AREA. DTSBU040
|
|
00100 DTSBU040
|
|
00101 SET L934-READ-88 TO TRUE. DTSBU040
|
|
00102 DTSBU040
|
|
00103 PERFORM S934-NAICS-I THRU S934-EXIT. DTSBU040
|
|
00104 DTSBU040
|
|
00105 *****IF L934-FILE-CLOSED-88 DTSBU040
|
|
00106 *********SET L040-NAICS-FILE-CLOSED TO TRUE DTSBU040
|
|
00107 *********MOVE L934-MSG-AREA TO L040-MSG-AREA DTSBU040
|
|
00108 *********GO TO P1100-EXIT. DTSBU040
|
|
00109 DTSBU040
|
|
00110 IF L934-NO-REC-88 DTSBU040
|
|
00111 GO TO P1100-EXIT. DTSBU040
|
|
00112 DTSBU040
|
|
00113 MOVE XNIC-NIC-DSCR TO L040-NAICS-SHORT-DSCR DTSBU040
|
|
00114 L040-NAICS-LONG-DSCR. DTSBU040
|
|
00115 DTSBU040
|
|
00116 SET L040-NAICS-VALID TO TRUE. DTSBU040
|
|
00117 P1100-EXIT. DTSBU040
|
|
00118 EXIT. DTSBU040
|
|
00119 SKIP3 DTSBU040
|
|
00120 S934-NAICS-I. DTSBU040
|
|
00121 CALL 'DTSBU934' USING L934-LINK-AREA DTSBU040
|
|
00122 XNIC-REC. DTSBU040
|
|
00123 S934-EXIT. DTSBU040
|
|
00124 EXIT. DTSBU040
|