- 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 Feb 18, 2025@23:34:58 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