- PRCHLO1 ;WOIFO/RLL-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ;5/22/09 14:10
- ;;5.1;IFCAP;**83,130**;Oct 20, 2000;Build 25
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ; DBIA 10093 - Read file 49 via FileMan.
- ; Continuation of PRCHLO1. This program builds the extracts for
- ; the Master PO Table and the associated multiples
- POMAST ; PoMaster Table
- Q
- PODISCW ; Write PO Discount table data
- N GPOID,GPOND
- S GPOID=0,GPOND=""
- F S GPOID=$O(^TMP($J,"PODISC",GPOID)) Q:GPOID="" D
- . F S GPOND=$O(^TMP($J,"PODISC",GPOID,GPOND)) Q:GPOND="" D
- . . W $G(^TMP($J,"PODISC",GPOID,GPOND))
- . . W !
- . . Q
- . Q
- Q
- GPOMAST ; get PO Master record
- S U="^"
- N N0,N1,N7,N12,N16,N23,PONUMB,STNUMB,PODAT,PPOKEY
- N PAPAB,PAPAB1,AGAPO,AGAPO1,PCHDR,PCHDR1,PCUSR,PCUSR1,POIDC,PRCVAL
- N VL1,VL6,VL7,VL8,VL9,VL10,VL11,VL12,VL13,VL14,VL15,VL16,VL17,VL18
- N VL19,VL20,VL21,VL22,VL23,VL24,VL25,VL26,VL27,VL28,VL29,VL30,VL31
- N VL32,VL33,VL34,VL35,VL36,VL37,VL38,VL39,VL40,VL41
- N GN0,GN0A,GN0B,GN1,GN1A,GN2,VN,VN1,VN2
- N VL6E,VL6E1,VL6E2,VL7E,VL7E1,VL7E2,VL8E,VL8E1,VL8E2,VL10E,VL10E1
- N VL10E2,VL21E,VL21E1,VL21E2,VL25E,VL25E1,VL25E2,VL35E,VL35E1,VL35E2
- N VL16E,VL16E1,VL16E2,VL18E,VL18E1,VL18E2,VL33E,VL33E1,VL33E2
- N VL34E,VL34E1,VL34E2,PC2237V,PC2237V1,EXDT,EXDT1,EXDT2
- S N0=$G(^PRC(442,POID,0))
- S N1=$G(^PRC(442,POID,1))
- S N7=$G(^PRC(442,POID,7))
- S N12=$G(^PRC(442,POID,12))
- S N16=$G(^PRC(442,POID,16))
- S N23=$G(^PRC(442,POID,23))
- S PONUMB=$P(N0,U,1),STNUMB=$P(PONUMB,"-",1)
- S EXDT=$P(N1,U,15)
- I EXDT="" S EXDT=POCRDAT ; if PO Date "" use x-ref date value for PO
- S EXDT1=$P(EXDT,".",1)
- S EXDT2=$$FMTE^XLFDT(EXDT1)
- S PODAT=EXDT2 ; needed for key
- S PPOKEY=POID_U_PONUMB_U_PODAT_U_MNTHYR_U_STNUMB
- ;
- ; The 1st 5 values in PPOKEY above are included in each record
- ;
- S VL6E=$P(N0,U,12),VL6E1=$G(^PRCS(410,+VL6E,0)),VL6E2=$P(VL6E1,U,1)
- S VL6=VL6E2 ; Prim2237
- S VL7E=$P(N0,U,2),VL7E1=$G(^PRCD(442.5,+VL7E,0)),VL7E2=$P(VL7E1,U,1)
- S VL7=VL7E2 ; meth.of proc
- S VL8E=$P(N1,U,19),VL8E1=$G(^PRC(443.8,+VL8E,0)),VL8E2=$P(VL8E1,U,2)
- S VL8=VL8E2 ; locProcRsnCode
- S VL9=$P(N1,U,18) ; exp/non-exp
- S VL10E=$P(N7,U,1),VL10E1=$G(^PRCD(442.3,+VL10E,0))
- S VL10E2=$P(VL10E1,U,1)
- S VL10=VL10E2 ; Supply status
- S VL11=$P(N7,U,2) ; Sup Stat Order
- S VL12=$P(N7,U,4) ;Fis Stat Order
- S VL13=$P(N0,U,3) ;FCP
- S VL14=$P(N0,U,4) ;Appropriation
- S VL15=$P(N0,U,5) ;CostCenter
- S VL16E=$P(N0,U,6),VL16E1=$G(^PRCD(420.2,+VL16E,0))
- S VL16E2=$P(VL16E1,U,1)
- S VL16=VL16E2 ;SubAcct1
- S VL17=$P(N0,U,7) ;SubAmt1
- S VL18E=$P(N0,U,8),VL18E1=$G(^PRCD(420.2,+VL18E,0))
- S VL18E2=$P(VL18E1,U,1)
- S VL18=VL18E2 ;SubAcct2
- S VL19=$P(N0,U,9) ;SubAmt2
- ; set Node 0 of ^TMP
- S GN0=PPOKEY_U_VL6_U_VL7_U_VL8_U_VL9_U_VL10_U
- S GN0A=GN0_VL11_U_VL12_U_VL13_U_VL14_U_VL15_U
- S GN0B=GN0A_VL16_U_VL17_U_VL18_U_VL19_U
- S GN0B=GN0B_VL6E_U ;IEN OF PRIMARY 2237
- S GN0B=GN0B_VL7E_U ;IEN OF METHOD OF PROCESSING
- S GN0B=GN0B_VL10E_U ;IEN OF SUPPLY STATUS
- S GN0B=GN0B_VL16E_U ;IEN OF SUBACCOUNT1
- S GN0B=GN0B_VL18E_U ;IEN OF SUBACCOUNT2
- S ^TMP($J,"POMAST",POID,0)=GN0B ; build and set node 0
- ; begin Node 1
- ; look up Vendor
- S VN=$P(N1,U,1),VN1=$G(^PRC(440,+VN,0)),VN2=$P(VN1,U,1)
- S VL20=VN2 ;Vendor Name
- S VL21E=$P(N1,U,2),VL21E1=$$GET1^DIQ(49,+VL21E_",",.01)
- S VL21E2=$P(VL21E1,U,1)
- S VL21=VL21E2 ; Req. Service
- S VL22=$P(N1,U,6) ; Fob Point
- ; get ext. date
- S EXDT=$P(N0,U,20),EXDT1=$P(EXDT,".",1)
- S EXDT2=$$FMTE^XLFDT(EXDT1)
- S VL23=EXDT2 ; Org. Del. Date
- S VL24=$P(N0,U,11) ; Est. Cost
- S VL25E=$P(N1,U,7),VL25E1=$G(^PRCD(420.8,+VL25E,0))
- S VL25E2=$P(VL25E1,U,2)
- S VL25=VL25E2 ; Source Code
- S VL26=$P(N0,U,13) ; Est Shipping
- S VL27=$P(N0,U,18) ; Shp Ln Itm #
- S VL28=$P(N0,U,14) ; Ln Itm Cnt
- S PAPAB=$P(N1,U,10),PAPAB1=$G(^VA(200,+PAPAB,0))
- S VL29=$P(PAPAB1,U,1) ; PaPpmAuthBuyer
- S VL8=$P($G(^VA(200,+PAPAB,5)),"^") ;Service - PaPpmAuthBuyer
- S VL9=$S(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01)) ;SVC ext - PaPpmAuthBuyer
- S AGAPO=$P(N12,U,4),AGAPO1=$G(^VA(200,+AGAPO,0))
- S VL30=$P(AGAPO1,U,1) ; Agt Assgnd PO
- S VL6=$P($G(^VA(200,+AGAPO,5)),"^") ;Service - Agt Assgnd PO
- S VL7=$S(VL6="":"",1:$$GET1^DIQ(49,+VL6_",",.01)) ;SVC ext - Agt Assgnd
- ; get external date
- S EXDT=$P(N12,U,5),EXDT1=$P(EXDT,".",1)
- S EXDT2=$$FMTE^XLFDT(EXDT1)
- S VL31=EXDT2 ; DatePoAssigned
- S VL32=$P(N16,U,0) ;remarks
- S VL33E=$P(N23,U,3),VL33E1=$G(^PRC(442,+VL33E,0))
- S VL33E2=$P(VL33E1,U,1)
- S VL33=VL33E2 ; OldPoRec
- S VL34E=$P(N23,U,4),VL34E1=$G(^PRC(442,+VL34E,0))
- S VL34E2=$P(VL34E1,U,1)
- S VL34=$P(N23,U,4) ; New PoRec
- S GN1=VL20_U_VL21_U_VL22_U_VL23_U_VL24_U_VL25_U_VL26_U_VL27_U
- S GN1A=GN1_VL28_U_VL29_U_VL30_U_VL31_U_VL32_U_VL33_U_VL34_U
- S GN1A=GN1A_VL8_U_VL9_U_AGAPO_U_VL6_U_VL7_U
- S ^TMP($J,"POMAST",POID,1)=GN1A
- ;
- ; build node 2
- S VL35E=$P(N23,U,14),VL35E1=$G(^PRC(440,+VL35E,0))
- S VL35E2=$P(VL35E1,U,1)
- S VL35=VL35E2 ; PcDo Vendor
- S PCUSR=$P(N23,U,17),PCUSR1=$G(^VA(200,+PCUSR,0))
- S VL36=$P(PCUSR1,U,1) ; Pur Crd User
- S VL6=$P($G(^VA(200,+PCUSR,5)),"^") ;Service - Pur Crd User
- S VL7=$S(VL6="":"",1:$$GET1^DIQ(49,+VL6_",",.01)) ;SVC ext - Pur Crd User
- S VL37=$P(N23,U,21) ; Pur Cost
- S PCHDR=$P(N23,U,22),PCHDR1=$G(^VA(200,+PCHDR,0))
- S VL38=$P(PCHDR1,U,1) ; Pur Card Hldr
- S VL8=$P($G(^VA(200,+PCHDR,5)),"^") ;Service - Pur Crd Hldr
- S VL9=$S(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01)) ;SVC ext - Pur Crd Hldr
- ; get ext. value for 2237
- S PC2237V=$P(N23,U,23),PC2237V1=$G(^PRCS(410,+PC2237V,0))
- S VL39=$P(PC2237V1,U,1) ; Pcdo2237
- S VL40=$P(N0,U,15) ; Total Amount
- S VL41=$P(N0,U,16) ; Net amount
- ;
- S GN2=VL35_U_VL36_U_VL37_U_VL38_U_VL39_U_VL40_U_VL41_U
- S ^TMP($J,"POMAST",POID,2)=GN2_VL6_U_VL7_U_VL8_U_VL9_U
- S VL20=$P(N23,U,2) S:VL20'="" VL20=$E(VL20+17000000,1,4) ;BBFY
- S VL21=$$FMTE^XLFDT($P($P(N23,U,5),".")) ;END DATE FOR SERVICE ORDER
- S VL19=$$GET1^DIQ(442,POID_",",30) ;AUTO ACCRUE
- S VL22=$P(N23,U,7) ;SUBSTATION IEN
- S VL23=$P($G(^PRC(411,+VL22,0)),U,1) ;SUBSTATION EXTERNAL
- S VL24=VN ;VENDOR IEN
- S VL25=$P($G(^PRC(440,+VN,3)),U,4) ;VENDOR FMS CODE
- S VL26=$P($G(^PRC(440,+VN,3)),U,5) ;VENDOR ALT-ADDR-IND
- S VL27=$P($G(^PRC(440,+VN,7)),U,12) ;VENDOR D & B
- S VL28=$$GET1^DIQ(442,POID,21) ;MONTH
- S VL29=$$GET1^DIQ(442,POID,22) ;QUARTER
- S VL30=$$GET1^DIQ(442,POID,23) ;LAST DIGIT OF FISCAL YEAR
- S GN1=VL20_U_VL21_U_VL19_U_VL22_U_VL23_U_VL24_U_VL25_U_VL26_U_VL27
- S ^TMP($J,"POMAST",POID,3)=GN1_U_VL28_U_VL29_U_VL30_U
- S N1=$G(^PRC(442,POID,8)) D
- . S VL20=$P(N1,U,1) ;ACTUAL 1358 BALANCE
- . S VL21=$P(N1,U,2) ;FISCAL 1358 BALANCE
- . S VL22=$P(N1,U,3) ;ESTIMATED 1358 BALANCE
- . S VL23=$$GET1^DIQ(442,POID_",",96.7) ;BULLETIN SENT
- S VL24=$P($G(^PRC(442,POID,24)),U,3) ;INTERFACE PACKAGE PREFIX
- S VL25=$P($G(^PRC(442,POID,18)),U,3) ;DOCUMENT IDENTIFIER/COMMON #
- S VL26=$$GET1^DIQ(442,POID_",",116) ;DO YOU WANT TO SEND THIS EDI?
- S GN1=VL20_U_VL21_U_VL22_U_VL23_U_VL24_U_VL25_U_VL26_U
- S ^TMP($J,"POMAST",POID,4)=GN1
- K PRCVAL,POIDC S POIDC=POID_","
- D GETS^DIQ(442,POIDC,"117:132","E","PRCVAL")
- S GN1=""
- F VL1=117:1:132 S GN1=GN1_$G(PRCVAL(442,POIDC,VL1,"E"))_U
- K PRCVAL,POIDC
- S GN1=GN1_$P($G(^PRC(442,POID,25)),U,17)_U ; SEND TO FPDS?
- S $P(GN1,U,18,20)=PAPAB_U_$P(N23,U,17)_U_$P(N23,U,22)
- S $P(GN1,U,21)=$$GET^XPAR("SYS","PRCPLO REGIONAL ACQ CENTER",1,"Q")
- S ^TMP($J,"POMAST",POID,5)=GN1 ;NODE 25, TOTAL OF 17 FIELDS
- ;
- D PODISC^PRCHLO1A
- D POBOC^PRCHLO1A
- D POCMTS^PRCHLO1A
- D PORMKS^PRCHLO1A
- D PO2237^PRCHLO1A
- D POAMT^PRCHLO1A
- D POAMMD^PRCHLO1A
- D POPPTER^PRCHLO2A
- D POPART^PRCHLO2A
- D POOBL^PRCHLO2A
- D POPMET^PRCHLO2A
- D GPOITEM^PRCHLO2
- Q
- PODISCH ; PO Discount Header File
- ; Header file for PO Discount Multiple
- W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
- W "DiscountIdNum^DiscountItem^PercentDollarAmount^"
- W "DiscountAmount^ItemCount^Contract^LineItem",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO1 8319 printed Feb 18, 2025@23:34:50 Page 2
- PRCHLO1 ;WOIFO/RLL-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ;5/22/09 14:10
- +1 ;;5.1;IFCAP;**83,130**;Oct 20, 2000;Build 25
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; DBIA 10093 - Read file 49 via FileMan.
- +4 ; Continuation of PRCHLO1. This program builds the extracts for
- +5 ; the Master PO Table and the associated multiples
- POMAST ; PoMaster Table
- +1 QUIT
- PODISCW ; Write PO Discount table data
- +1 NEW GPOID,GPOND
- +2 SET GPOID=0
- SET GPOND=""
- +3 FOR
- SET GPOID=$ORDER(^TMP($JOB,"PODISC",GPOID))
- if GPOID=""
- QUIT
- Begin DoDot:1
- +4 FOR
- SET GPOND=$ORDER(^TMP($JOB,"PODISC",GPOID,GPOND))
- if GPOND=""
- QUIT
- Begin DoDot:2
- +5 WRITE $GET(^TMP($JOB,"PODISC",GPOID,GPOND))
- +6 WRITE !
- +7 QUIT
- End DoDot:2
- +8 QUIT
- End DoDot:1
- +9 QUIT
- GPOMAST ; get PO Master record
- +1 SET U="^"
- +2 NEW N0,N1,N7,N12,N16,N23,PONUMB,STNUMB,PODAT,PPOKEY
- +3 NEW PAPAB,PAPAB1,AGAPO,AGAPO1,PCHDR,PCHDR1,PCUSR,PCUSR1,POIDC,PRCVAL
- +4 NEW VL1,VL6,VL7,VL8,VL9,VL10,VL11,VL12,VL13,VL14,VL15,VL16,VL17,VL18
- +5 NEW VL19,VL20,VL21,VL22,VL23,VL24,VL25,VL26,VL27,VL28,VL29,VL30,VL31
- +6 NEW VL32,VL33,VL34,VL35,VL36,VL37,VL38,VL39,VL40,VL41
- +7 NEW GN0,GN0A,GN0B,GN1,GN1A,GN2,VN,VN1,VN2
- +8 NEW VL6E,VL6E1,VL6E2,VL7E,VL7E1,VL7E2,VL8E,VL8E1,VL8E2,VL10E,VL10E1
- +9 NEW VL10E2,VL21E,VL21E1,VL21E2,VL25E,VL25E1,VL25E2,VL35E,VL35E1,VL35E2
- +10 NEW VL16E,VL16E1,VL16E2,VL18E,VL18E1,VL18E2,VL33E,VL33E1,VL33E2
- +11 NEW VL34E,VL34E1,VL34E2,PC2237V,PC2237V1,EXDT,EXDT1,EXDT2
- +12 SET N0=$GET(^PRC(442,POID,0))
- +13 SET N1=$GET(^PRC(442,POID,1))
- +14 SET N7=$GET(^PRC(442,POID,7))
- +15 SET N12=$GET(^PRC(442,POID,12))
- +16 SET N16=$GET(^PRC(442,POID,16))
- +17 SET N23=$GET(^PRC(442,POID,23))
- +18 SET PONUMB=$PIECE(N0,U,1)
- SET STNUMB=$PIECE(PONUMB,"-",1)
- +19 SET EXDT=$PIECE(N1,U,15)
- +20 ; if PO Date "" use x-ref date value for PO
- IF EXDT=""
- SET EXDT=POCRDAT
- +21 SET EXDT1=$PIECE(EXDT,".",1)
- +22 SET EXDT2=$$FMTE^XLFDT(EXDT1)
- +23 ; needed for key
- SET PODAT=EXDT2
- +24 SET PPOKEY=POID_U_PONUMB_U_PODAT_U_MNTHYR_U_STNUMB
- +25 ;
- +26 ; The 1st 5 values in PPOKEY above are included in each record
- +27 ;
- +28 SET VL6E=$PIECE(N0,U,12)
- SET VL6E1=$GET(^PRCS(410,+VL6E,0))
- SET VL6E2=$PIECE(VL6E1,U,1)
- +29 ; Prim2237
- SET VL6=VL6E2
- +30 SET VL7E=$PIECE(N0,U,2)
- SET VL7E1=$GET(^PRCD(442.5,+VL7E,0))
- SET VL7E2=$PIECE(VL7E1,U,1)
- +31 ; meth.of proc
- SET VL7=VL7E2
- +32 SET VL8E=$PIECE(N1,U,19)
- SET VL8E1=$GET(^PRC(443.8,+VL8E,0))
- SET VL8E2=$PIECE(VL8E1,U,2)
- +33 ; locProcRsnCode
- SET VL8=VL8E2
- +34 ; exp/non-exp
- SET VL9=$PIECE(N1,U,18)
- +35 SET VL10E=$PIECE(N7,U,1)
- SET VL10E1=$GET(^PRCD(442.3,+VL10E,0))
- +36 SET VL10E2=$PIECE(VL10E1,U,1)
- +37 ; Supply status
- SET VL10=VL10E2
- +38 ; Sup Stat Order
- SET VL11=$PIECE(N7,U,2)
- +39 ;Fis Stat Order
- SET VL12=$PIECE(N7,U,4)
- +40 ;FCP
- SET VL13=$PIECE(N0,U,3)
- +41 ;Appropriation
- SET VL14=$PIECE(N0,U,4)
- +42 ;CostCenter
- SET VL15=$PIECE(N0,U,5)
- +43 SET VL16E=$PIECE(N0,U,6)
- SET VL16E1=$GET(^PRCD(420.2,+VL16E,0))
- +44 SET VL16E2=$PIECE(VL16E1,U,1)
- +45 ;SubAcct1
- SET VL16=VL16E2
- +46 ;SubAmt1
- SET VL17=$PIECE(N0,U,7)
- +47 SET VL18E=$PIECE(N0,U,8)
- SET VL18E1=$GET(^PRCD(420.2,+VL18E,0))
- +48 SET VL18E2=$PIECE(VL18E1,U,1)
- +49 ;SubAcct2
- SET VL18=VL18E2
- +50 ;SubAmt2
- SET VL19=$PIECE(N0,U,9)
- +51 ; set Node 0 of ^TMP
- +52 SET GN0=PPOKEY_U_VL6_U_VL7_U_VL8_U_VL9_U_VL10_U
- +53 SET GN0A=GN0_VL11_U_VL12_U_VL13_U_VL14_U_VL15_U
- +54 SET GN0B=GN0A_VL16_U_VL17_U_VL18_U_VL19_U
- +55 ;IEN OF PRIMARY 2237
- SET GN0B=GN0B_VL6E_U
- +56 ;IEN OF METHOD OF PROCESSING
- SET GN0B=GN0B_VL7E_U
- +57 ;IEN OF SUPPLY STATUS
- SET GN0B=GN0B_VL10E_U
- +58 ;IEN OF SUBACCOUNT1
- SET GN0B=GN0B_VL16E_U
- +59 ;IEN OF SUBACCOUNT2
- SET GN0B=GN0B_VL18E_U
- +60 ; build and set node 0
- SET ^TMP($JOB,"POMAST",POID,0)=GN0B
- +61 ; begin Node 1
- +62 ; look up Vendor
- +63 SET VN=$PIECE(N1,U,1)
- SET VN1=$GET(^PRC(440,+VN,0))
- SET VN2=$PIECE(VN1,U,1)
- +64 ;Vendor Name
- SET VL20=VN2
- +65 SET VL21E=$PIECE(N1,U,2)
- SET VL21E1=$$GET1^DIQ(49,+VL21E_",",.01)
- +66 SET VL21E2=$PIECE(VL21E1,U,1)
- +67 ; Req. Service
- SET VL21=VL21E2
- +68 ; Fob Point
- SET VL22=$PIECE(N1,U,6)
- +69 ; get ext. date
- +70 SET EXDT=$PIECE(N0,U,20)
- SET EXDT1=$PIECE(EXDT,".",1)
- +71 SET EXDT2=$$FMTE^XLFDT(EXDT1)
- +72 ; Org. Del. Date
- SET VL23=EXDT2
- +73 ; Est. Cost
- SET VL24=$PIECE(N0,U,11)
- +74 SET VL25E=$PIECE(N1,U,7)
- SET VL25E1=$GET(^PRCD(420.8,+VL25E,0))
- +75 SET VL25E2=$PIECE(VL25E1,U,2)
- +76 ; Source Code
- SET VL25=VL25E2
- +77 ; Est Shipping
- SET VL26=$PIECE(N0,U,13)
- +78 ; Shp Ln Itm #
- SET VL27=$PIECE(N0,U,18)
- +79 ; Ln Itm Cnt
- SET VL28=$PIECE(N0,U,14)
- +80 SET PAPAB=$PIECE(N1,U,10)
- SET PAPAB1=$GET(^VA(200,+PAPAB,0))
- +81 ; PaPpmAuthBuyer
- SET VL29=$PIECE(PAPAB1,U,1)
- +82 ;Service - PaPpmAuthBuyer
- SET VL8=$PIECE($GET(^VA(200,+PAPAB,5)),"^")
- +83 ;SVC ext - PaPpmAuthBuyer
- SET VL9=$SELECT(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01))
- +84 SET AGAPO=$PIECE(N12,U,4)
- SET AGAPO1=$GET(^VA(200,+AGAPO,0))
- +85 ; Agt Assgnd PO
- SET VL30=$PIECE(AGAPO1,U,1)
- +86 ;Service - Agt Assgnd PO
- SET VL6=$PIECE($GET(^VA(200,+AGAPO,5)),"^")
- +87 ;SVC ext - Agt Assgnd
- SET VL7=$SELECT(VL6="":"",1:$$GET1^DIQ(49,+VL6_",",.01))
- +88 ; get external date
- +89 SET EXDT=$PIECE(N12,U,5)
- SET EXDT1=$PIECE(EXDT,".",1)
- +90 SET EXDT2=$$FMTE^XLFDT(EXDT1)
- +91 ; DatePoAssigned
- SET VL31=EXDT2
- +92 ;remarks
- SET VL32=$PIECE(N16,U,0)
- +93 SET VL33E=$PIECE(N23,U,3)
- SET VL33E1=$GET(^PRC(442,+VL33E,0))
- +94 SET VL33E2=$PIECE(VL33E1,U,1)
- +95 ; OldPoRec
- SET VL33=VL33E2
- +96 SET VL34E=$PIECE(N23,U,4)
- SET VL34E1=$GET(^PRC(442,+VL34E,0))
- +97 SET VL34E2=$PIECE(VL34E1,U,1)
- +98 ; New PoRec
- SET VL34=$PIECE(N23,U,4)
- +99 SET GN1=VL20_U_VL21_U_VL22_U_VL23_U_VL24_U_VL25_U_VL26_U_VL27_U
- +100 SET GN1A=GN1_VL28_U_VL29_U_VL30_U_VL31_U_VL32_U_VL33_U_VL34_U
- +101 SET GN1A=GN1A_VL8_U_VL9_U_AGAPO_U_VL6_U_VL7_U
- +102 SET ^TMP($JOB,"POMAST",POID,1)=GN1A
- +103 ;
- +104 ; build node 2
- +105 SET VL35E=$PIECE(N23,U,14)
- SET VL35E1=$GET(^PRC(440,+VL35E,0))
- +106 SET VL35E2=$PIECE(VL35E1,U,1)
- +107 ; PcDo Vendor
- SET VL35=VL35E2
- +108 SET PCUSR=$PIECE(N23,U,17)
- SET PCUSR1=$GET(^VA(200,+PCUSR,0))
- +109 ; Pur Crd User
- SET VL36=$PIECE(PCUSR1,U,1)
- +110 ;Service - Pur Crd User
- SET VL6=$PIECE($GET(^VA(200,+PCUSR,5)),"^")
- +111 ;SVC ext - Pur Crd User
- SET VL7=$SELECT(VL6="":"",1:$$GET1^DIQ(49,+VL6_",",.01))
- +112 ; Pur Cost
- SET VL37=$PIECE(N23,U,21)
- +113 SET PCHDR=$PIECE(N23,U,22)
- SET PCHDR1=$GET(^VA(200,+PCHDR,0))
- +114 ; Pur Card Hldr
- SET VL38=$PIECE(PCHDR1,U,1)
- +115 ;Service - Pur Crd Hldr
- SET VL8=$PIECE($GET(^VA(200,+PCHDR,5)),"^")
- +116 ;SVC ext - Pur Crd Hldr
- SET VL9=$SELECT(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01))
- +117 ; get ext. value for 2237
- +118 SET PC2237V=$PIECE(N23,U,23)
- SET PC2237V1=$GET(^PRCS(410,+PC2237V,0))
- +119 ; Pcdo2237
- SET VL39=$PIECE(PC2237V1,U,1)
- +120 ; Total Amount
- SET VL40=$PIECE(N0,U,15)
- +121 ; Net amount
- SET VL41=$PIECE(N0,U,16)
- +122 ;
- +123 SET GN2=VL35_U_VL36_U_VL37_U_VL38_U_VL39_U_VL40_U_VL41_U
- +124 SET ^TMP($JOB,"POMAST",POID,2)=GN2_VL6_U_VL7_U_VL8_U_VL9_U
- +125 ;BBFY
- SET VL20=$PIECE(N23,U,2)
- if VL20'=""
- SET VL20=$EXTRACT(VL20+17000000,1,4)
- +126 ;END DATE FOR SERVICE ORDER
- SET VL21=$$FMTE^XLFDT($PIECE($PIECE(N23,U,5),"."))
- +127 ;AUTO ACCRUE
- SET VL19=$$GET1^DIQ(442,POID_",",30)
- +128 ;SUBSTATION IEN
- SET VL22=$PIECE(N23,U,7)
- +129 ;SUBSTATION EXTERNAL
- SET VL23=$PIECE($GET(^PRC(411,+VL22,0)),U,1)
- +130 ;VENDOR IEN
- SET VL24=VN
- +131 ;VENDOR FMS CODE
- SET VL25=$PIECE($GET(^PRC(440,+VN,3)),U,4)
- +132 ;VENDOR ALT-ADDR-IND
- SET VL26=$PIECE($GET(^PRC(440,+VN,3)),U,5)
- +133 ;VENDOR D & B
- SET VL27=$PIECE($GET(^PRC(440,+VN,7)),U,12)
- +134 ;MONTH
- SET VL28=$$GET1^DIQ(442,POID,21)
- +135 ;QUARTER
- SET VL29=$$GET1^DIQ(442,POID,22)
- +136 ;LAST DIGIT OF FISCAL YEAR
- SET VL30=$$GET1^DIQ(442,POID,23)
- +137 SET GN1=VL20_U_VL21_U_VL19_U_VL22_U_VL23_U_VL24_U_VL25_U_VL26_U_VL27
- +138 SET ^TMP($JOB,"POMAST",POID,3)=GN1_U_VL28_U_VL29_U_VL30_U
- +139 SET N1=$GET(^PRC(442,POID,8))
- Begin DoDot:1
- +140 ;ACTUAL 1358 BALANCE
- SET VL20=$PIECE(N1,U,1)
- +141 ;FISCAL 1358 BALANCE
- SET VL21=$PIECE(N1,U,2)
- +142 ;ESTIMATED 1358 BALANCE
- SET VL22=$PIECE(N1,U,3)
- +143 ;BULLETIN SENT
- SET VL23=$$GET1^DIQ(442,POID_",",96.7)
- End DoDot:1
- +144 ;INTERFACE PACKAGE PREFIX
- SET VL24=$PIECE($GET(^PRC(442,POID,24)),U,3)
- +145 ;DOCUMENT IDENTIFIER/COMMON #
- SET VL25=$PIECE($GET(^PRC(442,POID,18)),U,3)
- +146 ;DO YOU WANT TO SEND THIS EDI?
- SET VL26=$$GET1^DIQ(442,POID_",",116)
- +147 SET GN1=VL20_U_VL21_U_VL22_U_VL23_U_VL24_U_VL25_U_VL26_U
- +148 SET ^TMP($JOB,"POMAST",POID,4)=GN1
- +149 KILL PRCVAL,POIDC
- SET POIDC=POID_","
- +150 DO GETS^DIQ(442,POIDC,"117:132","E","PRCVAL")
- +151 SET GN1=""
- +152 FOR VL1=117:1:132
- SET GN1=GN1_$GET(PRCVAL(442,POIDC,VL1,"E"))_U
- +153 KILL PRCVAL,POIDC
- +154 ; SEND TO FPDS?
- SET GN1=GN1_$PIECE($GET(^PRC(442,POID,25)),U,17)_U
- +155 SET $PIECE(GN1,U,18,20)=PAPAB_U_$PIECE(N23,U,17)_U_$PIECE(N23,U,22)
- +156 SET $PIECE(GN1,U,21)=$$GET^XPAR("SYS","PRCPLO REGIONAL ACQ CENTER",1,"Q")
- +157 ;NODE 25, TOTAL OF 17 FIELDS
- SET ^TMP($JOB,"POMAST",POID,5)=GN1
- +158 ;
- +159 DO PODISC^PRCHLO1A
- +160 DO POBOC^PRCHLO1A
- +161 DO POCMTS^PRCHLO1A
- +162 DO PORMKS^PRCHLO1A
- +163 DO PO2237^PRCHLO1A
- +164 DO POAMT^PRCHLO1A
- +165 DO POAMMD^PRCHLO1A
- +166 DO POPPTER^PRCHLO2A
- +167 DO POPART^PRCHLO2A
- +168 DO POOBL^PRCHLO2A
- +169 DO POPMET^PRCHLO2A
- +170 DO GPOITEM^PRCHLO2
- +171 QUIT
- PODISCH ; PO Discount Header File
- +1 ; Header file for PO Discount Multiple
- +2 WRITE "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
- +3 WRITE "DiscountIdNum^DiscountItem^PercentDollarAmount^"
- +4 WRITE "DiscountAmount^ItemCount^Contract^LineItem",!
- +5 QUIT