* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Physical File Source * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * A* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * A* * "If it's squinky, then you know it's BrilligWare!" * * A* * * * A* * Source available at www.brilligware.com * * A* * Brillig Enterprises (aka Chris Pando) (C)2006 * * A* * * * A* * This work is licensed under a Creative Commons * * A* * Attribution-NonCommercial-ShareAlike License: * * A* * http://creativecommons.org/licenses/by-nc-sa/2.0/legalcode * * A* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * A* * * * A* * * Generic File Comparison * * * A* * * * A* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * A R CP1020 A TEXT('Generic File Comparison -+ A Exclusion File ') A AFRECTYP 10 A AFFLDNAM 10 A K AFRECTYP A K AFFLDNAM * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CL Source * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* "If it's squinky, then you know it's BrilligWare!" */ * * /* */ * * /* Source available at www.brilligware.com */ * * /* Brillig Enterprises (aka Chris Pando) (C)2006 */ * * /* */ * * /* This work is licensed under a Creative Commons */ * * /* Attribution-NonCommercial-ShareAlike License: */ * * /* http://creativecommons.org/licenses/by-nc-sa/2.0/legalcode */ * * /* */ /* */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Generic File Comparison */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ PGM PARM( &LIBRARY1 + &FILE1 + &MBR1 + &LIBRARY2 + &FILE2 + &MBR2 + &DESC ) DCL VAR(&FILE1 ) TYPE(*CHAR) LEN( 10) DCL VAR(&FILE2 ) TYPE(*CHAR) LEN( 10) DCL VAR(&LIBRARY1 ) TYPE(*CHAR) LEN( 10) DCL VAR(&LIBRARY2 ) TYPE(*CHAR) LEN( 10) DCL VAR(&MBR1 ) TYPE(*CHAR) LEN( 10) DCL VAR(&MBR2 ) TYPE(*CHAR) LEN( 10) DCL VAR(&DESC ) TYPE(*CHAR) LEN( 40) DCL VAR(&KEYFLD ) TYPE(*CHAR) LEN( 512) DCL VAR(&OPNQRYF1 ) TYPE(*CHAR) LEN(1024) DCL VAR(&OPNQRYF2 ) TYPE(*CHAR) LEN(1024) DCL VAR(&EOF ) TYPE(*LGL ) LEN( 1) DCL VAR(&CMDLEN ) TYPE(*DEC ) LEN(15 5) VALUE(1024) DCL VAR(&ERRFLG ) TYPE(*LGL ) LEN( 1) VALUE('0') DCL VAR(&MSGDTA ) TYPE(*CHAR) LEN( 512) DCL VAR(&MSGID ) TYPE(*CHAR) LEN( 7) DCL VAR(&MSGF ) TYPE(*CHAR) LEN( 10) DCL VAR(&MSGFLIB ) TYPE(*CHAR) LEN( 10) DCL VAR(&RTNTYPE ) TYPE(*CHAR) LEN( 2) DCLF FILE(DSPFD) MONMSG MSGID(CPF0000) EXEC(GOTO ERROR) DSPFD FILE(&LIBRARY1/&FILE1) TYPE(*ACCPTH) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFD) DSPFFD FILE(&LIBRARY1/&FILE1) OUTPUT(*OUTFILE) + OUTFILE(QTEMP/DSPFFD) OVRDBF FILE(INPUT1) TOFILE(&LIBRARY1/&FILE1) MBR(&MBR1) SHARE(*YES) OVRDBF FILE(INPUT2) TOFILE(&LIBRARY2/&FILE2) MBR(&MBR2) SHARE(*YES) OPNQRYF FILE((INPUT1)) KEYFLD(*FILE) OPNQRYF FILE((INPUT2)) KEYFLD(*FILE) /* */ /* Call the program */ /* */ CALL PGM(CP1030R) PARM(&LIBRARY1 &FILE1 &MBR1 + &LIBRARY2 &FILE2 &MBR2 + &DESC ) /* */ /* Housecleaning */ /* */ CLOF OPNID(INPUT1) CLOF OPNID(INPUT2) DLTOVR FILE(INPUT1) DLTOVR FILE(INPUT2) RETURN /* */ /* Error Handling */ /* */ ERROR: IF COND(� &ERRFLG) THEN(DO) CHGVAR VAR(&ERRFLG) VALUE('1') RCLRSC ETAG: RCVMSG PGMQ(*SAME) MSGTYPE(*EXCP) MSGDTA(&MSGDTA) + MSGID(&MSGID) RTNTYPE(&RTNTYPE) + MSGF(&MSGF) MSGFLIB(&MSGFLIB) IF COND(&MSGID *NE ' ') THEN(DO) SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) + MSGDTA(&MSGDTA) TOPGMQ(*PRV) MSGTYPE(*ESCAPE) GOTO CMDLBL(ETAG) ENDDO ENDDO RETURN ENDPGM * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ILE/RPG Source * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * "If it's squinky, then you know it's BrilligWare!" * * * * * * * * Source available at www.brilligware.com * * * * Brillig Enterprises (aka Chris Pando) (c)2006 * * * * * * * * This work is licensed under a Creative Commons * * * * Attribution-NonCommercial-ShareAlike License: * * * * http://creativecommons.org/licenses/by-nc-sa/2.0/legalcode * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Generic File Comparison * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * h dftActGrp(*No) actGrp(*Caller) bndDir('QC2LE') * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ... files ... * * * c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * fcp1030f if e k disk finput1 if f 768 disk finput2 if f 768 disk fqsysprt o f 132 printer OflInd(*InOF) * * ... dspffd must exist at compile time. It has the same format * as the outfile from the DSPFFD command ... * fdspffd if e disk * * ... dspfd must exist at compile time. It has the same format * as the outfile from the DSPFD *ACCPTH command ... * fdspfd if e disk * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ... procedure interfaces ... * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * d cp1030r pr d file1Lib 10a d file1Nam 10a d file1Mbr 10a d file2Lib 10a d file2Nam 10a d file2Mbr 10a d description 32a d cp1030r pi d file1Lib 10a d file1Nam 10a d file1Mbr 10a d file2Lib 10a d file2Nam 10a d file2Mbr 10a d description 32a /EJECT * * internal procedures * d bldHeaders pr d center pr d * Const d 10i 0 Const d compDta pr 10i 0 d compKey pr 10i 0 d cvtPacked pr 30p 0 d * Const d 10i 0 Const d left pr d right pr d both pr d getClcLen pr 10i 0 d init pr d hndlNoErr pr d loadArrays pr d loadFld pr d OFLogic pr d prtDta pr d prtKey pr d * Const d putFld pr d * Const d 10i 0 Const d read1 pr d read2 pr * * external procedures (from the C run-time library) * d memcmp pr 10i 0 ExtProc('memcmp') d * Value d * Value d 10i 0 Value d memcpy pr ExtProc('memcpy') d * Value d * Value d 10i 0 Value d memmove pr ExtProc('memmove') d * Value d * Value d 10i 0 Value d memset pr ExtProc('memset') d * Value d 10i 0 Value d 10i 0 Value * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ... data structures ... * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * dbuffer1ds ds 768 d buffer1 1a dim( 768) dbuffer2ds ds 768 d buffer2 1a dim( 768) d ds d timer 1 12s 0 d hhmmss 6s 0 Overlay(timer:1) d mmddyy 6s 0 Overlay(timer:7) /EJECT * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ... standalone variables ... * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * d hdr1 s 1a dim(132) d hdr2 s 1a dim(132) d detail s 1a dim(132) d fldNam s 10a dim(256) Inz(' ') Field Name d fldOff s 5p 0 dim(256) Inz(0) Field Offset (buffer d fldLnB s 10i 0 dim(256) Inz(0) Field Length (buffer d fldLnO s 10i 0 dim(256) Inz(0) Field Length (output d fldDLn s 10i 0 dim(256) Inz(0) Field Length (descri d fldTyp s 1a dim(256) Inz(' ') Field Type d fldPut s 5p 0 dim(256) Inz(0) Offset (output buffe d fldChg s 1n dim(256) Offset (output buffe d fldKSq s 1a dim(256) Field Length d refNam s 10a Dim(256) d refOff s 5s 0 Dim(256) d refLen s 5s 0 Dim(256) d refDgt s 2s 0 Dim(256) d refTyp s 1a Dim(256) d refKSq s dim(256) Like(fldKSq) d @bfr1@ s * Dim(256) d @bfr2@ s * Dim(256) d keyCnt s 5p 0 Key Field Count d dtaCnt s 5p 0 Data Field Count d testVar s 10i 0 d $I s 5p 0 d $J s 5p 0 d $K s 5p 0 d fldCnt s 5p 0 d errorFnd s n Inz(*Off) d prtFilNam s n Inz(*On) d lftFilNam s 32a d rghFilNam s 32a d memcmpstr s 10i 0 d before s 6a Inz('Before') d after s 5a Inz('After') d fldn s 6a Inz('FldNam') d fldChg@ s * Inz(%Addr(fldChg)) Offset (output buffe * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ... constants ... * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * d EQUAL c 0 d PACKED c 'P' d EDITWORD c ' 0 -' d SPLATBLANK c ' ' d EQUALSIGN c x'7E' d DASHSIGN c x'60' d ASCENDING c 'A' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Mainline * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * /free init(); read1(); read2(); DoW (Not %Eof(input1) Or Not %Eof(input2)); testVar = compKey(); Select; When ( testVar < EQUAL ); left(); read1(); When ( testVar > EQUAL ); right(); read2(); When ( testVar = EQUAL ); If ( compDta() <> EQUAL ); both(); EndIf; read1(); read2(); EndSl; EndDo; hndlNoErr(); Return; /end-free C KeyList KList C Kfld file1Nam c Kfld afFLDNAM * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ... "O" specs ... * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * oqsysprt e header1 01 o 6 'CP1030' o 76 'Compare/Contrast Files' o mmddyy 132 ' 0/ / ' o e header1 02 04 o 6 'Page: ' o Page Z 15 o description 81 o hhmmss 132 ' 0: : ' o e header2 0 1 o 11 'Left File: ' o lftFilNam 44 o e header2 0 2 o 11 'Right File:' o rghFilNam 44 o e header3 0 0 o hdr1 o e header3 1 o hdr2 o e detail1 1 o detail o e detail2 1 o detail o e noErrors 2 o '**** Identical Files ****' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Procedures * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * load arrays with field offsets and lengths (both key and data) * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p loadArrays b d pi d arrIndex s 3s 0 /free // // first load information from DSPFFD // fldCnt = 0; Read dspffd; DoW ( Not %Eof(dspffd) ); fldCnt = fldCnt + 1; refNam(fldCnt) = whFLDI; refOff(fldCnt) = whFOBO; refLen(fldCnt) = whFLDB; refDgt(fldCnt) = whFLDD; refTyp(fldCnt) = whFLDT; Read dspffd; EndDo; // // now load key fields // Read dspfd; DoW (Not %Eof(dspfd)); $J = %Lookup( APKEYF : refNam : 1 : fldCnt ); // not testing for failure loadFld(); keyCnt = keyCnt + 1; fldKSq($I) = apKSEQ; // ascending or descending Read dspfd; EndDo; // // and, finally, load all data fields *not* in cp1030f // For $J = 1 to fldCnt; $K = %Lookup( refNam($J) : fldNam : 1 : keyCnt ); // key fields already loaded If ( $K = 0 ); afFLDNAM = refNam($J); SetLL keyList cp1030f; If ( Not %Equal(cp1030f) ); loadFld(); dtaCnt = dtaCnt + 1; EndIf; EndIf; EndFor; *InLR = *On; /end-free p loadArrays e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * load global field arrays * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p loadFld b /free $I = $I + 1; fldNam($I) = refNam($J); fldOff($I) = refOff($J); fldLnB($I) = refLen($J); @bfr1@($I) = %Addr(buffer1) + fldOff($I) - 1; @bfr2@($I) = %Addr(buffer2) + fldOff($I) - 1; fldTyp($I) = refTyp($J); Select; When (fldTyp($I) = PACKED); fldLnO($I) = refDgt($J); Other; fldLnO($I) = refLen($J); EndSl; // Length of output is the greater of field & desc length fldDLn($I) = %Scan( SPLATBLANK : fldNam($I) ) - 1; If (fldDLn($I) <= 0); fldDLn($I) = %Size(fldNam); EndIf; Return; /end-free p loadFld e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * initialisation * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p init b c Time timer /free center( %Addr(description) : %Len(description) ); lftFilNam = %trimR(file1Lib) + '/' + %TrimR(file1Nam) + '.' + file1Mbr; rghFilNam = %trimR(file2Lib) + '/' + %TrimR(file2Nam) + '.' + file2Mbr; loadArrays(); bldHeaders(); *InLR = *On; *InOF = *On; Return; /end-free p init e /EJECT * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * build report headers * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p bldHeaders b d pi d clcLen s 10i 0 d $J s 5p 0 Inz(3) output starts in 3rd d $K s 5p 0 Inz(3) output starts in 3rd /free // // key field header information // for $I = 1 to keyCnt; fldPut($I) = $J; clcLen = getClcLen(); memcpy( %Addr(hdr1($J)) : %Addr(fldNam($I)) : 6 ); memset( %Addr(hdr2($J)) : EQUALSIGN : clcLen ); $J = $J + clcLen + 1; EndFor; // // data field headers // $K = (132 - $J - 8)/2; fldPut($I) = $J; memcpy( %Addr(hdr1($J)) : %Addr(fldn) : 6 ); memset( %Addr(hdr2($J)) : DASHSIGN : 6 ); $J = $J + 7; $I = $I + 1; fldPut($I) = $J; memcpy( %Addr(hdr1($J)) : %Addr(before) : %Size(before) ); memset( %Addr(hdr2($J)) : DASHSIGN : $K ); $J = $J + $K + 1; $I = $I + 1; fldPut($I) = $J; memcpy( %Addr(hdr1($J)) : %Addr(after) : %Size(after) ); memset( %Addr(hdr2($J)) : DASHSIGN : $K ); Return; /end-free p bldHeaders e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * read from first file * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p read1 b d pi /free Read input1 buffer1ds; If (%Eof(input1)); // if eof, then load key fields with high values For $I = 1 to keyCnt; memset( %Addr(buffer1(fldOff($I))) : x'FF' : fldLnB($I) ); EndFor; EndIf; Return; /end-free p read1 e /EJECT * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * read from second file * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p read2 b d pi /free Read input2 buffer2ds; If (%Eof(input2)); // if eof, then load key fields with high values For $I = 1 to keyCnt; memset( %Addr(buffer2(fldOff($I))) : x'FF' : fldLnB($I) ); EndFor; EndIf; Return; /end-free p read2 e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * when first record key is less than second * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p left b d pi /free OFLogic(); detail = *Blanks; prtKey( %Addr(buffer1) ); detail(1) = 'L'; Except detail1; errorFnd = *On; Return; /end-free p left e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * when first record key is greater than second * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p right b d pi /free OFLogic(); detail = *Blanks; prtKey( %Addr(buffer2) ); detail(1) = 'R'; Except detail1; errorFnd = *On; Return; /end-free p right e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * keys equal but data different * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p both b d pi /free OFLogic(); detail = *Blanks; prtKey( %Addr(buffer1) ); Except detail1; prtDta(); errorFnd = *On; Return; /end-free p both e /EJECT * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * compare keys * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p compKey b d pi 10i 0 /free $I = 0; DoU ($I = keyCnt Or memcmpstr <> 0); $I = $I + 1; memcmpstr = memcmp( @bfr1@($I) : @bfr2@($I) : fldLnB($I) ); EndDo; If ( fldKSq($I) = ASCENDING ); Return memcmpstr; Else; Return (memcmpstr * -1); // flip for descending key fields EndIf; Return memcmpstr; /end-free p compKey e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * compare data * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p compDta b d pi 10i 0 d chgFlg s 1n Inz(*Off) /free memset( fldChg@ : x'F0' : fldCnt ); For $I = keyCnt + 1 to keyCnt + dtaCnt; memcmpstr = memcmp( @bfr1@($I) : @bfr2@($I) : fldLnB($I) ); If ( memcmpstr <> EQUAL ); chgFlg = *On; fldChg($I) = *On; EndIf; EndFor; If ( chgFlg ); Return -1; Else; Return 0; EndIf; /end-free p compDta e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Overflow Logic * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p OFLogic b d pi /free If (*InOF); Except header1; If (prtFilNam); Except header2; prtFilNam = *Off; EndIf; Except header3; *InOF = *Off; EndIf; Return; /end-free p OFLogic e /EJECT * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * No Errors * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p hndlNoErr b d pi /free If (Not errorFnd); Except Header1; Except Header2; Except Header3; Except noErrors; EndIf; Return; /end-free p hndlNoErr e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * transfer key information to output buffer * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p prtKey b d pi D buffer@ * Const /free For $I = 1 to keyCnt; putFld( buffer@ : $I ); EndFor; Return; /end-free p prtKey e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * transfer data information to output buffer * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p prtDta b d pi /free For $I = keyCnt + 1 to keyCnt + dtaCnt; If ( fldChg($I) ); detail = *Blanks; memcpy( %Addr(detail(fldPut(keyCnt + 1))) : %Addr(fldNam($I)) : 6 ); putFld( %Addr(buffer1) : keyCnt + 2 // ugly, before field ); putFld( %Addr(buffer2) : keyCnt + 3 // ugly, after field ); Except detail2; EndIf; EndFor; Return; /end-free p prtDta e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * center * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p center b d pi d @ * Const description pointer d fldLen 10i 0 Const description length d char s 1a Based(l@) test character d l@ s * left pointer d r@ s * right pointer d moveCnt s 3u 0 /free l@ = @ + fldLen - 1; r@ = l@; DoW (@ <= l@ and char = *Blank); l@ = l@ - 1; EndDo; Select; // I certainly could have done: When (l@ < @); // // All blanks // If ( (l@ >= @) And (l@ < (r@ -1)) ); When (l@ = r@); // // No blanks // but that is not nearly as 'self-documenting'. Besides When (l@ = r@ - 1); // how often does a center routine execute // One blank Other; moveCnt = %Div( r@ - l@ : 2 ); memmove( @ + moveCnt : @ : l@ - @ + 1 ); memset( @ : x'40' : moveCnt ); EndSl; Return; /end-free p center e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * get display length * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p getClcLen b d pi 10i 0 D fldLen s 10i 0 /free If ( fldLnO($I) >= fldDLn($I) ); fldLen = fldLnO($I); Else; fldLen = fldDLn($I); EndIf; If ( %Len(%Trim(fldNam($I))) > fldLen ); Return %Len(%Trim(fldNam($I))); Else; Return fldLen; EndIf; /end-free p getClcLen e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * convert packed value to signed * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p cvtPacked b d pi 30p 0 d ptr * Const d fldLen 10i 0 Const d ds Based(ptr) d packed01 1 1p 0 d packed02 1 2p 0 d packed03 1 3p 0 d packed04 1 4p 0 d packed05 1 5p 0 d packed06 1 6p 0 d packed07 1 7p 0 d packed08 1 8p 0 d packed09 1 9p 0 d packed10 1 10p 0 d packed11 1 11p 0 d packed12 1 12p 0 d packed13 1 13p 0 d packed14 1 14p 0 d packed15 1 15p 0 d packed16 1 16p 0 PackEven /free Select; When (fldLen = 1); Return packed01; When (fldLen = 2); Return packed02; When (fldLen = 3); Return packed03; When (fldLen = 4); Return packed04; When (fldLen = 5); Return packed05; When (fldLen = 6); Return packed06; When (fldLen = 7); Return packed07; When (fldLen = 8); Return packed08; When (fldLen = 9); Return packed09; When (fldLen = 10); Return packed10; When (fldLen = 11); Return packed11; When (fldLen = 12); Return packed12; When (fldLen = 13); Return packed13; When (fldLen = 14); Return packed14; When (fldLen = 15); Return packed15; When (fldLen = 16); Return packed16; Other; Return packed16; EndSl; /end-free p cvtPacked e * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * convert packed value to signed * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * p putFld b d pi d @ * Const d put 10i 0 Const d alpha s 30a /free If (fldTyp($I) = PACKED); alpha = %EditW( cvtPacked( @ + fldOff($I) - 1 : fldLnB($I) ) : EDITWORD ); memcpy( %Addr(detail(fldPut(put))) : %Addr(alpha) + %Len(alpha) - fldLnO($I) : fldLnO($I) ); Else; memcpy( %Addr(detail(fldPut(put))) : @ + fldOff($I) - 1 : fldLnO($I) ); EndIf; // // if description longer than field, then center // If (fldDLn($I) > fldLnO($I)); center( %Addr(detail(fldPut(put))) : fldDLn($I) ); EndIf; Return; /end-free p putFld e