135 lines
11 KiB
COBOL
135 lines
11 KiB
COBOL
00001 IDENTIFICATION DIVISION. 10/02/98
|
|
00002 PROGRAM-ID. DTSCU833. DTSCU833
|
|
00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV004
|
|
00004 DATE-WRITTEN. NOVEMBER 1991. DTSCU833
|
|
00005 DATE-COMPILED. DTSCU833
|
|
00006 SKIP3 DTSCU833
|
|
00007 ***** DTSCU833
|
|
00008 * DTSCU833
|
|
00009 * FUNCTION: SIC FILE INPUT. DTSCU833
|
|
00010 * DTSCU833
|
|
00011 * DTSCU833
|
|
00012 * MODIFICATION LOG: DTSCU833
|
|
00013 * DTSCU833
|
|
00014 * 09/13/98 INITIAL DEVELOPMENT. COPIED FROM MACCU833. CL**2
|
|
00015 * WORK ORDER: PROGRAMMER: ZL1. CL**2
|
|
00016 * DTSCU833
|
|
00017 * XX/XX/XX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSCU833
|
|
00018 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSCU833
|
|
00019 * WORK ORDER: PROGRAMMER: XXX DTSCU833
|
|
00020 * DTSCU833
|
|
00021 * DTSCU833
|
|
00022 * DESCRIPTION: DTSCU833
|
|
00023 * DTSCU833
|
|
00024 * READ THE SPECIFIED SIC DESCRIPTION RECORD FROM THE LMI CL**2
|
|
00025 * "SIC DESCRIPTION" FILE. DTSCU833
|
|
00026 * DTSCU833
|
|
00027 * THE TAX SYSTEM DOES NOT UPDATE THE LMI "SIC DESCRIPTION" CL**2
|
|
00028 * FILE. THUS, THE ONLY VALID COMMAND IS READ. DTSCU833
|
|
00029 * DTSCU833
|
|
00030 * IF AN INVALID COMMAND IS REQUESTED, THEN ABEND THE MODULE. DTSCU833
|
|
00031 * DTSCU833
|
|
00032 * IF A CICS FILE COMMAND YIELDS A RESPONSE OTHER THAN NORMAL, DTSCU833
|
|
00033 * NOT FOUND, CLOSED, OR DISABLED, THEN ABEND THE MODULE. DTSCU833
|
|
00034 * DTSCU833
|
|
00035 * DTSCU833
|
|
00036 ***** DTSCU833
|
|
00037 SKIP3 DTSCU833
|
|
00038 ENVIRONMENT DIVISION. DTSCU833
|
|
00039 SKIP3 DTSCU833
|
|
00040 DATA DIVISION. DTSCU833
|
|
00041 SKIP3 DTSCU833
|
|
00042 WORKING-STORAGE SECTION. DTSCU833
|
|
000425 77 PAN-VALET PICTURE X(24) VALUE '004DTSCU833 10/02/98'. DTSCU833
|
|
00043 SKIP3 DTSCU833
|
|
00044 01 WRK-AREA. DTSCU833
|
|
00045 05 WRK-ABEND-CD PIC X(04) VALUE 'U833'. DTSCU833
|
|
00046 05 WRK-RESP-CD PIC S9(08) COMP. DTSCU833
|
|
00047 SKIP1 DTSCU833
|
|
00048 05 EMSG-NOT-AVAILABLE. DTSCU833
|
|
00049 10 FILLER PIC X(04) VALUE 'E091'. DTSCU833
|
|
00050 10 FILLER PIC X(06) VALUE 'FILE '. DTSCU833
|
|
00051 10 EMSG-FILE-NAME PIC X(08). DTSCU833
|
|
00052 10 FILLER PIC X(33) DTSCU833
|
|
00053 VALUE ' NOT AVAILABLE PLEASE TRY LATER'. DTSCU833
|
|
00054 SKIP1 DTSCU833
|
|
00055 05 WRK-FILE-NAME PIC X(08) VALUE 'DTSFSIC'. CL**4
|
|
00056 SKIP1 DTSCU833
|
|
00057 05 WRK-REC-LENGTH PIC S9(04) COMP DTSCU833
|
|
00058 VALUE +46. DTSCU833
|
|
00059 EJECT DTSCU833
|
|
00060 LINKAGE SECTION. DTSCU833
|
|
00061 SKIP3 DTSCU833
|
|
00062 01 DFHCOMMAREA. DTSCU833
|
|
00063 05 L833-CONTROL-BLOCK. DTSCU833
|
|
00064 ++INCLUDE DTSIL833 CL**2
|
|
00065 SKIP3 DTSCU833
|
|
00066 05 XSIC-REC. DTSCU833
|
|
00067 ++INCLUDE DTSIXSIC CL**2
|
|
00068 EJECT DTSCU833
|
|
00069 PROCEDURE DIVISION. DTSCU833
|
|
00070 SKIP2 DTSCU833
|
|
00071 MOVE SPACES TO L833-MSG-AREA. DTSCU833
|
|
00072 SET L833-OK-88 TO TRUE. DTSCU833
|
|
00073 SKIP1 DTSCU833
|
|
00074 IF L833-READ-88 DTSCU833
|
|
00075 PERFORM P1100-READ THRU P1100-EXIT DTSCU833
|
|
00076 ELSE DTSCU833
|
|
00077 PERFORM S899-ABEND THRU S899-EXIT. DTSCU833
|
|
00078 SKIP2 DTSCU833
|
|
00079 EXEC CICS DTSCU833
|
|
00080 RETURN DTSCU833
|
|
00081 END-EXEC. DTSCU833
|
|
00082 SKIP2 DTSCU833
|
|
00083 GOBACK. DTSCU833
|
|
00084 EJECT DTSCU833
|
|
00085 P1100-READ. DTSCU833
|
|
00086 MOVE '01' TO XSIC-LINE-NUMBER. DTSCU833
|
|
00087 SKIP1 DTSCU833
|
|
00088 EXEC CICS DTSCU833
|
|
00089 READ DTSCU833
|
|
00090 DATASET (WRK-FILE-NAME) DTSCU833
|
|
00091 INTO (XSIC-REC) DTSCU833
|
|
00092 LENGTH (WRK-REC-LENGTH) DTSCU833
|
|
00093 RIDFLD (XSIC-KEY-AREA) DTSCU833
|
|
00094 RESP (WRK-RESP-CD) DTSCU833
|
|
00095 END-EXEC. DTSCU833
|
|
00096 SKIP1 DTSCU833
|
|
00097 IF WRK-RESP-CD = DFHRESP (NOTOPEN) OR DFHRESP (DISABLED) DTSCU833
|
|
00098 OR DFHRESP (SYSIDERR) DTSCU833
|
|
00099 PERFORM S1100-NOT-AVAILABLE THRU S1100-EXIT DTSCU833
|
|
00100 GO TO P1100-EXIT. DTSCU833
|
|
00101 SKIP1 DTSCU833
|
|
00102 IF WRK-RESP-CD = DFHRESP (NOTFND) DTSCU833
|
|
00103 PERFORM S1200-NOT-FOUND THRU S1200-EXIT DTSCU833
|
|
00104 GO TO P1100-EXIT. DTSCU833
|
|
00105 SKIP1 DTSCU833
|
|
00106 IF WRK-RESP-CD = DFHRESP (NORMAL) DTSCU833
|
|
00107 NEXT SENTENCE DTSCU833
|
|
00108 ELSE DTSCU833
|
|
00109 PERFORM S899-ABEND THRU S899-EXIT. DTSCU833
|
|
00110 P1100-EXIT. DTSCU833
|
|
00111 EXIT. DTSCU833
|
|
00112 EJECT DTSCU833
|
|
00113 S1100-NOT-AVAILABLE. DTSCU833
|
|
00114 MOVE WRK-FILE-NAME TO EMSG-FILE-NAME. DTSCU833
|
|
00115 MOVE EMSG-NOT-AVAILABLE TO L833-MSG-AREA. DTSCU833
|
|
00116 SET L833-FILE-CLOSED-88 TO TRUE. DTSCU833
|
|
00117 S1100-EXIT. DTSCU833
|
|
00118 EXIT. DTSCU833
|
|
00119 SKIP3 DTSCU833
|
|
00120 S1200-NOT-FOUND. DTSCU833
|
|
00121 SET L833-NO-REC-88 TO TRUE. DTSCU833
|
|
00122 S1200-EXIT. DTSCU833
|
|
00123 EXIT. DTSCU833
|
|
00124 EJECT DTSCU833
|
|
00125 S899-ABEND. DTSCU833
|
|
00126 SKIP1 DTSCU833
|
|
00127 EXEC CICS DTSCU833
|
|
00128 ABEND DTSCU833
|
|
00129 ABCODE (WRK-ABEND-CD) DTSCU833
|
|
00130 END-EXEC. DTSCU833
|
|
00131 SKIP1 DTSCU833
|
|
00132 S899-EXIT. DTSCU833
|
|
00133 EXIT. DTSCU833
|