189 lines
15 KiB
COBOL
189 lines
15 KiB
COBOL
00001 ***** 08/31/98
|
|
00002 * DTSIP006
|
|
00003 * DTSIP006 RECORD COMPRESSION PROCEDURE DIVISION CODE. LV002
|
|
00004 * DTSIP006
|
|
00005 * IF THIS CODE IS MODIFIED, THEN DTSCU810 CL**2
|
|
00006 * AND DTSBU910 MUST BE RECOMPILED. CL**2
|
|
00007 * DTSIP006
|
|
00008 * CL**2
|
|
00009 * 08/31/1998 REVIEWED AND MODIFIED FOR DC. EHH CL**2
|
|
00010 * CL**2
|
|
00011 ***** DTSIP006
|
|
00012 CL**2
|
|
00013 S6000-WRK-DATA-TO-IO-DATA. DTSIP006
|
|
00014 IF MLEN-COMPRESS-NO-88 (REC-TYPE-SUB) DTSIP006
|
|
00015 PERFORM S6100-COMPRESS-NO THRU S6100-EXIT DTSIP006
|
|
00016 ELSE DTSIP006
|
|
00017 IF MLEN-COMPRESS-1-88 (REC-TYPE-SUB) DTSIP006
|
|
00018 PERFORM S6200-COMPRESS-1 THRU S6200-EXIT DTSIP006
|
|
00019 ELSE DTSIP006
|
|
00020 PERFORM S899-ABEND THRU S899-EXIT. DTSIP006
|
|
00021 S6000-EXIT. DTSIP006
|
|
00022 EXIT. DTSIP006
|
|
00023 EJECT DTSIP006
|
|
00024 S6100-COMPRESS-NO. DTSIP006
|
|
00025 MOVE WRK-DATA-AREA (1:WRK-DATA-LENGTH) DTSIP006
|
|
00026 TO MIO-DATA-AREA (1:WRK-DATA-LENGTH). DTSIP006
|
|
00027 MOVE WRK-DATA-LENGTH TO MIO-DATA-LENGTH. DTSIP006
|
|
00028 SET MIO-COMPRESS-NO-88 TO TRUE. DTSIP006
|
|
00029 S6100-EXIT. DTSIP006
|
|
00030 EXIT. DTSIP006
|
|
00031 EJECT DTSIP006
|
|
00032 S6200-COMPRESS-1. DTSIP006
|
|
00033 MOVE +1 TO MIO-DATA-LENGTH. DTSIP006
|
|
00034 MOVE +1 TO CMP-SUB-S1. DTSIP006
|
|
00035 PERFORM S6210-COMPRESS-1-LOOP THRU S6210-EXIT DTSIP006
|
|
00036 UNTIL CMP-SUB-S1 > WRK-DATA-LENGTH. DTSIP006
|
|
00037 SUBTRACT 1 FROM MIO-DATA-LENGTH. DTSIP006
|
|
00038 IF MIO-DATA-LENGTH < WRK-DATA-LENGTH DTSIP006
|
|
00039 SET MIO-COMPRESS-1-88 TO TRUE DTSIP006
|
|
00040 ELSE DTSIP006
|
|
00041 PERFORM S6100-COMPRESS-NO THRU S6100-EXIT. DTSIP006
|
|
00042 S6200-EXIT. DTSIP006
|
|
00043 EXIT. DTSIP006
|
|
00044 SKIP3 DTSIP006
|
|
00045 S6210-COMPRESS-1-LOOP. DTSIP006
|
|
00046 MOVE CMP-SUB-S1 TO CMP-SUB-S2. DTSIP006
|
|
00047 MOVE +0 TO CMP-STRING-LENGTH. DTSIP006
|
|
00048 MOVE 'N' TO CMP-STRING-COMPLETE-IND. DTSIP006
|
|
00049 CL**2
|
|
00050 IF WRK-DATA-CHAR (CMP-SUB-S2) = SPACES DTSIP006
|
|
00051 PERFORM S6220-SPACE-STRING THRU S6220-EXIT DTSIP006
|
|
00052 UNTIL CMP-STRING-COMPLETE-IND = 'Y' DTSIP006
|
|
00053 ELSE DTSIP006
|
|
00054 IF WRK-DATA-CHAR (CMP-SUB-S2) = LOW-VALUES DTSIP006
|
|
00055 PERFORM S6230-LOW-VALUES-STRING THRU S6230-EXIT DTSIP006
|
|
00056 UNTIL CMP-STRING-COMPLETE-IND = 'Y' DTSIP006
|
|
00057 ELSE DTSIP006
|
|
00058 PERFORM S6240-ACTUAL-VALUES-STRING THRU S6240-EXIT DTSIP006
|
|
00059 UNTIL CMP-STRING-COMPLETE-IND = 'Y'. DTSIP006
|
|
00060 CL**2
|
|
00061 ADD CMP-STRING-LENGTH TO CMP-SUB-S1. DTSIP006
|
|
00062 S6210-EXIT. DTSIP006
|
|
00063 EXIT. DTSIP006
|
|
00064 SKIP3 DTSIP006
|
|
00065 S6220-SPACE-STRING. DTSIP006
|
|
00066 ADD +1 TO CMP-STRING-LENGTH. DTSIP006
|
|
00067 CL**2
|
|
00068 IF CMP-STRING-LENGTH NOT < CMP-STRING-MAX DTSIP006
|
|
00069 PERFORM S6221-SPACE THRU S6221-EXIT DTSIP006
|
|
00070 GO TO S6220-EXIT. DTSIP006
|
|
00071 CL**2
|
|
00072 ADD +1 TO CMP-SUB-S2. DTSIP006
|
|
00073 CL**2
|
|
00074 IF CMP-SUB-S2 > WRK-DATA-LENGTH DTSIP006
|
|
00075 PERFORM S6221-SPACE THRU S6221-EXIT DTSIP006
|
|
00076 GO TO S6220-EXIT. DTSIP006
|
|
00077 CL**2
|
|
00078 IF WRK-DATA-CHAR (CMP-SUB-S2) = SPACE DTSIP006
|
|
00079 NEXT SENTENCE DTSIP006
|
|
00080 ELSE DTSIP006
|
|
00081 PERFORM S6221-SPACE THRU S6221-EXIT. DTSIP006
|
|
00082 S6220-EXIT. DTSIP006
|
|
00083 EXIT. DTSIP006
|
|
00084 CL**2
|
|
00085 S6221-SPACE. DTSIP006
|
|
00086 MOVE +0 TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00087 MOVE CMP-SPACES-BYTE TO CMP-BINARY-HALF-BYTE-2. DTSIP006
|
|
00088 ADD CMP-STRING-LENGTH TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00089 MOVE CMP-BINARY-HALF-BYTE-2 DTSIP006
|
|
00090 TO MIO-DATA-CHAR (MIO-DATA-LENGTH). DTSIP006
|
|
00091 ADD +1 TO MIO-DATA-LENGTH. DTSIP006
|
|
00092 CL**2
|
|
00093 MOVE 'Y' TO CMP-STRING-COMPLETE-IND. DTSIP006
|
|
00094 S6221-EXIT. DTSIP006
|
|
00095 EXIT. DTSIP006
|
|
00096 SKIP3 DTSIP006
|
|
00097 S6230-LOW-VALUES-STRING. DTSIP006
|
|
00098 ADD +1 TO CMP-STRING-LENGTH. DTSIP006
|
|
00099 CL**2
|
|
00100 IF CMP-STRING-LENGTH NOT < CMP-STRING-MAX DTSIP006
|
|
00101 PERFORM S6231-LOW-VALUES THRU S6231-EXIT DTSIP006
|
|
00102 GO TO S6230-EXIT. DTSIP006
|
|
00103 CL**2
|
|
00104 ADD +1 TO CMP-SUB-S2. DTSIP006
|
|
00105 CL**2
|
|
00106 IF CMP-SUB-S2 > WRK-DATA-LENGTH DTSIP006
|
|
00107 PERFORM S6231-LOW-VALUES THRU S6231-EXIT DTSIP006
|
|
00108 GO TO S6230-EXIT. DTSIP006
|
|
00109 CL**2
|
|
00110 IF WRK-DATA-CHAR (CMP-SUB-S2) = LOW-VALUES DTSIP006
|
|
00111 NEXT SENTENCE DTSIP006
|
|
00112 ELSE DTSIP006
|
|
00113 IF WRK-DATA-CHAR (CMP-SUB-S2) = CMP-PACKED-ZERO-LIT DTSIP006
|
|
00114 ADD +1 TO CMP-STRING-LENGTH DTSIP006
|
|
00115 PERFORM S6232-PACKED-ZERO THRU S6232-EXIT DTSIP006
|
|
00116 ELSE DTSIP006
|
|
00117 PERFORM S6231-LOW-VALUES THRU S6231-EXIT. DTSIP006
|
|
00118 S6230-EXIT. DTSIP006
|
|
00119 EXIT. DTSIP006
|
|
00120 CL**2
|
|
00121 S6231-LOW-VALUES. DTSIP006
|
|
00122 MOVE +0 TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00123 MOVE CMP-LOW-VALUES-BYTE TO CMP-BINARY-HALF-BYTE-2. DTSIP006
|
|
00124 ADD CMP-STRING-LENGTH TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00125 MOVE CMP-BINARY-HALF-BYTE-2 DTSIP006
|
|
00126 TO MIO-DATA-CHAR (MIO-DATA-LENGTH). DTSIP006
|
|
00127 ADD +1 TO MIO-DATA-LENGTH. DTSIP006
|
|
00128 CL**2
|
|
00129 MOVE 'Y' TO CMP-STRING-COMPLETE-IND. DTSIP006
|
|
00130 S6231-EXIT. DTSIP006
|
|
00131 EXIT. DTSIP006
|
|
00132 CL**2
|
|
00133 S6232-PACKED-ZERO. DTSIP006
|
|
00134 MOVE +0 TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00135 MOVE CMP-PACKED-ZERO-BYTE TO CMP-BINARY-HALF-BYTE-2. DTSIP006
|
|
00136 ADD CMP-STRING-LENGTH TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00137 MOVE CMP-BINARY-HALF-BYTE-2 DTSIP006
|
|
00138 TO MIO-DATA-CHAR (MIO-DATA-LENGTH). DTSIP006
|
|
00139 ADD +1 TO MIO-DATA-LENGTH. DTSIP006
|
|
00140 CL**2
|
|
00141 MOVE 'Y' TO CMP-STRING-COMPLETE-IND. DTSIP006
|
|
00142 S6232-EXIT. DTSIP006
|
|
00143 EXIT. DTSIP006
|
|
00144 SKIP3 DTSIP006
|
|
00145 S6240-ACTUAL-VALUES-STRING. DTSIP006
|
|
00146 ADD +1 TO CMP-STRING-LENGTH. DTSIP006
|
|
00147 CL**2
|
|
00148 IF CMP-STRING-LENGTH NOT < CMP-STRING-MAX DTSIP006
|
|
00149 PERFORM S6241-ACTUAL-VALUES THRU S6241-EXIT DTSIP006
|
|
00150 GO TO S6240-EXIT. DTSIP006
|
|
00151 CL**2
|
|
00152 ADD +1 TO CMP-SUB-S2. DTSIP006
|
|
00153 CL**2
|
|
00154 IF CMP-SUB-S2 > WRK-DATA-LENGTH DTSIP006
|
|
00155 PERFORM S6241-ACTUAL-VALUES THRU S6241-EXIT DTSIP006
|
|
00156 GO TO S6240-EXIT. DTSIP006
|
|
00157 CL**2
|
|
00158 IF WRK-DATA-CHAR (CMP-SUB-S2) = SPACES DTSIP006
|
|
00159 IF WRK-DATA-CHAR (CMP-SUB-S2 + 1) = SPACES DTSIP006
|
|
00160 PERFORM S6241-ACTUAL-VALUES THRU S6241-EXIT DTSIP006
|
|
00161 ELSE DTSIP006
|
|
00162 NEXT SENTENCE DTSIP006
|
|
00163 ELSE DTSIP006
|
|
00164 IF WRK-DATA-CHAR (CMP-SUB-S2) = LOW-VALUES DTSIP006
|
|
00165 IF WRK-DATA-CHAR (CMP-SUB-S2 + 1) DTSIP006
|
|
00166 = LOW-VALUES OR CMP-PACKED-ZERO-LIT DTSIP006
|
|
00167 PERFORM S6241-ACTUAL-VALUES THRU S6241-EXIT DTSIP006
|
|
00168 ELSE DTSIP006
|
|
00169 NEXT SENTENCE DTSIP006
|
|
00170 ELSE DTSIP006
|
|
00171 NEXT SENTENCE. DTSIP006
|
|
00172 S6240-EXIT. DTSIP006
|
|
00173 EXIT. DTSIP006
|
|
00174 CL**2
|
|
00175 S6241-ACTUAL-VALUES. DTSIP006
|
|
00176 MOVE +0 TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00177 MOVE CMP-ACTUAL-VALUES-BYTE TO CMP-BINARY-HALF-BYTE-2. DTSIP006
|
|
00178 ADD CMP-STRING-LENGTH TO CMP-BINARY-HALF-WORD. DTSIP006
|
|
00179 MOVE CMP-BINARY-HALF-BYTE-2 DTSIP006
|
|
00180 TO MIO-DATA-CHAR (MIO-DATA-LENGTH). DTSIP006
|
|
00181 ADD +1 TO MIO-DATA-LENGTH. DTSIP006
|
|
00182 MOVE WRK-DATA-AREA (CMP-SUB-S1:CMP-STRING-LENGTH) DTSIP006
|
|
00183 TO MIO-DATA-AREA (MIO-DATA-LENGTH:CMP-STRING-LENGTH). DTSIP006
|
|
00184 ADD CMP-STRING-LENGTH TO MIO-DATA-LENGTH. DTSIP006
|
|
00185 CL**2
|
|
00186 MOVE 'Y' TO CMP-STRING-COMPLETE-IND. DTSIP006
|
|
00187 S6241-EXIT. DTSIP006
|
|
00188 EXIT. DTSIP006
|