SQLTODBF COmmand CMD PROMPT('Convierte Salida SQL a DBF') PARM KWD(SQLSTM) TYPE(*CHAR) LEN(3000) MIN(1) + PROMPT('Sentencia SQL a ejecutar') PARM KWD(IFSOBJ) TYPE(*CHAR) LEN(8) MIN(1) + PROMPT('Objeto PC para Salida') PARM KWD(PATH) TYPE(*CHAR) LEN(120) MIN(1) + PROMPT('Directorio QNTC') SQLTODBFC CLP PGM (&Q &IFSOBJ &PATH) DCL &Q *CHAR 3000 DCL &IFSOBJ *CHAR 8 DCL &PATH *CHAR 120 dcl &fromfile *char 20 value('tmpdbf qtemp ') DCL &TOFLR *CHAR 60 DCL &PCFILE *CHAR 10 DCL &PCFMT *CHAR 10 value('*DBASE') DCL &PCEXT *CHAR 3 value('DBF') DCL &REPLACE *CHAR 4 DCL VAR(&INPFILE) TYPE(*CHAR) LEN(10) value('tmpdbf') DCL VAR(&INPlib) TYPE(*CHAR) LEN(10) value('qtemp') DCL &DOC *CHAR 12 DCL &EXIST *LGL 1 '0' DCL &ERROR *CHAR 1 ' ' DCL &FF *CHAR 21 ' ' DCL &SIZA *CHAR 4 DCL &MSGID *CHAR 7 DCL &MSGDTA *CHAR 132 chgvar &PCFILE &ifsobj dltf qtemp/tmpdbf monmsg cpf0000 DSPLNK OBJ(&PATH) OUTPUT(*PRINT) MONMSG CPFA0A9 EXEC(DO) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('No se + ha encontrado el directorio en ' || + &path) MSGTYPE(*DIAG) GOTO ENDERROR ENDDO EXSQLSTM SQLSTM(&Q) OUTPUT(*OUTFILE) + OUTFILE(QTEMP/TMPDBF) NOEXT: IF (&PCEXT *EQ '***') CHGVAR &PCEXT ' ' /* CHECK FOR DATABASE FILE; IF NO, THEN ERROR */ DATABASE: RTVMBRD %SST(&FROMFILE 11 10)/%SST(&FROMFILE 1 10) MONMSG CPF0000 EXEC(GOTO ERROR) /* IF MEMBER *FIRST, CONVERT TO MEMBER NAME */ /* CHECK FROMFILE EXISTENCE; IF NO, THEN ERROR */ FROMFILE: CHKOBJ %SST(&FROMFILE 11 10)/%SST(&FROMFILE 1 10) + *FILE MONMSG CPF0000 EXEC(GOTO ERROR) DLTF QTEMP/XPRTFC MONMSG CPF0000 /* CHECK PCFILE EXISTENCE; IF YES AND REPLACE(*NO), ERROR */ /* EXPAND PACKED FIELDS IN FILE; IF UNABLE, ERROR */ dltf qtemp/XPNDF monmsg cpf0000 chgvar &inplib (%sst(&fromfile 11 10)) chgvar &inpfile (%sst(&fromfile 01 10)) EXPAND: XPNDF INPFILE(&INPLIB/&INPFILE) OUTFILE(QTEMP/XPNDF) MONMSG CPF0000 EXEC(GOTO ERROR) /* CREATE EXPANDED FILE INFORMATION FILES */ CHGVAR &FROMFILE 'XPNDF QTEMP ' DSPFFD FILE(QTEMP/XPNDF) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFFD) DSPFD FILE(QTEMP/XPNDF) TYPE(*MBR) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFD) /* SEND EXPORTING STATUS MESSAGE */ STATUS: SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) + MSGDTA('Exportando salida a archivo de + PC ' *BCAT &DOC) TOPGMQ(*EXT) + MSGTYPE(*STATUS) /* CALL EXPORT MODULE - XPRTFR FOR RPG */ EXPORT: OVRDBF FILE(INPUT) TOFILE(QTEMP/XPNDF) OVRDBF FILE(OUTPUT) TOFILE(QTEMP/XPRTFR) OVRDBF FILE(DSPFFD) TOFILE(QTEMP/DSPFFD) OVRDBF FILE(DSPFD) TOFILE(QTEMP/DSPFD) CALL SQLTODBFR (&PCFMT ' ' &ERROR) /* INTERNAL PROCESSING ERRORS */ DATAERROR: IF (&ERROR *NE ' ') DO DLTOVR *ALL DLTF QTEMP/XPNDF DLTF QTEMP/DSPFFD DLTF QTEMP/DSPFD DLTF QTEMP/XPRTFR FIELD: IF (&ERROR *EQ 'F') DO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('+ FIELD size exceeds 254(Character) + or 19(Numeric) bytes') MSGTYPE(*DIAG) GOTO ENDERROR ENDDO RECORDS: IF (&ERROR *EQ 'N') DO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('+ RECORDS exceed 1 billion') + MSGTYPE(*DIAG) GOTO ENDERROR ENDDO PROCESS: IF (&ERROR *EQ 'P') DO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('+ PROCESSING ERROR . . . UNABLE TO + CREATE INTERNAL FILE') + MSGTYPE(*DIAG) GOTO ENDERROR ENDDO SIZE: IF (&ERROR *EQ 'S') DO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('+ RECORD size exceeds 4,000 bytes') + MSGTYPE(*DIAG) GOTO ENDERROR ENDDO TYPE: IF (&ERROR *EQ 'T') DO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('+ FIELD TYPE not supported') + MSGTYPE(*DIAG) GOTO ENDERROR ENDDO FIELDNBR: IF (&ERROR *EQ 'Z') DO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('+ FIELD number exceeds dBASE limit + of 128 fields') MSGTYPE(*DIAG) GOTO ENDERROR ENDDO ENDDO /* COPY TO PC DOCUMENT; IF UNABLE, ERROR */ COPY: CPYTOSTMF + FROMMBR('/qsys.lib/qtemp.lib/xprtfr.file/xp+ rtfr.mbr') TOSTMF(&PATH |< &IFSOBJ |< + '.DBF') DBFCCSID(1252) /* CPYTOIMPF FROMFILE(QTEMP/XPRTFR) TOSTMF(&PATH |< + &IFSOBJ |< '.DBF') STMFCODPAG(*STDASCII) + RCDDLM(*CR) DTAFMT(*FIXED) */ MONMSG (cpf0000) + EXEC(GOTO ERROR) /* SEND COMPLETION MESSAGE */ COMPLETE: SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) + MSGDTA('Conversion finalizada') + MSGTYPE(*DIAG) GOTO END /* ERROR PROCESSING */ ERROR: RCVMSG MSGDTA(&MSGDTA) MSGID(&MSGID) IF (%SST(&MSGID 1 3) = 'CPC') GOTO ERROR IF (&MSGID = 'CPF0001') GOTO ERROR IF (&MSGID = 'CPF0864') GOTO ERROR IF (&MSGID = 'CPF3030') GOTO ERROR IF (&MSGID = 'CPF9861') GOTO ERROR IF (&MSGID = 'CPF9862') GOTO ERROR IF (&MSGID = 'IWS1601') GOTO ERROR IF (&MSGID = 'OFC8E70') GOTO ERROR IF (&MSGID = ' ') GOTO ENDERROR IF (%SST(&MSGID 1 2) = 'CP') + SNDPGMMSG MSGID(&MSGID) MSGF(QCPFMSG) + MSGDTA(&MSGDTA) MSGTYPE(*DIAG) ELSE SNDPGMMSG MSGID(&MSGID) MSGF(('Q' || + %SST(&MSGID 1 3) || 'MSG')) MSGDTA(&MSGDTA) GOTO ERROR ENDERROR: SNDPGMMSG MSGID(CPF0001) MSGF(QCPFMSG) MSGDTA('+ SQLTODBF') MSGTYPE(*ESCAPE) /* CLEAN UP */ END: DLTOVR *ALL DLTF QTEMP/XPNDF DLTF QTEMP/XPRTFR DLTF QTEMP/DSPFFD DLTF QTEMP/DSPFD ENDPGM SQLTODBFR RPGLE 0015 FDSPFFD IF F 9999 DISK 0016 FDSPFD IF F 9999 DISK 0017 FINPUT IF F 9999 DISK F INFDS(INFO) 0019 FOUTPUT O A F 9999 DISK USROPN 0020 F** 0021 F************************************************************** 0022 F/EJECT 0023 D************************************************************** 0024 D** 0025 D** A R R A Y S 0026 D** 0027 D************************************************************** 0028 D** 0029 D S S 1 DIM(92) 0030 D N S 10 DIM(999) 0031 D L S 6 DIM(999) 0032 D A S 1 DIM(999) 0033 D D S 2 DIM(999) 0034 D P S 4 0 DIM(999) 0035 D I S 1 DIM(9999) 0036 D O S 1 DIM(9999) 0037 D HC S 2 0 DIM(8) 0039 D MN S 1 DIM(19) 0044 D T S 2 0 DIM(16) CTDATA PERRCD(16) 0045 D H S 1 DIM(16) CTDATA PERRCD(16) 0076 D INFO DS 0077 D RCDSIZ 125 126B 0 0078 D NBRRCD 156 159B 0 0079 D DS 0080 D Q 1 80 D DIM(2) CTDATA PERRCD(1) 0081 D OSIZE 33 36 0082 D DS 0083 D LSTUPD 1 6 0084 D LUMM 1 2 0085 D LUDD 3 4 0086 D LUYY 5 6 0087 D DS 0088 D HS 1 8 D DIM(8) 0089 D HEX4 1 2 0090 D HEX3 3 4 0091 D HEX2 5 6 0092 D HEX1 7 8 0093 D DS 0094 D STG 1 8 D DIM(4) 0095 D STG1 1 2 0096 D STG2 3 4 0097 D STG3 5 6 0098 D STG4 7 8 0099 D DS 0100 D HBYT 1 2 0101 D HB01 1 1 0102 D HB02 2 2 0103 D DS 0104 D HEX 1 4 D DIM(4) 0105 D FOUR 1 4 0106 D THREE 1 3 0107 D TWO 1 2 0108 D ONE 1 1 0109 D DS 0110 D FNM 1 11 D DIM(11) 0111 D T11 1 11 0046 I** 0047 I************************************************************** 0048 I/EJECT 0049 I************************************************************** 0050 I** 0051 I** I N P U T 0052 I** 0053 I************************************************************** 0054 I** 0055 IDSPFFD NS 01 0056 I 1 10 WHFILE 0057 I 11 20 WHLIB 0058 I 28 28 WHFTYP 0059 I 47 56 WHNAME 0060 I 70 119 WHTEXT 0061 I 130 139 WHFLDI 0062 I 140 149 WHFLDE 0063 I 160 164 0WHFLDB 0064 I 165 166 0WHFLDD 0065 I 167 168 0WHFLDP 0066 I 169 218 WHFTXT 0067 I 322 322 WHFLDT 0068 IDSPFD NS 02 0069 I 164 173 MBNAME 0070 I 415 420 MBCHGD 0071 I 415 416 MBYY 0072 I 417 418 MBMM 0073 I 419 420 MBDD 0074 IINPUT NS 03 0075 I 1 9999 I 0112 I** 0113 I************************************************************** 0114 I/EJECT 0115 C************************************************************** 0116 C************************* PROGRAM START ********************** 0117 C************************************************************** 0118 C* 0119 C** GET PARAMETERS. 0120 C* 0125 C* 0126 C** INITIALIZATION. 0127 C* * C CLOSE DSPFFD 99 C CLOSE DSPFD 99 C CLOSE OUTPUT 99 * 0128 C Z-ADD 0 F 3 0 0129 C MOVE *BLANKS N 0130 C MOVE *BLANKS L 0131 C MOVE *BLANKS A 0132 C MOVE *BLANKS D 0133 C Z-ADD 0 P 0134 C MOVE *BLANKS BLANKS 10 0135 C MOVEL '*DBASE' FMTDBF 10 0136 C MOVEL '*DELIMIT' FMTDLM 10 0137 C MOVE 'ED' FMTDLM 0138 C MOVEL '*SDF' FMTSDF 10 0139 C MOVEL '*FIRST' FIRST 10 0140 C Z-ADD 0 SIZE 4 0 0141 C MOVE ' ' ERROR 0142 C MOVE 'N' HFLAG 0143 C* 0144 C** CREATE CARRIAGE-RETURN(CR) & LINE-FEED(LF) BYTES. 0145 C* 0146 C BITOFF '01234567' NULL 1 0147 C MOVE NULL CR 1 0148 C MOVE NULL LF 1 0149 C MOVE NULL GOOD 1 0150 C MOVE NULL SIGN 1 0151 C MOVE NULL EOF 1 0152 C MOVE NULL ZERO 1 0153 C MOVE NULL MINUS 1 0154 C MOVE NULL DOT 1 0155 C MOVE NULL D0 1 0156 C MOVE NULL D1 1 0157 C MOVE NULL D2 1 0158 C MOVE NULL D3 1 0159 C MOVE NULL D4 1 0160 C MOVE NULL D5 1 0161 C MOVE NULL D6 1 0162 C MOVE NULL D7 1 0163 C MOVE NULL D8 1 0164 C MOVE NULL D9 1 0165 C MOVE NULL A0 1 0166 C MOVE NULL A1 1 0167 C MOVE NULL A2 1 0168 C MOVE NULL A3 1 0169 C MOVE NULL A4 1 0170 C MOVE NULL A5 1 0171 C MOVE NULL A6 1 0172 C MOVE NULL A7 1 0173 C MOVE NULL A8 1 0174 C MOVE NULL A9 1 0175 C BITON '457' CR 0176 C BITON '46' LF 0177 C BITON '2' GOOD 0178 C BITON '67' SIGN 0179 C BITON '346' EOF 0180 C BITON '23' ZERO 0181 C BITON '2457' MINUS 0182 C BITON '2456' DOT 0183 C BITON '123457' D0 0184 C BITON '146' D1 0185 C BITON '1467' D2 0186 C BITON '145' D3 0187 C BITON '1457' D4 0188 C BITON '1456' D5 0189 C BITON '14567' D6 0190 C BITON '13' D7 0191 C BITON '137' D8 0192 C BITON '136' D9 0193 C BITON '23' A0 0194 C BITON '237' A1 0195 C BITON '236' A2 0196 C BITON '2367' A3 0197 C BITON '235' A4 0198 C BITON '2357' A5 0199 C BITON '2356' A6 0200 C BITON '23567' A7 0201 C BITON '234' A8 0202 C BITON '2347' A9 0203 C* 0204 C** CHECK FILE LIMITATIONS. 0205 C* 0206 C FORMAT IFEQ FMTDBF 0207 C NBRRCD IFGT 10000000 0208 C MOVE 'R' ERROR 0209 C ELSE 0210 C RCDSIZ IFGT 3999 0211 C MOVE 'S' ERROR 0212 C END 0213 C END 0214 C ERROR CABNE ' ' STOP 0215 C END 0216 C* 0217 C** LOAD FIELD ARRAYS. 0218 C* 0219 C Z-ADD 1 FLDPOS 4 0 0220 C OPEN DSPFFD 0221 C READ DSPFFD 10 0222 C *IN10 DOWEQ '0' 0223 C MOVE WHFLDT FLDATR 1 0224 C WHFLDT IFEQ 'P' 0225 C WHFLDT OREQ 'S' 0226 C Z-ADD WHFLDD FLDLEN 6 0 0227 C MOVE WHFLDP FLDDEC 2 0228 C WHFLDP IFLT 10 0229 C MOVEL ' ' FLDDEC 0230 C END 0231 C ELSE 0232 C WHFLDT IFEQ 'A' 0233 C WHFLDT OREQ 'N' 0234 C Z-ADD WHFLDB FLDLEN 0235 C MOVE ' ' FLDDEC 0236 C ELSE 0237 C MOVE 'T' ERROR 0238 C END 0239 C END 0240 C WHFLDE IFNE BLANKS 0241 C MOVE WHFLDE FLDNAM 10 0242 C ELSE 0243 C WHFLDI IFNE BLANKS 0244 C MOVE WHFLDI FLDNAM 0245 C END 0246 C END 0247 C FLDATR IFEQ 'A' 0248 C FLDLEN ANDGT 254 0249 C MOVE 'F' ERROR 0250 C ELSE 0251 C FLDATR IFEQ 'S' 0252 C FLDLEN ANDGT 19 0253 C MOVE 'F' ERROR 0254 C ELSE 0255 C ADD 1 F 0256 C MOVEA FLDNAM N(F) 0257 C MOVE FLDLEN L(F) 0258 C MOVEA FLDATR A(F) 0259 C MOVEA FLDDEC D(F) 0260 C Z-ADD FLDPOS P(F) 0261 C END 0262 C END 0263 C ERROR IFEQ ' ' 0264 C ADD FLDLEN FLDPOS 0265 C READ DSPFFD 10 0266 C ELSE 0267 C MOVE '1' *IN10 0268 C END 0269 C END 0270 C CLOSE DSPFFD 0271 C F IFGT 128 0272 C MOVE 'Z' ERROR 0273 C END 0274 C* 0275 C** CHECK dBASE FIELD LIMITATIONS. 0276 C* 0277 C ERROR CABNE ' ' STOP 0278 C* 0279 C** READ MEMBER FILE AND GET LAST UPDATE DATE. 0280 C* 0281 C MOVE ' ' LSTUPD 0282 C OPEN DSPFD 0283 C READ DSPFD 10 0284 C *IN10 DOWEQ '0' 0285 C MEMBER IFEQ FIRST 0286 C MOVE '1' *IN10 0287 C ELSE 0288 C MBNAME IFEQ MEMBER 0289 C MOVE '1' *IN10 0290 C ELSE 0291 C READ DSPFD 10 0292 C END 0293 C END 0294 C END 0295 C MOVE MBYY LUYY 0296 C MOVE MBMM LUMM 0297 C MOVE MBDD LUDD 0298 C CLOSE DSPFD 0299 C* 0300 C** CALCULATE PC FILE RECORD SIZE. 0301 C* 0302 C FORMAT CASEQ FMTDBF SIZDBF 0303 C FORMAT CASEQ FMTDLM SIZDLM 0304 C FORMAT CASEQ FMTSDF SIZSDF 0305 C END 0306 C* 0307 C** CREATE NEW OUTPUT FILE, IF ERROR, END. 0308 C* 0309 C FORMAT IFNE FMTDBF 0310 C ADD 2 SIZE 0311 C MOVE SIZE OSIZE 0312 C SUB 2 SIZE 0313 C ELSE 0314 C MOVE SIZE OSIZE 0315 C END 0316 C MOVE Q(1) QCMD 80 0317 C Z-ADD 80 QLEN 15 5 0318 C CALL 'QCMDEXC' 99 0319 C PARM QCMD 0320 C PARM QLEN 0321 C *IN99 IFEQ '1' 0322 C MOVE 'P' ERROR 0323 C GOTO STOP 0324 C END 0325 C* 0326 C** OVERRIDE OUTPUT FILE. 0327 C* 0328 C MOVE Q(2) QCMD 0329 C Z-ADD 80 QLEN 0330 C CALL 'QCMDEXC' 0331 C PARM QCMD 0332 C PARM QLEN 0333 C* 0334 C** OPEN OUTPUT FILE. 0335 C* 0336 C OPEN OUTPUT 0337 C* 0338 C** READ INPUT FILE. 0339 C* 0340 C READ INPUT 10 0341 C *IN10 DOWEQ '0' 0342 C* 0343 C** FORMAT DELIMITED OUTPUT RECORD. 0344 C* 0345 C FORMAT IFEQ FMTDLM 0346 C Z-ADD 1 IP 4 0 0347 C Z-ADD 1 OP 4 0 0348 C Z-ADD 0 FF 3 0 0349 C FF DOWLT F 0350 C ADD 1 FF 0351 C MOVE L(FF) LEN 6 0 0352 C A(FF) IFEQ 'A' 0353 C A(FF) OREQ 'N' 0354 C MOVEA '\"' O(OP) 0355 C ADD 1 OP 0356 C MOVEA I(IP) O(OP) 0357 C ADD LEN OP 0358 C MOVEA '\"' O(OP) 0359 C ADD 1 OP 0360 C ELSE 0361 C MOVEA I(IP) O(OP) 0362 C ADD LEN OP 0363 C END 0364 C MOVEA ',' O(OP) 0365 C ADD 1 OP 0366 C ADD LEN IP 0367 C END 0368 C CALL 'QDCXLATE' 0369 C PARM 9999 TLEN 0370 C PARM O 03710C PARM 'QASCII ' TTBL 03730C PARM 'QSYS ' TLIB 0374 C Z-ADD SIZE OO 4 0 0375 C ADD 1 OO 0376 C MOVEA CR O(OO) 0377 C ADD 1 OO 0378 C MOVEA LF O(OO) 0379 C END 0380 C* 0381 C** FORMAT SDF(ASCII) OUTPUT RECORD. 0382 C* 0383 C FORMAT IFEQ FMTSDF 0384 C MOVEA I O 0385 C CALL 'QDCXLATE' 0386 C PARM 9999 TLEN 0387 C PARM O 03710C PARM 'QASCII ' TTBL 03900C PARM 'QSYS ' TLIB 0391 C Z-ADD SIZE OO 0392 C ADD 1 OO 0393 C MOVEA CR O(OO) 0394 C ADD 1 OO 0395 C MOVEA LF O(OO) 0396 C END 0397 C* 0398 C** WRITE OUTPUT RECORD FOR NON-dBASE FORMATS. 0399 C* 0400 C FORMAT IFNE FMTDBF 0401 C READ INPUT 10 0402 C *IN10 IFEQ '0' 0403 C EXCEPT PUT 0404 C END 0405 C ELSE 0406 C* 0407 C** WRITE OUTPUT RECORD(S) FOR dBASE FORMAT. 0408 C* 0409 C HFLAG IFEQ 'N' 0410 C EXSR WRTHDR 0411 C MOVE 'Y' HFLAG 1 0412 C ELSE 0413 C EXSR WRTDTA 0414 C END 0415 C READ INPUT 10 0416 C END 0417 C* 0418 C END 0419 C* 0420 C** LAST WRITE(S). 0421 C* 0422 C FORMAT IFEQ FMTDBF 0423 C EXSR WRTLST 0424 C ELSE 0425 C EXSR WRTEOF 0426 C END 0427 C* 0428 C** CLOSE OUTPUT FILE. 0429 C* 0430 C CLOSE OUTPUT 0431 C* 0432 C** END OF JOB. 0433 C* 0434 C STOP TAG 0435 C* 0436 C MOVE '1' *INLR 0437 C** 0438 C************************************************************** 0439 C************************* END PROGRAM ********************** 0440 C************************************************************** 0441 C/EJECT 0442 C************************************************************** 0443 C** 0444 C** S U B R O U T I N E S 0445 C** 0446 C************************************************************** 0447 C** 0448 C SIZDBF BEGSR 0449 C** 0450 C Z-ADD 9999 SIZE 0451 C** 0452 C ENDSR 0453 C** 0454 C************************************************************** 0455 C/EJECT 0456 C************************************************************** 0457 C** 0458 C SIZDLM BEGSR 0459 C** 0460 C DO F G 3 0 0461 C MOVE L(G) LEN 6 0 0462 C ADD LEN SIZE 0463 C A(G) IFEQ 'A' 0464 C A(G) OREQ 'N' 0465 C ADD 2 SIZE 0466 C END 0467 C ADD 1 SIZE 0468 C END 0469 C SUB 1 SIZE 0470 C** 0471 C ENDSR 0472 C** 0473 C************************************************************** 0474 C/EJECT 0475 C************************************************************** 0476 C** 0477 C SIZSDF BEGSR 0478 C** 0479 C Z-ADD RCDSIZ SIZE 0480 C** 0481 C ENDSR 0482 C** 0483 C************************************************************** 0484 C/EJECT 0485 C************************************************************** 0486 C** 0487 C WRTHDR BEGSR 0488 C** 0489 C* 0490 C** CALCULATE HEADER LENGTH. 0491 C* 0492 C F MULT 32 HDRLEN 4 0 0493 C ADD 33 HDRLEN 0494 C* 0495 C** CALCULATE DATA RECORD LENGTH. 0496 C* 0497 C Z-ADD RCDSIZ RCDLEN 4 0 0498 C ADD 1 RCDLEN 0499 C* 0500 C** STUFF SIGNATURE BYTE. 0501 C* 0502 C MOVEA SIGN O(1) 0503 C* 0504 C** STUFF LAST UPDATE(YMD). 0505 C* 0506 C MOVE LUYY HDEC 10 0 0507 C Z-ADD 1 HLEN 1 0 0508 C EXSR DECHEX 0509 C MOVEA ONE O(2) 0510 C MOVE LUMM HDEC 0511 C Z-ADD 1 HLEN 0512 C EXSR DECHEX 0513 C MOVEA ONE O(3) 0514 C MOVE LUDD HDEC 0515 C Z-ADD 1 HLEN 0516 C EXSR DECHEX 0517 C MOVEA ONE O(4) 0518 C* 0519 C** STUFF NUMBER OF RECORDS. 0520 C* 0521 C Z-ADD NBRRCD HDEC 0522 C Z-ADD 4 HLEN 0523 C EXSR DECHEX 0524 C MOVEA FOUR O(5) 0525 C* 0526 C** STUFF HEADER LENGTH. 0527 C* 0528 C Z-ADD HDRLEN HDEC 0529 C Z-ADD 2 HLEN 0530 C EXSR DECHEX 0531 C MOVEA TWO O(9) 0532 C* 0533 C** STUFF DATA RECORD LENGTH. 0534 C* 0535 C Z-ADD RCDLEN HDEC 0536 C Z-ADD 2 HLEN 0537 C EXSR DECHEX 0538 C MOVEA TWO O(11) 0539 C* 0540 C** STUFF RESERVED BYTES(NULLS). 0541 C* 0542 C Z-ADD 12 OO 0543 C Z-ADD 0 O1 4 0 0544 C O1 DOWLT 20 0545 C ADD 1 O1 0546 C ADD 1 OO 0547 C MOVEA NULL O(OO) 0548 C END 0549 C Z-ADD 33 OO 0550 C* 0551 C** STUFF FIELD SUB-RECORD(S). 0552 C* 0553 C Z-ADD 1 OFS 4 0 0554 C Z-ADD 0 FF 3 0 0555 C FF DOWLT F 0556 C ADD 1 FF 0557 C MOVE *BLANKS T11 0558 C MOVEL N(FF) T11 0559 C CALL 'QDCXLATE' 0560 C PARM 11 TLEN 5 0 0561 C PARM T11 05640C PARM 'QASCII ' TTBL 10 05650C PARM 'QSYS ' TLIB 10 0566 C Z-ADD 12 NN 2 0 0567 C NN DOWGT 0 0568 C SUB 1 NN 0569 C FNM(NN) IFEQ GOOD 0570 C MOVEA NULL FNM(NN) 0571 C ELSE 0572 C Z-ADD 0 NN 0573 C END 0574 C END 0575 C MOVEA T11 O(OO) 0576 C ADD 11 OO 0577 C A(FF) IFEQ 'S' 0578 C A(FF) OREQ 'N' 0579 C MOVE 'N' T01 1 0580 C ELSE 0581 C A(FF) IFEQ 'A' 0582 C MOVE 'C' T01 0583 C ELSE 0584 C MOVE A(FF) T01 0585 C END 0586 C END 0587 C CALL 'QDCXLATE' 0588 C PARM 1 TLEN 0589 C PARM T01 05900C PARM 'QASCII ' TTBL 05920C PARM 'QSYS ' TLIB 0593 C MOVEA T01 O(OO) 0594 C ADD 1 OO 0595 C Z-ADD OFS HDEC 0596 C Z-ADD 4 HLEN 0597 C EXSR DECHEX 0598 C MOVEA FOUR O(OO) 0599 C ADD 4 OO 0600 C MOVE L(FF) FLEN 6 0 0601 C Z-ADD FLEN HDEC 0602 C Z-ADD 1 HLEN 0603 C EXSR DECHEX 0604 C MOVEA ONE O(OO) 0605 C ADD FLEN OFS 0606 C ADD 1 OO 0607 C A(FF) IFEQ 'S' 0608 C A(FF) OREQ 'N' 0609 C MOVE D(FF) FDEC 2 0 0610 C Z-ADD FDEC HDEC 0611 C Z-ADD 1 HLEN 0612 C EXSR DECHEX 0613 C MOVEA ONE O(OO) 0614 C ELSE 0615 C MOVEA NULL O(OO) 0616 C END 0617 C ADD 1 OO 0618 C Z-ADD 0 NN 2 0 0619 C NN DOWLT 14 0620 C ADD 1 NN 0621 C MOVEA NULL O(OO) 0622 C ADD 1 OO 0623 C END 0624 C END 0625 C* 0626 C** STUFF TERMINATOR BYTE. 0627 C* 0628 C MOVEA CR O(OO) 0629 C* 0630 C** SETUP DATA RECORD LIMITS. 0631 C* 0632 C Z-ADD OO OB 5 0 0633 C Z-ADD 0 OR 4 0 0634 C ADD 1 OO 0635 C Z-ADD 1 II 4 0 0636 C* 0637 C** TRANSLATE 1ST DATA RECORD TO ASCII. 0638 C* 0639 C CALL 'QDCXLATE' 0640 C PARM 9999 TLEN 0641 C PARM I 06420C* PARM 'QASCII' TTBL 06430C* PARM 'QSYS' TLIB 06440C PARM 'QASCII ' TTBL 06450C PARM 'QSYS ' TLIB 0646 C* 0647 C** CONVERT NUMERICS. 0648 C* 0649 C EXSR CVTNUM 0650 C* 0651 C** CONVERT NEGATIVE NUMERICS. 0652 C* 0653 C EXSR CVTNEG 0654 C* 0655 C** STUFF 'GOOD' BYTE. 0656 C* 0657 C MOVEA GOOD O(OO) 0658 C ADD 1 OB 0659 C ADD 1 OO 0660 C* 0661 C** STUFF PARTIAL/FULL DATA RECORD. 0662 C* 0663 C 9999 SUB OB OR 0664 C OR IFLT RCDSIZ 0665 C MOVEA I(II) O(OO) 0666 C EXCEPT PUT 0667 C MOVE NULL O 0668 C Z-ADD 1 OO 0669 C ADD OR II 0670 C MOVEA I(II) O(OO) 0671 C RCDSIZ SUB OR OB 0672 C 9999 SUB OB OR 0673 C ADD OB OO 0674 C Z-ADD 1 II 0675 C ELSE 0676 C OR IFEQ RCDSIZ 0677 C MOVEA I(II) O(OO) 0678 C EXCEPT PUT 0679 C MOVE NULL O 0680 C Z-ADD 0 OB 0681 C Z-ADD 0 OR 0682 C Z-ADD 1 OO 0683 C Z-ADD 1 II 0684 C ELSE 0685 C MOVEA I(II) O(OO) 0686 C ADD RCDSIZ OB 0687 C 9999 SUB OB OR 0688 C ADD RCDSIZ OO 0689 C Z-ADD 1 II 0690 C END 0691 C END 0692 C** 0693 C ENDSR 0694 C** 0695 C************************************************************** 0696 C/EJECT 0697 C************************************************************** 0698 C** 0699 C WRTDTA BEGSR 0700 C** 0701 C* 0702 C** TRANSLATE DATA RECORD TO ASCII. 0703 C* 0704 C CALL 'QDCXLATE' 0705 C PARM 9999 TLEN 0706 C PARM I 07070C* PARM 'QASCII' TTBL 07080C* PARM 'QSYS' TLIB 07090C PARM 'QASCII ' TTBL 07100C PARM 'QSYS ' TLIB 0711 C* 0712 C** CONVERT NUMERICS. 0713 C* 0714 C EXSR CVTNUM 0715 C* 0716 C** CONVERT NEGATIVE NUMERICS. 0717 C* 0718 C EXSR CVTNEG 0719 C* 0720 C** STUFF 'GOOD' BYTE. 0721 C* 0722 C II IFEQ 1 0723 C MOVEA GOOD O(OO) 0724 C ADD 1 OB 0725 C ADD 1 OO 0726 C END 0727 C* 0728 C** WRITE RECORD. 0729 C* 0730 C OB IFGE 9999 0731 C EXCEPT PUT 0732 C MOVE NULL O 0733 C Z-ADD 1 OO 0734 C Z-ADD 0 OB 0735 C END 0736 C* 0737 C** STUFF PARTIAL/FULL DATA RECORD. 0738 C* 0739 C 9999 SUB OB OR 0740 C OR IFLT RCDSIZ 0741 C MOVEA I(II) O(OO) 0742 C EXCEPT PUT 0743 C MOVE NULL O 0744 C Z-ADD 1 OO 0745 C ADD OR II 0746 C MOVEA I(II) O(OO) 0747 C RCDSIZ SUB OR OB 0748 C 9999 SUB OB OR 0749 C ADD OB OO 0750 C Z-ADD 1 II 0751 C ELSE 0752 C OR IFEQ RCDSIZ 0753 C MOVEA I(II) O(OO) 0754 C EXCEPT PUT 0755 C MOVE NULL O 0756 C Z-ADD 0 OB 0757 C Z-ADD 0 OR 0758 C Z-ADD 1 OO 0759 C Z-ADD 1 II 0760 C ELSE 0761 C MOVEA I(II) O(OO) 0762 C ADD RCDSIZ OB 0763 C 9999 SUB OB OR 0764 C ADD RCDSIZ OO 0765 C Z-ADD 1 II 0766 C END 0767 C END 0768 C** 0769 C ENDSR 0770 C** 0771 C************************************************************** 0772 C/EJECT 0773 C************************************************************** 0774 C** 0775 C WRTLST BEGSR 0776 C** 0777 C* 0778 C** STUFF LAST BYTE. 0779 C* 0780 C MOVEA EOF O(OO) 0781 C* 0782 C** CLEAR REMAINING BYTES(NULLS). 0783 C* 0784 C OO DOWLT 9999 0785 C ADD 1 OO 0786 C MOVEA NULL O(OO) 0787 C END 0788 C* 0789 C** WRITE LAST RECORD. 0790 C* 0791 C EXCEPT PUT 0792 C** 0793 C ENDSR 0794 C** 0795 C************************************************************** 0796 C/EJECT 0797 C************************************************************** 0798 C** 0799 C WRTEOF BEGSR 0800 C** 0801 C* 0802 C** STUFF EOF BYTE. 0803 C* 0804 C Z-ADD SIZE OO 0805 C ADD 2 OO 0806 C MOVEA EOF O(OO) 0807 C* 0808 C** WRITE LAST RECORD. 0809 C* 0810 C EXCEPT PUT 0811 C** 0812 C ENDSR 0813 C** 0814 C************************************************************** 0815 C/EJECT 0816 C************************************************************** 0817 C** 0818 C CVTNUM BEGSR 0819 C** 0820 C* 0821 C** CHECK FOR NUMERIC FIELD. 0822 C* 0823 C Z-ADD 0 FF 0824 C FF DOWLT F 0825 C ADD 1 FF 0826 C A(FF) IFEQ 'P' 0827 C A(FF) OREQ 'S' 0828 C MOVE ' ' MN 0829 C Z-ADD P(FF) MP 4 0 0830 C MOVEA I(MP) MN(1) 0831 C MOVE L(FF) ML 6 0 0832 C MOVE D(FF) MD 2 0 0833 C ML SUB MD MS 2 0 0834 C MD IFGT 0 0835 C Z-ADD 1 CT 2 0 0836 C Z-ADD 1 P1 2 0 0837 C Z-ADD 0 P2 2 0 0838 C CT DOWLT MS 0839 C ADD 1 CT 0840 C ADD 1 P1 0841 C ADD 1 P2 0842 C MOVE MN(P1) MN(P2) 0843 C END 0844 C MOVE DOT MN(P1) 0845 C END 0846 C MOVEA MN(1) I(MP) 0847 C END 0848 C END 0849 C** 0850 C ENDSR 0851 C** 0852 C************************************************************** 0853 C/EJECT 0854 C************************************************************** 0855 C** 0856 C CVTNEG BEGSR 0857 C** 0858 C* 0859 C** CHECK FOR NUMERIC FIELD. 0860 C* 0861 C Z-ADD 0 FF 0862 C FF DOWLT F 0863 C ADD 1 FF 0864 C A(FF) IFEQ 'P' 0865 C A(FF) OREQ 'S' 0866 C MOVE ' ' MN 0867 C Z-ADD P(FF) MP 4 0 0868 C MOVEA I(MP) MN(1) 0869 C MOVE L(FF) ML 6 0 0870 C Z-ADD 1 P1 2 0 0871 C P1 DOWLT ML 0872 C MN(P1) IFEQ GOOD 0873 C MN(P1) OREQ ZERO 0874 C MOVEA GOOD MN(P1) 0875 C ADD 1 P1 0876 C ELSE 0877 C Z-ADD P1 NP 2 0 0878 C Z-ADD ML P1 0879 C END 0880 C END 0881 C MOVE '0' NFLAG 1 0882 C MN(ML) IFEQ D0 0883 C MOVE A0 MN(ML) 0884 C MOVE '1' NFLAG 0885 C ELSE 0886 C MN(ML) IFEQ D1 0887 C MOVE A1 MN(ML) 0888 C MOVE '1' NFLAG 0889 C ELSE 0890 C MN(ML) IFEQ D2 0891 C MOVE A2 MN(ML) 0892 C MOVE '1' NFLAG 0893 C ELSE 0894 C MN(ML) IFEQ D3 0895 C MOVE A3 MN(ML) 0896 C MOVE '1' NFLAG 0897 C ELSE 0898 C MN(ML) IFEQ D4 0899 C MOVE A4 MN(ML) 0900 C MOVE '1' NFLAG 0901 C ELSE 0902 C MN(ML) IFEQ D5 0903 C MOVE A5 MN(ML) 0904 C MOVE '1' NFLAG 0905 C ELSE 0906 C MN(ML) IFEQ D6 0907 C MOVE A6 MN(ML) 0908 C MOVE '1' NFLAG 0909 C ELSE 0910 C MN(ML) IFEQ D7 0911 C MOVE A7 MN(ML) 0912 C MOVE '1' NFLAG 0913 C ELSE 0914 C MN(ML) IFEQ D8 0915 C MOVE A8 MN(ML) 0916 C MOVE '1' NFLAG 0917 C ELSE 0918 C MN(ML) IFEQ D9 0919 C MOVE A9 MN(ML) 0920 C MOVE '1' NFLAG 0921 C END 0922 C END 0923 C END 0924 C END 0925 C END 0926 C END 0927 C END 0928 C END 0929 C END 0930 C END 0931 C NFLAG IFEQ '1' 0932 C NP ANDGT 1 0933 C SUB 1 NP 0934 C MOVE MINUS MN(NP) 0935 C END 0936 C MOVEA MN(1) I(MP) 0937 C END 0938 C END 0939 C** 0940 C ENDSR 0941 C** 0942 C************************************************************** 0943 C/EJECT 0944 C************************************************************** 0945 C** 0946 C DECHEX BEGSR 0947 C** 0948 C* 0949 C** INITIALIZATION. 0950 C* 0951 C MOVE '0' HS 0952 C Z-ADD HDEC DV 10 0 0953 C Z-ADD 0 HC 0954 C* 0955 C** TRANSLATE HDEC TO BASE 16 & SET COUNTERS. 0956 C* 0957 C DV DOWGT 0 0958 C DV IFGE 268435456 0959 C SUB 268435456 DV 0960 C ADD 1 HC(1) 0961 C ELSE 0962 C DV IFGE 16777216 0963 C SUB 16777216 DV 0964 C ADD 1 HC(2) 0965 C ELSE 0966 C DV IFGE 1048576 0967 C SUB 1048576 DV 0968 C ADD 1 HC(3) 0969 C ELSE 0970 C DV IFGE 65536 0971 C SUB 65536 DV 0972 C ADD 1 HC(4) 0973 C ELSE 0974 C DV IFGE 4096 0975 C SUB 4096 DV 0976 C ADD 1 HC(5) 0977 C ELSE 0978 C DV IFGE 256 0979 C SUB 256 DV 0980 C ADD 1 HC(6) 0981 C ELSE 0982 C DV IFGE 16 0983 C SUB 16 DV 0984 C ADD 1 HC(7) 0985 C ELSE 0986 C DV IFGE 1 0987 C SUB 1 DV 0988 C ADD 1 HC(8) 0989 C END 0990 C END 0991 C END 0992 C END 0993 C END 0994 C END 0995 C END 0996 C END 0997 C END 0998 C* 0999 C** TRANSLATE BASE 16 COUNTERS TO HEXADECIMAL. 1000 C* 1001 C DO 8 HH 1 0 1002 C Z-ADD 0 HP 2 0 1003 C HC(HH) ADD 1 HP 1004 C MOVE H(HP) HS(HH) 1005 C END 1006 C* 1007 C** CREATE REVERSE HEX STRING(LOW-BYTE TO HIGH-BYTE). 1008 C* 1009 C MOVE HEX1 STG1 1010 C MOVE HEX2 STG2 1011 C MOVE HEX3 STG3 1012 C MOVE HEX4 STG4 1013 C* 1014 C** PRESET HEX BYTE(S) TO NULL. 1015 C* 1016 C MOVE NULL HEX 1017 C* 1018 C** TRANSLATE HEX STRING TO APPROPRIATE BITON(S). 1019 C* 1020 C DO 4 HX 1 0 1021 C MOVEA STG(HX) HBYT 1022 C Z-ADD 1 HY 2 0 1023 C HB01 LOOKUP H(HY) 10 1024 C *IN10 IFEQ '1' 1025 C 16 MULT T(HY) DD 3 0 1026 C END 1027 C Z-ADD 1 HY 1028 C HB02 LOOKUP H(HY) 10 1029 C *IN10 IFEQ '1' 1030 C ADD T(HY) DD 1031 C END 1032 C DD DOWGT 0 1033 C DD IFGE 128 1034 C SUB 128 DD 1035 C BITON '0' HEX(HX) 1036 C ELSE 1037 C DD IFGE 64 1038 C SUB 64 DD 1039 C BITON '1' HEX(HX) 1040 C ELSE 1041 C DD IFGE 32 1042 C SUB 32 DD 1043 C BITON '2' HEX(HX) 1044 C ELSE 1045 C DD IFGE 16 1046 C SUB 16 DD 1047 C BITON '3' HEX(HX) 1048 C ELSE 1049 C DD IFGE 8 1050 C SUB 8 DD 1051 C BITON '4' HEX(HX) 1052 C ELSE 1053 C DD IFGE 4 1054 C SUB 4 DD 1055 C BITON '5' HEX(HX) 1056 C ELSE 1057 C DD IFGE 2 1058 C SUB 2 DD 1059 C BITON '6' HEX(HX) 1060 C ELSE 1061 C DD IFGT 0 1062 C SUB 1 DD 1063 C BITON '7' HEX(HX) 1064 C END 1065 C END 1066 C END 1067 C END 1068 C END 1069 C END 1070 C END 1071 C END 1072 C END 1073 C END 1074 C** 1075 C ENDSR 1076 C** 1077 C************************************************************** C *INZSR BEGSR 0121 C *ENTRY PLIST 0122 C PARM FORMAT 10 0123 C PARM MEMBER 10 0124 C ERROR PARM ERROR ERROR 1 C* CALL 'TOL703' C endsr 1078 C/EJECT 1079 O************************************************************** 1080 O** 1081 O** O U T P U T 1082 O** 1083 O************************************************************** 1084 O** 1085 OOUTPUT EADD PUT 1086 O O 1087 O** 1088 O************************************************************** **CTDATA Q CRTPF FILE(QTEMP/XPRTFR) RCDLEN( ) OVRDBF FILE(OUTPUT) TOFILE(QTEMP/XPRTFR) OVRSCOPE(*JOB) OPNSCOPE(*JOB) **CTDATA T 00010203040506070809101112131415 **CTDATA H 0123456789ABCDEF