Here is an example of free...its a conversion program so some "stuff" hardcoded.
Code:
fHGQPGRP If E K DISK fHGQPMATL If E K DISK fHGQPPROC If E K DISK fHGQPPARM If E K DISK fHGQPVMSG If E K DISK fHGCIREL If E K DISK fHGQPDMSG If E K DISK fOERRPCSA If E K DISK fINMINVTB If E K DISK rename(INMINVTR:FormatB) fINMINVTX If E K DISK usropn fInDescA if e k disk fOEQOPDSA if e k disk fCICADLBD uf a e k disk rename(CICADLBR:D) prefix(D_) usropn fCIBCUSTOM if a E K DISK usropn fCIBCUSTOMAIf e k disk rename(CIBCUSTOMR:CUSTOMA) prefix(A) f usropn fCICADLB O E K DISK usropn fCIDSPEC O E K DISK usropn fCIHRELEAS O E K DISK usropn fXREF$PRC uf a e k disk usropn fNOPRICE O E K DISK usropn * * Program Info * d SDS d @PGM 1 10 d @PARMS 37 39 0 d @JOB 244 253 d @USER 254 263 d @JOB# 264 269 0 * * Definitions * d BurnInches s like(CCBRNIPP) d CmdLength s 15 5 d CmdString s 256 d Count s 5 0 d Dec3 s 3 0 d Fourfour s 4 4 d Freight s 7 2 d ISODate s d datfmt(*ISO) d LastPartName s 15 d LengthDec s 5 5 d NextPart# s 7 0 d OenCustomer s 5 0 d OenFrcCity s 16 d OenFrcState s 2 d OenInd s 1 d OenLotRate s 7 2 d OenRate s 7 2 d OenShipto s 5 0 d OenShpType s 1 d OenType s 1 inz('Q') d OenWeight s 7 0 d pseg s 1 d TheUnique s 28 d TheWeight s 10 4 d TimeStamp s z d ToThePenny s 9 2 d WidthDec s 5 5 d WorkCost s 7 2 d WorkSeq s 4 0 d WroteOne s 1 inz('N') * d keydupcheck s 62 d DupCheck s 62 dim(9999) d DC# s 4 0 d DC## s 4 0 * * Data structures * d ds d DsWidth 1 7 4 inz d DsWInch 1 3 d DsWFract 4 7 d ds d DsLength 1 9 4 inz d DsLFeet 1 2 d DsLInch 3 5 d DsLInchDec 3 5 0 d DsLFract 6 9 * d ds d WholeNumber 1 4 0 inz d Numerator 1 2 0 d Denominator 3 4 0 * * Procedure calls * d Command pr EXTPGM('QCMDEXC') d CmdString 256 d CmdLength 15 5 * d GetWeight pr EXTPGM('OENAH') d OenType 1 d OenWeight 7 0 d OenInd 1 d OenCustomer 5 0 d OenShipto 5 0 d OenShpType 1 d OenFrcCity 16 d OenFrcState 2 d OenRate 7 2 d OenLotRate 7 2 * /copy qprcsrc,CSTMKUP_CP * /free read HGQPGRP; dow not%eof(HGQPGRP); if QPGAFL = 'Y'; //if QPGPRT = 'APS917-1'; exsr $CibCustom; if lastpartname = *blanks; lastpartname = QPGPRT; endif; if lastpartname <> QPGPRT; clear dupcheck; clear DC#; lastpartname = QPGPRT; endif; //endif; endif; reset WroteOne; read HGQPGRP; enddo; if %open(CIBCUSTOM); close CIBCUSTOM; open CIBCUSTOM; endif; exsr $FixThePenny; exsr $Release; *inlr = *on; //========================================= // $CibCustom - Populate Cibcustom //========================================= begsr $CibCustom; clear CIBCUSTOMR; CBCURRENT = 'Y'; CBACTIVE = 'Y'; CBVERSION = 1; CBCOMP = 20; CBSL# = QPGACT; CBPART = QPGPRT; NextPart# += 1; CBPARTID = NextPart#; CBPARTD = QPGDSC; CBSPECN = QPGSPE; CBECHG1 = QPGEC1; CBECHG2 = QPGEC2; CBPRTREQ = QPGPFL; CBBUNT = 'CWT'; // // before the write loop thru the materials file to get bracket qtys // exsr $CrtUnique; setll (QPGACT:QPGPRT:QPGGRP) HGQPMATL; reade (QPGACT:QPGPRT:QPGGRP) HGQPMATL; dow not%eof(HGQPMATL); Dswidth = QPGDM1; Dslength = QPGDM2; setll (QPGPRD) INMINVTX; reade (QPGPRD) INMINVTX; dow not%eof(INMINVTX); CBRMAT = IMMAT; CBRANAL = IMANAL; CBRSIZE = IMSIZE; if IMLIN <> *blanks; if %dec(IMLIN:3:0) >= QPMSD2; leave; endif; endif; reade (QPGPRD) INMINVTX; enddo; chain (IMMAT) InDescA; if %found(InDescA); select; when IdSection = 'PLT'; pseg = 'P'; when IdSection = 'SHT'; Pseg = 'S'; when IdSection = 'EM '; Pseg = 'E'; when IdSection = 'GR '; Pseg = 'G'; other; Pseg = *blanks; endsl; endif; CBFWDIN = %dec(DsWInch:3:0); CBFWDFR = %dec(DsWFract:4:0); if pseg = *blanks; CBFLDFT = %div(DsLInchDec:12); CBFLDIN = %rem(DsLInchDec:12); CBFLDFR = %dec(DsLFract:4:0); else; CBFLDFT = *zeros; CBFLDIN = %dec(DsLInch:3:0); CBFLDFR = %dec(DsLFract:4:0); endif; // if QPGR1O = 'Y' and QPGR2I = *blanks then this is a circle if QPGR1o = 'Y' and QPGR2I = *blanks; CBRCIRC = 'C'; endif; CBRNUMFMT = 'D'; CBBWEIGHT = QPMWPP; CBAWEIGHT = QPGWPP; cbbrck# = QPMPCS; cbanluse = QPMEAU; cbunqkey = TheUnique; cbaddusr = @USER; cbastamp = %timestamp(); Dswidth = QPMSD1; Dslength = QPMSD2; cbyield = QPMPPS; cbbuyout = 'N'; cbnwdin = %dec(DsWInch:3:0); cbnwdfr = %dec(DsWFract:4:0); if pseg = *blanks; CBNLDFT = %div(DsLInchDec:12); CBNLDIN = %rem(DsLInchDec:12); CBNLDFR = %dec(DsLFract:4:0); else; CBNLDFT = *zeros; CBNLDIN = %dec(DsLInch:3:0); CBNLDFR = %dec(DsLFract:4:0); endif; // // If the cost is *zeros use replacement cost // setll (CBRMAT:CBRANAL:CBRSIZE) OERRPCSA; reade (CBRMAT:CBRANAL:CBRSIZE) OERRPCSA; dow not%eof(OERRPCSA); WorkCost = (ORRC + ORRCE); reade (CBRMAT:CBRANAL:CBRSIZE) OERRPCSA; enddo; if CBAWEIGHT > *zeros; cbucost = (100/CBAWEIGHT * QPMCPP); endif; if CBUCOST = *zeros; chain (20 : 20 : CBRMAT : CBRANAL : CBRSIZE) INMINVTB; if %found(INMINVTB); CBUCOST = IMSCST; endif; endif; write CIBCUSTOMR; exsr $Material; exsr $CicAdlb; exsr $Messages2; reade (QPGACT:QPGPRT:QPGGRP) HGQPMATL; enddo; endsr; //========================================= // $CicAdlb - write out the labor //========================================= begsr $CicAdlb; // // Write labor by selected part. // setll (QPMACT:QPMPRT:QPMGRP:QPMQSQ) HGQPPROC; reade (QPMACT:QPMPRT:QPMGRP:QPMQSQ) HGQPPROC; dow not%eof(HGQPPROC); clear CICADLBR; if (QPPSRT * 10) < 999; CCDSPSEQ = (QPPSRT * 10); else; CCDSPSEQ = 999; endif; CCSETTIM = QPPTST; CCHOURCST = QPPWAG; CCCOST = %dech(QPPCPP:9:2); CCUNITP = %dech(QPPPPP:7:2); chain (QPGACT:QPGPRT:QPGGRP:QPMQSQ:QPPPSQ) HGQPPARM; if %found(HGQPPARM); CCTORCH = QPTC; CCINTPR = QPPC; CCBRNIPP = QPBI; endif; select; when QPPPRC = 24200; CCLABCOD = 'SX'; when QPPPRC = 55; CCLABCOD = 'SC'; when QPPPRC = 19000; CCLABCOD = 'MC'; when QPPPRC = 23; CCLABCOD = 'BV'; when QPPPRC = 21100; CCLABCOD = 'BV'; when QPPPRC = 24050; CCLABCOD = 'CP'; when QPPPRC = 35; CCLABCOD = 'DB'; when QPPPRC = 26600; CCLABCOD = 'DR'; when QPPPRC = 21; CCLABCOD = 'FF'; when QPPPRC = 16205; CCLABCOD = 'MC'; when QPPPRC = 24962; CCLABCOD = 'FI'; when QPPPRC = 24600; CCLABCOD = 'LV'; when QPPPRC = 24961; CCLABCOD = 'BD'; when QPPPRC = 14400; CCLABCOD = 'SQ'; when QPPPRC = 14300; CCLABCOD = 'SC'; when QPPPRC = 40; CCLABCOD = 'LF'; when QPPPRC = 16200; CCLABCOD = 'MC'; when QPPPRC = 14200; CCLABCOD = 'SQ'; when QPPPRC = 14000; CCLABCOD = 'SC'; when QPPPRC = 29; CCLABCOD = 'NJ'; when QPPPRC = 24; CCLABCOD = 'BV'; when QPPPRC = 21000; CCLABCOD = 'BV'; when QPPPRC = 17000; select; when QPGLA = 152101; CCLABCOD = 'PO'; when QPGLA = 152102; CCLABCOD = 'WL'; when QPGLA = 152104; CCLABCOD = 'LP'; when QPGLA = 152105; CCLABCOD = 'MC'; when QPGLA = 152106; CCLABCOD = 'SC'; when QPGLA = 152201; CCLABCOD = 'GR'; when QPGLA = 152301; CCLABCOD = 'DR'; when QPGLA = 152401; CCLABCOD = 'PU'; when QPGLA = 152501; CCLABCOD = 'FA'; when QPGLA = 152601; CCLABCOD = 'HG'; when QPGLA = 152701; CCLABCOD = 'PT'; when QPGLA = 152801; CCLABCOD = 'LV'; when QPGLA = 152901; CCLABCOD = 'FM'; when QPGLA = 152931; CCLABCOD = 'ET'; other; CCLABCOD = '??'; endsl; when QPPPRC = 14; if QPGPFL <> 'Y'; CCLABCOD = 'FC'; else; CCLABCOD = 'FT'; endif; when QPPPRC = 24955; CCLABCOD = 'PK'; when QPPPRC = 24960; CCLABCOD = 'PM'; when QPPPRC = 15; CCLABCOD = 'FS'; when QPPPRC = 24000; CCLABCOD = 'FW'; when QPPPRC = 24800; CCLABCOD = 'ZZ'; when QPPPRC = 16000; CCLABCOD = 'PS'; when QPPPRC = 20; CCLABCOD = 'WL'; when QPPPRC = 26000; CCLABCOD = 'WL'; when QPPPRC = 26100; CCLABCOD = 'WR'; when QPPPRC = 24130; CCLABCOD = 'KS'; when QPPPRC = 15000; CCLABCOD = 'FL'; when QPPPRC = 26; CCLABCOD = 'XS'; when QPPPRC = 30002; CCLABCOD = 'RT'; when QPPPRC = 24100; CCLABCOD = 'KA'; when QPPPRC = 36; CCLABCOD = 'WD'; other; CCLABCOD = '**'; endsl; CCUNQKEY = cbunqkey; CCBRCK# = cbbrck#; CCVERSION = cbversion; CCTOTLTM = QPPTPP; CCTOOLCST = QPPTTC; CCFIXTCST = QPPTFC; chain (CCLABCOD) OEQOPDSA; if %found(OEQOPDSA); CCPRCGRP = OQPRCGRP; endif; if ccunitp > *zeros and ccunitp-cccost > *zeros; CCMARGIN = %dech(((ccunitp-cccost)/ccunitp) * 100 :3:0); endif; if QPPPRC = 17000; CCBUYOFLG = 'Y'; else; CCBUYOFLG = 'N'; endif; if CCBRNIPP = *zeros; exsr $BurnInches; endif; write CICADLBR; if CCUNITP = *zeros and CCCOST <> *zeros; write nopricer; endif; xxunqkey = CCUNQKEY; xxBRCK# = CCBRCK#; xxVERSION = CCVERSION; xxunitp = %dec(QPMSUP:7:2)+ QPMPVPP; write XREFR; //Messages by process setll (QPMACT:QPMPRT:QPMGRP:QPMQSQ:QPPPSQ) HGQPDMSG; reade (QPMACT:QPMPRT:QPMGRP:QPMQSQ:QPPPSQ) HGQPDMSG; dow not%eof(HGQPDMSG); keydupcheck = %editc(QPDACT:'X') + QPDPRT + QPDMSG + CCLABCOD; DC## = 1; DC## = %lookup(keydupcheck:dupcheck:DC##); if DC## = *zeros; DC# += 1; dupcheck(DC#) = keydupcheck; clear CIDSPECR; CDCOMP = 20; CDVERSION = 1; CDPART = QPMPRT; CDSL# = QPMACT; CDSH# = *zeros; CDLABCOD = CCLABCOD; CDLABSEQ = CCDSPSEQ; CDCOMM = QPDMSG; CDCOMSEQ = CCDSPSEQ; CDUNQKEY = CCUNQKEY; write CIDSPECR; endif; reade (QPMACT:QPMPRT:QPMGRP:QPMQSQ:QPPPSQ) HGQPDMSG; enddo; exsr $Messages; reade (QPMACT:QPMPRT:QPMGRP:QPMQSQ) HGQPPROC; enddo; endsr; //========================================= // $Releases - write out the releases //========================================= begsr $Release; read HGCIREL; dow not%eof(HGCIREL); clear CIHRELEASR; CHACCT = CRACCT; CHPART = CRPART; CHVERSION = 1; CHSHIPTO = CRSHIP; CHDUEDAT = CREWDW; CHSTRDAT = CRSWDW; CHEXPDAT = %uns(%char(%Date()+ %months(6) :*iso0)); CHPONM = CRPO; CHPOLINE = CRPOLN; CHFIRMFLG = CRFFLG; CHRELPCS = CRQTY; // // Entered by // CHENTDAT = %uns(%char(%Date():*ISO0)); CHENTTIM = %Uns( %Char( %Time( timeStamp ) : *HMS0 ) ); CHENTUSER = @USER; clear CHSHIPTO; chain (20 :CHACCT :CHSHIPTO :CHPART :1) CIBCUSTOMA; if %found(CIBCUSTOMA); CHUNQKEY = ACBUNQKEY; endif; write CIHRELEASR; read HGCIREL; enddo; endsr; //========================================= // $Material - Write material/freight //========================================= begsr $Material; for count = 1 to 3; clear CICADLBR; CCBRCK# = CBBRCK#; CCVERSION = CBVERSION; CCPRCGRP = 500; CCBUYOFLG = 'N'; select; when count = 1; CCDSPSEQ = 1; CCLABCOD = 'Z1'; CCUNITP = %dech(QPMPPP:7:2); select; when CBBUNT = 'CWT'; CCCOST = CBBWEIGHT/100 * CBUCOST; when CBBUNT = 'EA'or CBBUNT = 'EACH'; CCCOST = CBUCOST; endsl; when count = 2; CCLABCOD = 'Z3'; CCCOST = QPMPVPP; CCUNITP = QPMPVPP; CCDSPSEQ = 2; when count = 3; CCLABCOD = 'Z2'; OenWeight = (CBBWEIGHT * CBBRCK#); OenInd = 'I'; OenCustomer = CBSL#; OenShipto = CBSH#; OenShpType = *blanks; clear OenRate; clear OenLotRate; clear Freight; getweight(OenType : OenWeight : OenInd : OenCustomer : OenShipTo : OenShpType : OenFrcCity : OenFrcState : OenRate : OenLotRate); Freight = %dec(OenRate); CCCOST = Freight; if QPGWPP > *zeros; CCUNITP = %dech((QPMFPP/QPGWPP)*100:7:2); endif; CCDSPSEQ = 999; endsl; CCUNQKEY = CBUNQKEY; write CICADLBR; endfor; endsr; //========================================= // $CrtUnique - create unique ID //========================================= begsr $CrtUnique; ISODate = %Date(); TimeStamp = %Timestamp(); TheUnique = 'Cit' + %editc(@JOB#:'X') + %char( %Subdt(ISODate:*Years)) + %char( %Subdt(ISODate:*Months)) + %char( %Subdt(ISODate:*Days)) + %char( %Subdt(Timestamp:*Hours)) + %char( %Subdt(TimeStamp:*Minutes)) + %char( %Subdt(TimeStamp:*Seconds)) + %char( %Subdt(TimeStamp:*MS)); endsr; //========================================= // $BurnInches //========================================= begsr $BurnInches; clear WidthDec; if CBFWDFR <> *zeros; select; when CBRNUMFMT = 'D'; WidthDec = CBFWDFR/10000; when CBRNUMFMT = 'M'; fourfour = CBFWDFR/10000; WidthDec = fourfour/25.4; other; WholeNumber = CBFWDFR; if Denominator <> *zeros; WidthDec = %dech(Numerator/Denominator:5:5); endif; endsl; endif; clear LengthDec; if CBFLDFR <> *zeros; select; when CBRNUMFMT = 'D'; LengthDec = CBFLDFR/10000; when CBRNUMFMT = 'M'; fourfour = CBFWDFR/10000; LengthDec = fourfour/25.4; other; wholeNumber = CBFLDFR; if Denominator <> *zeros; LengthDec = %dech(Numerator/Denominator:5:5); endif; endsl; endif; BurnInches = %dech(((CBFWDIN + WidthDec) + ((CBFLDFT/12) + CBFLDIN + LengthDec))*2:5:1); CCBRNIPP = BurnInches; // get burn speed CCBURNSPD = QPBRNT; endsr; //========================================= // $Messages - if messages then write them //========================================= begsr $Messages; if Wroteone = 'N'; reset workseq; Setll (QPGACT:QPGPRT:QPPGRP:QPPQSQ:QPPPSQ) HGQPVMSG; reade (QPGACT:QPGPRT:QPPGRP:QPPQSQ:QPPPSQ) HGQPVMSG; dow not%eof(HGQPVMSG); clear CIDSPECR; cdversion = cbversion; cdcomp = cbcomp; cdpart = cbpart; cdsl# = cbsl#; cdsh# = cbsh#; cdlabcod = CCLABCOD; cdlabseq = CCDSPSEQ; cdcomm = QPVMSG; workseq += 1; cdcomseq = workseq; cdunqkey = cbunqkey; write CIDSPECR; WroteOne = 'Y'; reade (QPGACT:QPGPRT:QPPGRP:QPPQSQ:QPPPSQ) HGQPVMSG; enddo; endif; endsr; //========================================= // $Messages2 - write part messages // QPPPSQ = *zeros //========================================= begsr $Messages2; Setll (QPGACT:QPGPRT:QPPGRP:0:0) HGQPDMSG; reade (QPGACT:QPGPRT:QPPGRP:0:0) HGQPDMSG; dow not%eof(HGQPDMSG); keydupcheck = %editc(QPDACT:'X') + QPDPRT + QPDMSG + CCLABCOD; DC## = 1; DC## = %lookup(keydupcheck:dupcheck:DC##); if DC## = *zeros; DC# += 1; dupcheck(DC#) = keydupcheck; clear CIDSPECR; CDCOMP = 20; CDVERSION = 1; CDPART = QPPPRT; CDSL# = QPPACT; CDSH# = *zeros; CDLABCOD = *Blanks; CDLABSEQ = 0; CDCOMM = QPDMSG; CDCOMSEQ = CCDSPSEQ; CDUNQKEY = CCUNQKEY; write CIDSPECR; endif; reade (QPGACT:QPGPRT:QPPGRP:0:0) HGQPDMSG; enddo; endsr; //========================================= // $FixThePenny - Fix the pennies //========================================= begsr $FixThePenny; read CIBCUSTOM; dow not%eof(CIBCUSTOM); clear ToThePenny; setll (CBUNQKEY:CBVERSION:CBBRCK#) CICADLBD; reade(n) (CBUNQKEY:CBVERSION:CBBRCK#) CICADLBD; dow not%eof(CICADLBD); if D_CCLABCOD <> 'Z2'; ToThePenny += D_CCUNITP; else; TheWeight = %dech((D_CCUNITP/100 * CBAWEIGHT):9:2); ToThePenny += %dec(TheWeight:9:2); endif; reade(n) (CBUNQKEY:CBVERSION:CBBRCK#) CICADLBD; enddo; // get the steve selling price chain (CBUNQKEY:CBVERSION:CBBRCK#) XREF$PRC; if %found(XREF$PRC); // i know read it again for update if ToThePenny <> XXUNITP; setll (CBUNQKEY:CBVERSION:CBBRCK#) CICADLBD; reade (CBUNQKEY:CBVERSION:CBBRCK#) CICADLBD; dow not%eof(CICADLBD); if D_CCLABCOD = 'Z1'; select; when ToThePenny > XXUNITP; D_CCUNITP -= (ToThePenny - XXUNITP); Update D %Fields(D_CCUNITP); when ToThePenny < XXUNITP; D_CCUNITP += (XXUNITP - ToThePenny) ; Update D %Fields(D_CCUNITP); endsl; endif; reade (CBUNQKEY:CBVERSION:CBBRCK#) CICADLBD; enddo; endif; endif; read CIBCUSTOM; enddo; endsr; //========================================= // *inzsr - One time run subroutine. //========================================= begsr *inzsr; cmdstring = 'ovrdbf file(INMINVTX) tofile(PLTEST/INMINVTX)'; cmdlength = %len(%trim(cmdstring)); command(cmdstring : cmdlength); cmdstring = 'clrpfm customized/cibcustom'; cmdlength = %len(%trim(cmdstring)); command(cmdstring : cmdlength); cmdstring = 'clrpfm customized/cicadlb'; cmdlength = %len(%trim(cmdstring)); command(cmdstring : cmdlength); cmdstring = 'clrpfm customized/cidspec'; cmdlength = %len(%trim(cmdstring)); command(cmdstring : cmdlength); cmdstring = 'clrpfm xref$prc'; cmdlength = %len(%trim(cmdstring)); command(cmdstring : cmdlength); cmdstring = 'clrpfm cihreleas'; cmdlength = %len(%trim(cmdstring)); command(cmdstring : cmdlength); cmdstring = 'clrpfm noprice'; cmdlength = %len(%trim(cmdstring)); command(cmdstring : cmdlength); if not%open(INMINVTX); open INMINVTX ; endif; if not%open(CIBCUSTOM); open CIBCUSTOM; open CIBCUSTOMA; endif; if not%open(CICADLB); open CICADLB ; open CICADLBD; endif; if not%open(CIDSPEC); open CIDSPEC ; endif; if not%open(xref$prc); open xref$prc; endif; if not%open(cihreleas); open cihreleas; endif; if not%open(noprice); open noprice; endif; endsr; /end-free