PRCHLO7 ;SSOI&TFO/LKG-EXTRACT ROUTINE (cont.) CLO REPORT SERVER ;2/17/11 16:39
;;5.1;IFCAP;**154**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
INVCOMPL ;Compile list of invoices within date range
K ^TMP($J,"PRCINVHDR"),^TMP($J,"PRCINVPAYT"),^TMP($J,"PRCINVFMS"),^TMP($J,"PRCINVCERTSVC")
N PRCI,PRCINV,PRCJ,PRCK,PRCNOD0,PRCNOD1,PRCNOD2,PRCNOD21,PRCPER,PRCPOIEN,PRCSTUB,PRCVIEN,PRCX
S PRCINV=0
F S PRCINV=$O(^PRCF(421.5,PRCINV)) Q:+PRCINV'=PRCINV D
. S PRCNOD0=$G(^PRCF(421.5,PRCINV,0)) Q:$P(PRCNOD0,U)'>0
. S PRCNOD2=$G(^PRCF(421.5,PRCINV,2)),PRCNOD21=$G(^(2.1))
. Q:$P(PRCNOD0,U,4)>CLOEND Q:$P(PRCNOD0,U,5)>CLOEND
. Q:$P(PRCNOD21,U,5)&($P(PRCNOD21,U,5)<CLOBGN) Q:$P($P(PRCNOD21,U,5),".")>CLOEND
. S PRCNOD1=$G(^PRCF(421.5,PRCINV,1)),PRCPOIEN=$P(PRCNOD0,U,7),PRCVIEN=$P(PRCNOD0,U,8)
. I $$GET1^DIQ(442,PRCPOIEN_",",.1,"I")<CLOBGN,$P(PRCNOD21,U,5)<CLOBGN,$P(PRCNOD0,U,5)<CLOBGN Q
. S PRCX=$P(PRCNOD0,U)_U_$P(PRCNOD1,U,2)_U_$S(PRCPOIEN>0:$$GET1^DIQ(442,PRCPOIEN_",",31),1:"")_U_MNTHYR_U_$P(PRCNOD0,U,3)_U_$$FMTE^XLFDT($P(PRCNOD0,U,4))
. S PRCX=PRCX_U_$$FMTE^XLFDT($P(PRCNOD0,U,5))_U_$$GET1^DIQ(442,PRCPOIEN_",",.01)_U_PRCPOIEN_U_$$GET1^DIQ(442,PRCPOIEN_",",.02)_U_$P(PRCNOD1,U,3)
. S PRCX=PRCX_U_$$GET1^DIQ(421.5,PRCINV_",",.6)_U_$$GET1^DIQ(421.5,PRCINV_",",4)
. S ^TMP($J,"PRCINVHDR",PRCINV,1)=PRCX_U
. S PRCX=$$GET1^DIQ(440,PRCVIEN_",",.01)_U_PRCVIEN_U_$$GET1^DIQ(440,PRCVIEN_",",34)_U_$$GET1^DIQ(440,PRCVIEN_",",35)_U_$$GET1^DIQ(440,PRCVIEN_",",18.3)
. S PRCX=PRCX_U_$P(PRCNOD0,U,12)_U_$$GET1^DIQ(421.5,PRCINV_",",11)_U_$$FMTE^XLFDT($P(PRCNOD0,U,21))_U_$S($P(PRCNOD0,U,14)'="":$FN($P(PRCNOD0,U,14)/100,"",2),1:"")
. S PRCX=PRCX_U_$S($P(PRCNOD0,U,15)'="":$FN($P(PRCNOD0,U,15)/100,"",2),1:"")
. S PRCX=PRCX_U_$$FMTE^XLFDT($P(PRCNOD1,U,4))_U_$$GET1^DIQ(421.5,PRCINV_",",25)_U_$P(PRCNOD1,U,6)_U_$P(PRCNOD1,U,7)
. S PRCX=PRCX_U_$S($P(PRCNOD1,U,8)'="":$FN($P(PRCNOD1,U,8)/100,"",2),1:"")
. S PRCX=PRCX_U_$S($P(PRCNOD1,U,9)'="":$FN($P(PRCNOD1,U,9)/100,"",2),1:"")
. S PRCX=PRCX_U_$$GET1^DIQ(421.5,PRCINV_",",50)_U_$P(PRCNOD2,U,2)_U_$P(PRCNOD2,U,3)_U_$P(PRCNOD2,U,4)_U_$TR($$FMTE^XLFDT($P(PRCNOD2,U,5)),"@"," ")
. S ^TMP($J,"PRCINVHDR",PRCINV,2)=PRCX_U
. S PRCPER=$P(PRCNOD2,U,17),PRCX=$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
. S PRCX=PRCX_U_$$FMTE^XLFDT($P(PRCNOD2,U,6))_U_$$FMTE^XLFDT($P(PRCNOD2,U,7))_U_$$FMTE^XLFDT($P(PRCNOD2,U,8))_U_$$FMTE^XLFDT($P(PRCNOD2,U,9))
. S PRCPER=$P(PRCNOD2,U,10),PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
. S PRCPER=$P(PRCNOD2,U,11) S PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
. S PRCX=PRCX_U_$$GET1^DIQ(421.5,PRCINV_",",61)_U_$TR($$FMTE^XLFDT($P(PRCNOD21,U,5)),"@"," ")_U_$$GET1^DIQ(421.5,PRCINV_",",62)_U_$TR($$FMTE^XLFDT($P(PRCNOD21,U,6)),"@"," ")
. S ^TMP($J,"PRCINVHDR",PRCINV,3)=PRCX_U
. S PRCX=$$GET1^DIQ(421.5,PRCINV_",",63)_U_$TR($$FMTE^XLFDT($P(PRCNOD2,U,15)),"@"," ")
. S PRCPER=$P(PRCNOD2,U,18) S PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)_U_$TR($$FMTE^XLFDT($P(PRCNOD21,U,9)),"@"," ")_U_$P(PRCNOD1,U,11)
. S PRCX=PRCX_U_$$FMTE^XLFDT($P(PRCNOD1,U,19))_U_$$FMTE^XLFDT($P(PRCNOD1,U,20))
. S ^TMP($J,"PRCINVHDR",PRCINV,4)=PRCX_U
. N PRCARRAY S PRCX=$$GET1^DIQ(421.5,PRCINV_",",23,"","PRCARRAY","PRCERR")
. S PRCI=0,PRCJ=4,PRCK=0
. F S PRCI=$O(PRCARRAY(PRCI)) Q:PRCI="" D
. . S PRCJ=PRCJ+1,^TMP($J,"PRCINVHDR",PRCINV,PRCJ)=$S(PRCK:" ",1:"")_$TR(PRCARRAY(PRCI),"^"),PRCK=PRCK+1
. K PRCARRAY
. S PRCSTUB=$P(PRCNOD0,U)_U_$P(PRCNOD1,U,2)_U_MNTHYR_U_U_$P(PRCNOD0,U,3)_U_$$GET1^DIQ(442,PRCPOIEN_",",.01)_U_PRCPOIEN
. D PAYTERMS(PRCINV,PRCSTUB)
. D FMSLINE(PRCINV,PRCSTUB)
. D CERTSVC(PRCINV,PRCSTUB)
Q
;
PAYTERMS(PRCID,PRCY) ;Compile Prompt Payment Terms for Invoice
N PRCJ,PRCPTNOD
S PRCJ=0
F S PRCJ=$O(^PRCF(421.5,PRCID,6,PRCJ)) Q:+PRCJ'=PRCJ D
. S PRCPTNOD=$G(^PRCF(421.5,PRCID,6,PRCJ,0)) Q:PRCPTNOD=""
. S PRCX=PRCY,$P(PRCX,U,4)=PRCJ
. S PRCX=PRCX_U_$P(PRCPTNOD,U)_U_$$GET1^DIQ(421.531,PRCJ_","_PRCID_",",1)_U_$P(PRCPTNOD,U,3)_U_$P(PRCPTNOD,U,4)_U_$P(PRCPTNOD,U,5)
. S ^TMP($J,"PRCINVPAYT",PRCID,PRCJ)=PRCX
Q
;
FMSLINE(PRCID,PRCY) ;Compile FMS Line Data
N PRCJ,PRCFMSND
S PRCJ=0
F S PRCJ=$O(^PRCF(421.5,PRCID,5,PRCJ)) Q:+PRCJ'=PRCJ D
. S PRCFMSND=$G(^PRCF(421.5,PRCID,5,PRCJ,0)) Q:PRCFMSND=""
. S PRCX=PRCY,$P(PRCX,U,4)=PRCJ
. S PRCX=PRCX_U_$P($$GET1^DIQ(421.541,PRCJ_","_PRCID_",",.01)," ")_U_$S($P(PRCFMSND,U,2)'="":$FN($P(PRCFMSND,U,2),"",2),1:"")_U_$S($P(PRCFMSND,U,3)'="":$FN($P(PRCFMSND,U,3),"",2),1:"")
. S PRCX=PRCX_U_$$GET1^DIQ(421.541,PRCJ_","_PRCID_",",3)_U_$P(PRCFMSND,U,5)
. S ^TMP($J,"PRCINVFMS",PRCID,PRCJ)=PRCX
Q
;
CERTSVC(PRCID,PRCY) ;Compile Certifying Service
N PRCJ,PRCPER,PRCSVCND
S PRCJ=0
F S PRCJ=$O(^PRCF(421.5,PRCID,3,PRCJ)) Q:+PRCJ'=PRCJ D
. S PRCSVCND=$G(^PRCF(421.5,PRCID,3,PRCJ,0)) Q:PRCSVCND=""
. S PRCX=PRCY,$P(PRCX,U,4)=PRCJ
. S PRCX=PRCX_U_$$GET1^DIQ(421.51,PRCJ_","_PRCID_",",.01)_U_$TR($$FMTE^XLFDT($P(PRCSVCND,U,2)),"@"," ")
. S PRCPER=$P(PRCSVCND,U,3)
. S PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
. S ^TMP($J,"PRCINVCERTSVC",PRCID,PRCJ)=PRCX
Q
;
INVOICEH ;Invoice Header
W "InvID^Stn^SubStn^MonthYrRun^InvNbr^InvDt^DtRec^POPtr^POIdNum^MOP^PONbr^"
W "CertReq^PPType^VendorNm^VendorIEN^VendFMSCode^VendAltI^DUNS^DiscDays^"
W "DiscTerms^DtSvcRec^AppShipAmt^AmtCertPay^DtSuspLtr^SusLtrReq^PartialNbr^"
W "FMSPayVoucher^GrossAmt^GrossShip^Status^POSuffix^ExpandedPO^CurrLoc^"
W "DtCurrLoc^ChargeLocNm^ChargeLocDuz^ChargeLocSvc^DiscPayDt^NetPayDt^"
W "DtDueFisc^DtRetFisc^CertPayNm^CertPayDuz^CertPaySvc^CompletedNm^"
W "CompletedDuz^CompletedSvc^CertValCode^CertDtTime^CompValCode^"
W "CompletedDtTime^BullSentYN^BullSentDt^CPCertNm^CPCertDuz^CPCertSvc^"
W "CPSignDt^CertCP^FMSTxnDt^AcctMY^SusReason",!
Q
INVOICEW ;Write Invoice Header Data
N PRCI,PRCJ
S PRCI="",PRCJ=""
F S PRCI=$O(^TMP($J,"PRCINVHDR",PRCI)) Q:+PRCI'=PRCI D
. F S PRCJ=$O(^TMP($J,"PRCINVHDR",PRCI,PRCJ)) Q:PRCJ="" W $G(^TMP($J,"PRCINVHDR",PRCI,PRCJ))
. W !
Q
;
INVPAYH ;Invoice Payment Terms Header
W "InvID^Stn^MonthYrRun^PPTIEN^InvNbr^POPtr^POIdNum^PPTNbr^TermsType^DiscPcnt^DiscAmt^DiscDays",!
Q
INVPAYW ;Write Payment Terms Data
N PRCI,PRCJ
S PRCI="",PRCJ=""
F S PRCI=$O(^TMP($J,"PRCINVPAYT",PRCI)) Q:+PRCI'=PRCI D
. F S PRCJ=$O(^TMP($J,"PRCINVPAYT",PRCI,PRCJ)) Q:PRCJ="" W $G(^TMP($J,"PRCINVPAYT",PRCI,PRCJ)),!
Q
;
INVFMSH ;FMS Line Header
W "InvID^Stn^MonthYrRun^FMSLIEN^InvNbr^PoPtr^POIdNum^BOC^AcctLnAmt^LiqAmt^LiqCode^FMSLNbr",!
Q
INVFMSW ;Write FMS Line Data
N PRCI,PRCJ
S PRCI="",PRCJ=""
F S PRCI=$O(^TMP($J,"PRCINVFMS",PRCI)) Q:+PRCI'=PRCI D
. F S PRCJ=$O(^TMP($J,"PRCINVFMS",PRCI,PRCJ)) Q:PRCJ="" W $G(^TMP($J,"PRCINVFMS",PRCI,PRCJ)),!
Q
;
CERTH ;Write Certifying Service Header
W "InvID^Stn^MonthYrRun^CertIEN^InvNbr^POPtr^POIdNum^CertSvc^DTChargeOUT^ChargeByName^ChargeByDuz^ChargeBySvc",!
Q
CERTW ;Write Certifying Service Data
N PRCI,PRCJ
S PRCI="",PRCJ=""
F S PRCI=$O(^TMP($J,"PRCINVCERTSVC",PRCI)) Q:+PRCI'=PRCI D
. F S PRCJ=$O(^TMP($J,"PRCINVCERTSVC",PRCI,PRCJ)) Q:PRCJ="" W $G(^TMP($J,"PRCINVCERTSVC",PRCI,PRCJ)),!
Q
;
INVHDR ;Create flat file for Invoice header #421.5
N OUTFL24
S OUTFL24="IFCP"_STID_"F24.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFL24,"W") ;Open the file
D USE^%ZISUTL("FILE1")
D INVOICEH
D INVOICEW
D CLOSE^%ZISH("FILE1")
Q
INVPAY ;Create flat file for Invoice payment Terms subfile #421.531
N OUTFL25
S OUTFL25="IFCP"_STID_"F25.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFL25,"W")
D USE^%ZISUTL("FILE1")
D INVPAYH
D INVPAYW
D CLOSE^%ZISH("FILE1")
Q
INVFMS ;Create flat file for Invoice FMS lines subfile #421.541
N OUTFL26
S OUTFL26="IFCP"_STID_"F26.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFL26,"W")
D USE^%ZISUTL("FILE1")
D INVFMSH
D INVFMSW
D CLOSE^%ZISH("FILE1")
Q
INVCERT ;Create flat file for Invoice Certifying Services subfile #421.51
N OUTFL27
S OUTFL27="IFCP"_STID_"F27.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFL27,"W")
D USE^%ZISUTL("FILE1")
D CERTH
D CERTW
D CLOSE^%ZISH("FILE1")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO7 8334 printed Sep 23, 2025@19:44:40 Page 2
PRCHLO7 ;SSOI&TFO/LKG-EXTRACT ROUTINE (cont.) CLO REPORT SERVER ;2/17/11 16:39
+1 ;;5.1;IFCAP;**154**;Oct 20, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
INVCOMPL ;Compile list of invoices within date range
+1 KILL ^TMP($JOB,"PRCINVHDR"),^TMP($JOB,"PRCINVPAYT"),^TMP($JOB,"PRCINVFMS"),^TMP($JOB,"PRCINVCERTSVC")
+2 NEW PRCI,PRCINV,PRCJ,PRCK,PRCNOD0,PRCNOD1,PRCNOD2,PRCNOD21,PRCPER,PRCPOIEN,PRCSTUB,PRCVIEN,PRCX
+3 SET PRCINV=0
+4 FOR
SET PRCINV=$ORDER(^PRCF(421.5,PRCINV))
if +PRCINV'=PRCINV
QUIT
Begin DoDot:1
+5 SET PRCNOD0=$GET(^PRCF(421.5,PRCINV,0))
if $PIECE(PRCNOD0,U)'>0
QUIT
+6 SET PRCNOD2=$GET(^PRCF(421.5,PRCINV,2))
SET PRCNOD21=$GET(^(2.1))
+7 if $PIECE(PRCNOD0,U,4)>CLOEND
QUIT
if $PIECE(PRCNOD0,U,5)>CLOEND
QUIT
+8 if $PIECE(PRCNOD21,U,5)&($PIECE(PRCNOD21,U,5)<CLOBGN)
QUIT
if $PIECE($PIECE(PRCNOD21,U,5),".")>CLOEND
QUIT
+9 SET PRCNOD1=$GET(^PRCF(421.5,PRCINV,1))
SET PRCPOIEN=$PIECE(PRCNOD0,U,7)
SET PRCVIEN=$PIECE(PRCNOD0,U,8)
+10 IF $$GET1^DIQ(442,PRCPOIEN_",",.1,"I")<CLOBGN
IF $PIECE(PRCNOD21,U,5)<CLOBGN
IF $PIECE(PRCNOD0,U,5)<CLOBGN
QUIT
+11 SET PRCX=$PIECE(PRCNOD0,U)_U_$PIECE(PRCNOD1,U,2)_U_$SELECT(PRCPOIEN>0:$$GET1^DIQ(442,PRCPOIEN_",",31),1:"")_U_MNTHYR_U_$PIECE(PRCNOD0,U,3)_U_$$FMTE^XLFDT($PIECE(PRCNOD0,U,4))
+12 SET PRCX=PRCX_U_$$FMTE^XLFDT($PIECE(PRCNOD0,U,5))_U_$$GET1^DIQ(442,PRCPOIEN_",",.01)_U_PRCPOIEN_U_$$GET1^DIQ(442,PRCPOIEN_",",.02)_U_$PIECE(PRCNOD1,U,3)
+13 SET PRCX=PRCX_U_$$GET1^DIQ(421.5,PRCINV_",",.6)_U_$$GET1^DIQ(421.5,PRCINV_",",4)
+14 SET ^TMP($JOB,"PRCINVHDR",PRCINV,1)=PRCX_U
+15 SET PRCX=$$GET1^DIQ(440,PRCVIEN_",",.01)_U_PRCVIEN_U_$$GET1^DIQ(440,PRCVIEN_",",34)_U_$$GET1^DIQ(440,PRCVIEN_",",35)_U_$$GET1^DIQ(440,PRCVIEN_",",18.3)
+16 SET PRCX=PRCX_U_$PIECE(PRCNOD0,U,12)_U_$$GET1^DIQ(421.5,PRCINV_",",11)_U_$$FMTE^XLFDT($PIECE(PRCNOD0,U,21))_U_$SELECT($PIECE(PRCNOD0,U,14)'="":$FNUMBER($PIECE(PRCNOD0,U,14)/100,"",2),1:"")
+17 SET PRCX=PRCX_U_$SELECT($PIECE(PRCNOD0,U,15)'="":$FNUMBER($PIECE(PRCNOD0,U,15)/100,"",2),1:"")
+18 SET PRCX=PRCX_U_$$FMTE^XLFDT($PIECE(PRCNOD1,U,4))_U_$$GET1^DIQ(421.5,PRCINV_",",25)_U_$PIECE(PRCNOD1,U,6)_U_$PIECE(PRCNOD1,U,7)
+19 SET PRCX=PRCX_U_$SELECT($PIECE(PRCNOD1,U,8)'="":$FNUMBER($PIECE(PRCNOD1,U,8)/100,"",2),1:"")
+20 SET PRCX=PRCX_U_$SELECT($PIECE(PRCNOD1,U,9)'="":$FNUMBER($PIECE(PRCNOD1,U,9)/100,"",2),1:"")
+21 SET PRCX=PRCX_U_$$GET1^DIQ(421.5,PRCINV_",",50)_U_$PIECE(PRCNOD2,U,2)_U_$PIECE(PRCNOD2,U,3)_U_$PIECE(PRCNOD2,U,4)_U_$TRANSLATE($$FMTE^XLFDT($PIECE(PRCNOD2,U,5)),"@"," ")
+22 SET ^TMP($JOB,"PRCINVHDR",PRCINV,2)=PRCX_U
+23 SET PRCPER=$PIECE(PRCNOD2,U,17)
SET PRCX=$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
+24 SET PRCX=PRCX_U_$$FMTE^XLFDT($PIECE(PRCNOD2,U,6))_U_$$FMTE^XLFDT($PIECE(PRCNOD2,U,7))_U_$$FMTE^XLFDT($PIECE(PRCNOD2,U,8))_U_$$FMTE^XLFDT($PIECE(PRCNOD2,U,9))
+25 SET PRCPER=$PIECE(PRCNOD2,U,10)
SET PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
+26 SET PRCPER=$PIECE(PRCNOD2,U,11)
SET PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
+27 SET PRCX=PRCX_U_$$GET1^DIQ(421.5,PRCINV_",",61)_U_$TRANSLATE($$FMTE^XLFDT($PIECE(PRCNOD21,U,5)),"@"," ")_U_$$GET1^DIQ(421.5,PRCINV_",",62)_U_$TRANSLATE($$FMTE^XLFDT($PIECE(PRCNOD21,U,6)),"@"," ")
+28 SET ^TMP($JOB,"PRCINVHDR",PRCINV,3)=PRCX_U
+29 SET PRCX=$$GET1^DIQ(421.5,PRCINV_",",63)_U_$TRANSLATE($$FMTE^XLFDT($PIECE(PRCNOD2,U,15)),"@"," ")
+30 SET PRCPER=$PIECE(PRCNOD2,U,18)
SET PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)_U_$TRANSLATE($$FMTE^XLFDT($PIECE(PRCNOD21,U,9)),"@"," ")_U_$PIECE(PRCNOD1,U,11)
+31 SET PRCX=PRCX_U_$$FMTE^XLFDT($PIECE(PRCNOD1,U,19))_U_$$FMTE^XLFDT($PIECE(PRCNOD1,U,20))
+32 SET ^TMP($JOB,"PRCINVHDR",PRCINV,4)=PRCX_U
+33 NEW PRCARRAY
SET PRCX=$$GET1^DIQ(421.5,PRCINV_",",23,"","PRCARRAY","PRCERR")
+34 SET PRCI=0
SET PRCJ=4
SET PRCK=0
+35 FOR
SET PRCI=$ORDER(PRCARRAY(PRCI))
if PRCI=""
QUIT
Begin DoDot:2
+36 SET PRCJ=PRCJ+1
SET ^TMP($JOB,"PRCINVHDR",PRCINV,PRCJ)=$SELECT(PRCK:" ",1:"")_$TRANSLATE(PRCARRAY(PRCI),"^")
SET PRCK=PRCK+1
End DoDot:2
+37 KILL PRCARRAY
+38 SET PRCSTUB=$PIECE(PRCNOD0,U)_U_$PIECE(PRCNOD1,U,2)_U_MNTHYR_U_U_$PIECE(PRCNOD0,U,3)_U_$$GET1^DIQ(442,PRCPOIEN_",",.01)_U_PRCPOIEN
+39 DO PAYTERMS(PRCINV,PRCSTUB)
+40 DO FMSLINE(PRCINV,PRCSTUB)
+41 DO CERTSVC(PRCINV,PRCSTUB)
End DoDot:1
+42 QUIT
+43 ;
PAYTERMS(PRCID,PRCY) ;Compile Prompt Payment Terms for Invoice
+1 NEW PRCJ,PRCPTNOD
+2 SET PRCJ=0
+3 FOR
SET PRCJ=$ORDER(^PRCF(421.5,PRCID,6,PRCJ))
if +PRCJ'=PRCJ
QUIT
Begin DoDot:1
+4 SET PRCPTNOD=$GET(^PRCF(421.5,PRCID,6,PRCJ,0))
if PRCPTNOD=""
QUIT
+5 SET PRCX=PRCY
SET $PIECE(PRCX,U,4)=PRCJ
+6 SET PRCX=PRCX_U_$PIECE(PRCPTNOD,U)_U_$$GET1^DIQ(421.531,PRCJ_","_PRCID_",",1)_U_$PIECE(PRCPTNOD,U,3)_U_$PIECE(PRCPTNOD,U,4)_U_$PIECE(PRCPTNOD,U,5)
+7 SET ^TMP($JOB,"PRCINVPAYT",PRCID,PRCJ)=PRCX
End DoDot:1
+8 QUIT
+9 ;
FMSLINE(PRCID,PRCY) ;Compile FMS Line Data
+1 NEW PRCJ,PRCFMSND
+2 SET PRCJ=0
+3 FOR
SET PRCJ=$ORDER(^PRCF(421.5,PRCID,5,PRCJ))
if +PRCJ'=PRCJ
QUIT
Begin DoDot:1
+4 SET PRCFMSND=$GET(^PRCF(421.5,PRCID,5,PRCJ,0))
if PRCFMSND=""
QUIT
+5 SET PRCX=PRCY
SET $PIECE(PRCX,U,4)=PRCJ
+6 SET PRCX=PRCX_U_$PIECE($$GET1^DIQ(421.541,PRCJ_","_PRCID_",",.01)," ")_U_$SELECT($PIECE(PRCFMSND,U,2)'="":$FNUMBER($PIECE(PRCFMSND,U,2),"",2),1:"")_U_$SELECT($PIECE(PRCFMSND,U,3)'="":$FNUMBER($PIECE(PRCFMSND,U,3),"",2),1:"")
+7 SET PRCX=PRCX_U_$$GET1^DIQ(421.541,PRCJ_","_PRCID_",",3)_U_$PIECE(PRCFMSND,U,5)
+8 SET ^TMP($JOB,"PRCINVFMS",PRCID,PRCJ)=PRCX
End DoDot:1
+9 QUIT
+10 ;
CERTSVC(PRCID,PRCY) ;Compile Certifying Service
+1 NEW PRCJ,PRCPER,PRCSVCND
+2 SET PRCJ=0
+3 FOR
SET PRCJ=$ORDER(^PRCF(421.5,PRCID,3,PRCJ))
if +PRCJ'=PRCJ
QUIT
Begin DoDot:1
+4 SET PRCSVCND=$GET(^PRCF(421.5,PRCID,3,PRCJ,0))
if PRCSVCND=""
QUIT
+5 SET PRCX=PRCY
SET $PIECE(PRCX,U,4)=PRCJ
+6 SET PRCX=PRCX_U_$$GET1^DIQ(421.51,PRCJ_","_PRCID_",",.01)_U_$TRANSLATE($$FMTE^XLFDT($PIECE(PRCSVCND,U,2)),"@"," ")
+7 SET PRCPER=$PIECE(PRCSVCND,U,3)
+8 SET PRCX=PRCX_U_$$GET1^DIQ(200,PRCPER_",",.01)_U_PRCPER_U_$$GET1^DIQ(200,PRCPER_",",29)
+9 SET ^TMP($JOB,"PRCINVCERTSVC",PRCID,PRCJ)=PRCX
End DoDot:1
+10 QUIT
+11 ;
INVOICEH ;Invoice Header
+1 WRITE "InvID^Stn^SubStn^MonthYrRun^InvNbr^InvDt^DtRec^POPtr^POIdNum^MOP^PONbr^"
+2 WRITE "CertReq^PPType^VendorNm^VendorIEN^VendFMSCode^VendAltI^DUNS^DiscDays^"
+3 WRITE "DiscTerms^DtSvcRec^AppShipAmt^AmtCertPay^DtSuspLtr^SusLtrReq^PartialNbr^"
+4 WRITE "FMSPayVoucher^GrossAmt^GrossShip^Status^POSuffix^ExpandedPO^CurrLoc^"
+5 WRITE "DtCurrLoc^ChargeLocNm^ChargeLocDuz^ChargeLocSvc^DiscPayDt^NetPayDt^"
+6 WRITE "DtDueFisc^DtRetFisc^CertPayNm^CertPayDuz^CertPaySvc^CompletedNm^"
+7 WRITE "CompletedDuz^CompletedSvc^CertValCode^CertDtTime^CompValCode^"
+8 WRITE "CompletedDtTime^BullSentYN^BullSentDt^CPCertNm^CPCertDuz^CPCertSvc^"
+9 WRITE "CPSignDt^CertCP^FMSTxnDt^AcctMY^SusReason",!
+10 QUIT
INVOICEW ;Write Invoice Header Data
+1 NEW PRCI,PRCJ
+2 SET PRCI=""
SET PRCJ=""
+3 FOR
SET PRCI=$ORDER(^TMP($JOB,"PRCINVHDR",PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:1
+4 FOR
SET PRCJ=$ORDER(^TMP($JOB,"PRCINVHDR",PRCI,PRCJ))
if PRCJ=""
QUIT
WRITE $GET(^TMP($JOB,"PRCINVHDR",PRCI,PRCJ))
+5 WRITE !
End DoDot:1
+6 QUIT
+7 ;
INVPAYH ;Invoice Payment Terms Header
+1 WRITE "InvID^Stn^MonthYrRun^PPTIEN^InvNbr^POPtr^POIdNum^PPTNbr^TermsType^DiscPcnt^DiscAmt^DiscDays",!
+2 QUIT
INVPAYW ;Write Payment Terms Data
+1 NEW PRCI,PRCJ
+2 SET PRCI=""
SET PRCJ=""
+3 FOR
SET PRCI=$ORDER(^TMP($JOB,"PRCINVPAYT",PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:1
+4 FOR
SET PRCJ=$ORDER(^TMP($JOB,"PRCINVPAYT",PRCI,PRCJ))
if PRCJ=""
QUIT
WRITE $GET(^TMP($JOB,"PRCINVPAYT",PRCI,PRCJ)),!
End DoDot:1
+5 QUIT
+6 ;
INVFMSH ;FMS Line Header
+1 WRITE "InvID^Stn^MonthYrRun^FMSLIEN^InvNbr^PoPtr^POIdNum^BOC^AcctLnAmt^LiqAmt^LiqCode^FMSLNbr",!
+2 QUIT
INVFMSW ;Write FMS Line Data
+1 NEW PRCI,PRCJ
+2 SET PRCI=""
SET PRCJ=""
+3 FOR
SET PRCI=$ORDER(^TMP($JOB,"PRCINVFMS",PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:1
+4 FOR
SET PRCJ=$ORDER(^TMP($JOB,"PRCINVFMS",PRCI,PRCJ))
if PRCJ=""
QUIT
WRITE $GET(^TMP($JOB,"PRCINVFMS",PRCI,PRCJ)),!
End DoDot:1
+5 QUIT
+6 ;
CERTH ;Write Certifying Service Header
+1 WRITE "InvID^Stn^MonthYrRun^CertIEN^InvNbr^POPtr^POIdNum^CertSvc^DTChargeOUT^ChargeByName^ChargeByDuz^ChargeBySvc",!
+2 QUIT
CERTW ;Write Certifying Service Data
+1 NEW PRCI,PRCJ
+2 SET PRCI=""
SET PRCJ=""
+3 FOR
SET PRCI=$ORDER(^TMP($JOB,"PRCINVCERTSVC",PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:1
+4 FOR
SET PRCJ=$ORDER(^TMP($JOB,"PRCINVCERTSVC",PRCI,PRCJ))
if PRCJ=""
QUIT
WRITE $GET(^TMP($JOB,"PRCINVCERTSVC",PRCI,PRCJ)),!
End DoDot:1
+5 QUIT
+6 ;
INVHDR ;Create flat file for Invoice header #421.5
+1 NEW OUTFL24
+2 SET OUTFL24="IFCP"_STID_"F24.TXT"
+3 ;Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFL24,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO INVOICEH
+6 DO INVOICEW
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
INVPAY ;Create flat file for Invoice payment Terms subfile #421.531
+1 NEW OUTFL25
+2 SET OUTFL25="IFCP"_STID_"F25.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFL25,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO INVPAYH
+6 DO INVPAYW
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
INVFMS ;Create flat file for Invoice FMS lines subfile #421.541
+1 NEW OUTFL26
+2 SET OUTFL26="IFCP"_STID_"F26.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFL26,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO INVFMSH
+6 DO INVFMSW
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
INVCERT ;Create flat file for Invoice Certifying Services subfile #421.51
+1 NEW OUTFL27
+2 SET OUTFL27="IFCP"_STID_"F27.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFL27,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO CERTH
+6 DO CERTW
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
