PRCHLO2 ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 10/16/06 2:09pm
V ;;5.1;IFCAP;**83,98**; Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
; Continuation of PRCHLO1. This program includes the extract
; logic for each of the 19 identified tables.
;
POITEM ; PoItem Table
;
Q
;
POITEMH ; PoItem Table Header
;
W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
W "LineItemIdNum^LineItemNumber^ItemMasterFileNumber^"
W "ItemMasterDescription^NIFNumber^"
;
W "Quantity^UnitOfPurchase^PackagingMultiple^ItemDeliveryPoints^"
W "BOC^ContractBOA^ActualUnitCost^EstUnitCost^FedSupplyClass^"
W "VendorStockNumber^NationalDrugCode^SKU^NSN^"
W "UnitConversionFactor^TotalCost^DiscountedAmount^"
W "Z410ItemNumber^LotNumber^SerialNumber"
Q
POITEMW ; Write PO Item Data
;
N GPOID,GPOND
S GPOID=0,GPOND=""
F S GPOID=$O(^TMP($J,"POITEM",GPOID)) Q:GPOID="" D
. F S GPOND=$O(^TMP($J,"POITEM",GPOID,GPOND)) Q:GPOND="" D
. . W !,$G(^TMP($J,"POITEM",GPOID,GPOND,0))
. . Q
. Q
Q
POITLNH ; Write PO Line Inventory Point Header
W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
W "LineItemIdNum^LineInvPtIdNum^LineInvPt^LineQty^LineDelivery^"
W "QtyReceivedToDate",!
Q
POITLNW ; Write PO Line Inventory Point Data
N PITL,PITL1,PITL2
S PITL=0,PITL1=0,PITL2=0
F S PITL=$O(^TMP($J,"POITEMLNINVPT",PITL)) Q:PITL="" D
. F S PITL1=$O(^TMP($J,"POITEMLNINVPT",PITL,PITL1)) Q:PITL1="" D
. . W $G(^TMP($J,"POITEMLNINVPT",PITL,PITL1,1,0)),!
. . Q
. Q
Q
GPOITEM ; Get PO Item record
S U="^"
N N0,N2,N4,PONUMB,STNUMB,PR2237,PODAT,CKIT,CKIT1,ITMID
N POI1A,POI1B,POI1C,POIA,POIA1,POIA2,PO16E,PO16E1,PO16E2
N PO17E,PO17E1,PO17E2,POIAF,POIA2A,IMID
S CKIT=$G(^PRC(442,POID,2,0)),ITMID=0
S CKIT1=$P(CKIT,U,3)
I +CKIT1>0 D
. S ITMID=0
. F S ITMID=$O(^PRC(442,POID,2,ITMID)) Q:ITMID="" D
. . I +ITMID>0 D ; Got an item
. . . S N0=$G(^PRC(442,POID,2,ITMID,0))
. . . S N2=$G(^PRC(442,POID,2,ITMID,2))
. . . S N4=$G(^PRC(442,POID,2,ITMID,4))
. . . D LPPOITM ; Loop on item
. . . Q
. . Q
. Q
Q
DITMD ; Set PO Item Description Data
N ITMD,ITMD1,ITMD2,ITMD3
; get 1st 50 characters from 1st desc.
S ITMD=$G(^PRC(442,POID,2,ITMID,1,1,0))
Q:ITMD="" ; make sure a description exists for the PO
S ITMD1=$P(ITMD,U,1)
S ITMD2=$E(ITMD1,1,175)
S ITMD3=PPOKEY_U_ITMID_U_1_U_ITMD2
S ^TMP($J,"POITEMDESC",POID,ITMID,0)=ITMD3
Q
POLIDT ; PO line item date received
N LIDT1,LIDT2,LIDT3,LIDT4,LIDT5,V1,V2,V3,V4,LDT1E,LDT1E1,LDT1E2
S LIDT1=$G(^PRC(442,POID,2,ITMID,3,0))
S LIDT2=$P(LIDT1,U,3)
I +LIDT2>0 D
. S LIDT3=0
. F S LIDT3=$O(^PRC(442,POID,2,ITMID,3,LIDT3)) Q:LIDT3="" D
. . Q:+LIDT3<0 ; quit at the x-ref
. . S LIDT4=$G(^PRC(442,POID,2,ITMID,3,LIDT3,0))
. . ; V1-V4 Get the data,$P the values, pad with "^" delimiters
. . ; get external value for date received
. . S LDT1E=$P(LIDT4,U,1)
. . I LDT1E'="" S LDT1E1=$P(LDT1E,".",1),LDT1E2=$$FMTE^XLFDT(LDT1E1)
. . I LDT1E="" S LDT1E2=""
. . S V1=LDT1E2_U_$P(LIDT4,U,2)_U_$P(LIDT4,U,3)_U
. . S V2=$P(LIDT4,U,4)_U_$P(LIDT4,U,5)_U
. . S V3=$P(LIDT4,U,7)_U_$P(LIDT4,U,8),V4=V1_V2_V3
. . S LIDT5=PPOKEY_U_ITMID_U_LIDT3_U_V4
. . I +(LIDT3)>0 S ^TMP($J,"POITEMDATEREC",POID,ITMID,LIDT3,0)=LIDT5
. . Q
. Q
Q
POLIINV ; PO line item Inventory Point multiple
N POLIV,POLIV1,POLIV2,POLIV3,POLIV4,V1,V2,V3,POLE1,POLE2,POLE3
S POLIV=$G(^PRC(442,POID,2,ITMID,5,0))
S POLIV1=$P(POLIV,U,3)
I +POLIV1>0 D
. S POLIV2=0
. S POLIV2=$O(^PRC(442,POID,2,ITMID,5,POLIV2)) Q:POLIV2="" D
. . Q:+POLIV2<0 ; quit at the x-ref ELSE Get data, $P values
. . S POLIV3=$G(^PRC(442,POID,2,ITMID,5,POLIV2,0)) ;Get data values
. . S POLE1=$P(POLIV3,U,1)
. . I POLE1'="" S POLE2=$G(^PRCP(445,+POLE1,0)),POLE3=$P(POLE2,U,1)
. . I POLE1="" S POLE3=""
. . S V1=POLE3_U_$P(POLIV3,U,2)_U_$P(POLIV3,U,3)_U
. . S V2=$P(POLIV3,U,4),V3=V1_V2
. . S POLIV4=PPOKEY_U_ITMID_U_POLIV2_U_V3
. . I +POLIV2>0 S ^TMP($J,"POITEMLNINVPT",POID,ITMID,POLIV2,0)=POLIV4
. . Q
. Q
Q
LPPOITM ; Loop on PO Item
; Initialize with PPOKEY
S ^TMP($J,"POITEM",POID,ITMID,0)=PPOKEY_U_ITMID
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,7)=$P(N0,U,1) ; LineItem#
;
;
; get value for ItemMast.Description
S POIA=$P(N0,U,5)
I POIA'="" S POIA1=$G(^PRC(441,+POIA,0)),POIA2=$P(POIA1,U,2),IMID=$P(POIA1,U,1),POIA2A=$P(POIA1,U,1)
I POIA="" S POIA2="",IMID=""
;
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,8)=IMID ; ItemMast.ID#
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,9)=POIA2 ; ItemMast.Description
;
; Patch 98 CR1 fix . ITEM Master entry may have been deleted if
; POIA2'="", but value for lookup is missing (POIA2A="")
; If this is the case, S POIAF="ITEM MASTER FILE ERROR "_POIA
;
I POIA2="" S POIAF=""
I POIA2'="" D ; new logic RLL 8/9/06
. I POIA2A="" S POIAF="ITEM MASTER FILE ERROR "_ITMID
. I POIA2A'="" S POIAF=$P($G(^PRC(441,POIA2A,0)),U,15)
. Q
; I POIA2'="" S POIAF=$P(^PRC(441,POIA2A,0),U,15) ;original logic
; End Changes Patch 98 RLL 8/9/06
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,10)=POIAF ; NIF #
;
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,11)=$P(N0,U,2) ; Quantity
; Get external value of Unit of Purchase
S POI1A=$P(N0,U,3)
I POI1A'="" S POI1B=$G(^PRCD(420.5,+POI1A,0)),POI1C=$P(POI1B,U,1)
I POI1A="" S POI1C=""
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,12)=POI1C ;UnitOfPurchase
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,13)=$P(N0,U,12) ; PkgMult
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,14)=$P(N0,U,8) ; ItmDelPoints
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,15)=$P(N0,U,4) ; BOC
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,16)=$P(N2,U,2) ; Contract Boa
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,17)=$P(N0,U,9) ; Act Unit Cost
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,18)=$P(N0,U,7) ; Est Unit Cost
; get external value for Fed Supply Classification
S PO17E=$P(N2,U,3)
I PO17E'="" S PO17E1=$G(^PRC(441.2,+PO17E,0)),PO17E2=$P(PO17E1,U,1)
I PO17E="" S PO17E2=""
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,19)=PO17E2 ;FedSupClass
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,20)=$P(N0,U,6) ;VenStkNum
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,21)=$P(N0,U,15) ;NatDrugCode
; get external value for SKU
S PO16E=$P(N0,U,16)
I PO16E'="" S PO16E1=$G(^PRCD(420.5,+PO16E,0)),PO16E2=$P(PO16E1,U,1)
I PO16E="" S PO16E2=""
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,22)=PO16E2 ;SKU
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,23)=$P(N0,U,13) ;NSN
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,24)=$P(N0,U,17) ;UnitConFactor
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,25)=$P(N2,U,1) ;TotalCost
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,26)=$P(N2,U,6) ;DiscItmAmt
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,27)=$P(N2,U,13) ;Z410ItmNum
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,28)=$P(N4,U,17) ;LotNum
S $P(^TMP($J,"POITEM",POID,ITMID,0),U,29)=$P(N4,U,18) ;SerialNum
D DITMD ; get 1st Item Description from multiple
D POLIDT ; get Item Date received Data from multiple
D POLIINV
Q
;
POITDRCH ; PO Item Date Received Header
W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
W "LineItemIdNum^DateRecIdNum^DateReceived^QtyReceived^Amount^"
W "PartialNumber^DiscountedAmount^AdjustedQuantityRec^AdjustedAmt",!
Q
POITDRCW ; PO Item Date Received Data
N PIDRC,PIDRC1,PIDRC2,PIDRC3,PIDRC4
S PIDRC=0,PIDRC1=0,PIDRC2=0,PIDRC3=0
F S PIDRC=$O(^TMP($J,"POITEMDATEREC",PIDRC)) Q:PIDRC="" D
. F S PIDRC1=$O(^TMP($J,"POITEMDATEREC",PIDRC,PIDRC1)) Q:PIDRC1="" D
. . F S PIDRC2=$O(^TMP($J,"POITEMDATEREC",PIDRC,PIDRC1,PIDRC2)) Q:PIDRC2="" D
. . . ;
. . . W $G(^TMP($J,"POITEMDATEREC",PIDRC,PIDRC1,PIDRC2,0)),!
. . Q
. . Q
. Q
Q
POITDSH ; PO Item Description Header
W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
W "LineItemIdNum^LineItemDescIdNum^Description",!
Q
POITDSW ; PO Item Description Write Data
N PDES,PDES1,PDES2,PDES3
S PDES=0,PDES1=0
F S PDES=$O(^TMP($J,"POITEMDESC",PDES)) Q:PDES="" D
. F S PDES1=$O(^TMP($J,"POITEMDESC",PDES,PDES1)) Q:PDES1="" D
. . W $G(^TMP($J,"POITEMDESC",PDES,PDES1,0)),!
. . Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO2 8174 printed Sep 23, 2025@19:44:33 Page 2
PRCHLO2 ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 10/16/06 2:09pm
V ;;5.1;IFCAP;**83,98**; Oct 20, 2000;Build 37
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ; Continuation of PRCHLO1. This program includes the extract
+3 ; logic for each of the 19 identified tables.
+4 ;
POITEM ; PoItem Table
+1 ;
+2 QUIT
+3 ;
POITEMH ; PoItem Table Header
+1 ;
+2 WRITE "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
+3 WRITE "LineItemIdNum^LineItemNumber^ItemMasterFileNumber^"
+4 WRITE "ItemMasterDescription^NIFNumber^"
+5 ;
+6 WRITE "Quantity^UnitOfPurchase^PackagingMultiple^ItemDeliveryPoints^"
+7 WRITE "BOC^ContractBOA^ActualUnitCost^EstUnitCost^FedSupplyClass^"
+8 WRITE "VendorStockNumber^NationalDrugCode^SKU^NSN^"
+9 WRITE "UnitConversionFactor^TotalCost^DiscountedAmount^"
+10 WRITE "Z410ItemNumber^LotNumber^SerialNumber"
+11 QUIT
POITEMW ; Write PO Item Data
+1 ;
+2 NEW GPOID,GPOND
+3 SET GPOID=0
SET GPOND=""
+4 FOR
SET GPOID=$ORDER(^TMP($JOB,"POITEM",GPOID))
if GPOID=""
QUIT
Begin DoDot:1
+5 FOR
SET GPOND=$ORDER(^TMP($JOB,"POITEM",GPOID,GPOND))
if GPOND=""
QUIT
Begin DoDot:2
+6 WRITE !,$GET(^TMP($JOB,"POITEM",GPOID,GPOND,0))
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
POITLNH ; Write PO Line Inventory Point Header
+1 WRITE "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
+2 WRITE "LineItemIdNum^LineInvPtIdNum^LineInvPt^LineQty^LineDelivery^"
+3 WRITE "QtyReceivedToDate",!
+4 QUIT
POITLNW ; Write PO Line Inventory Point Data
+1 NEW PITL,PITL1,PITL2
+2 SET PITL=0
SET PITL1=0
SET PITL2=0
+3 FOR
SET PITL=$ORDER(^TMP($JOB,"POITEMLNINVPT",PITL))
if PITL=""
QUIT
Begin DoDot:1
+4 FOR
SET PITL1=$ORDER(^TMP($JOB,"POITEMLNINVPT",PITL,PITL1))
if PITL1=""
QUIT
Begin DoDot:2
+5 WRITE $GET(^TMP($JOB,"POITEMLNINVPT",PITL,PITL1,1,0)),!
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 QUIT
GPOITEM ; Get PO Item record
+1 SET U="^"
+2 NEW N0,N2,N4,PONUMB,STNUMB,PR2237,PODAT,CKIT,CKIT1,ITMID
+3 NEW POI1A,POI1B,POI1C,POIA,POIA1,POIA2,PO16E,PO16E1,PO16E2
+4 NEW PO17E,PO17E1,PO17E2,POIAF,POIA2A,IMID
+5 SET CKIT=$GET(^PRC(442,POID,2,0))
SET ITMID=0
+6 SET CKIT1=$PIECE(CKIT,U,3)
+7 IF +CKIT1>0
Begin DoDot:1
+8 SET ITMID=0
+9 FOR
SET ITMID=$ORDER(^PRC(442,POID,2,ITMID))
if ITMID=""
QUIT
Begin DoDot:2
+10 ; Got an item
IF +ITMID>0
Begin DoDot:3
+11 SET N0=$GET(^PRC(442,POID,2,ITMID,0))
+12 SET N2=$GET(^PRC(442,POID,2,ITMID,2))
+13 SET N4=$GET(^PRC(442,POID,2,ITMID,4))
+14 ; Loop on item
DO LPPOITM
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
DITMD ; Set PO Item Description Data
+1 NEW ITMD,ITMD1,ITMD2,ITMD3
+2 ; get 1st 50 characters from 1st desc.
+3 SET ITMD=$GET(^PRC(442,POID,2,ITMID,1,1,0))
+4 ; make sure a description exists for the PO
if ITMD=""
QUIT
+5 SET ITMD1=$PIECE(ITMD,U,1)
+6 SET ITMD2=$EXTRACT(ITMD1,1,175)
+7 SET ITMD3=PPOKEY_U_ITMID_U_1_U_ITMD2
+8 SET ^TMP($JOB,"POITEMDESC",POID,ITMID,0)=ITMD3
+9 QUIT
POLIDT ; PO line item date received
+1 NEW LIDT1,LIDT2,LIDT3,LIDT4,LIDT5,V1,V2,V3,V4,LDT1E,LDT1E1,LDT1E2
+2 SET LIDT1=$GET(^PRC(442,POID,2,ITMID,3,0))
+3 SET LIDT2=$PIECE(LIDT1,U,3)
+4 IF +LIDT2>0
Begin DoDot:1
+5 SET LIDT3=0
+6 FOR
SET LIDT3=$ORDER(^PRC(442,POID,2,ITMID,3,LIDT3))
if LIDT3=""
QUIT
Begin DoDot:2
+7 ; quit at the x-ref
if +LIDT3<0
QUIT
+8 SET LIDT4=$GET(^PRC(442,POID,2,ITMID,3,LIDT3,0))
+9 ; V1-V4 Get the data,$P the values, pad with "^" delimiters
+10 ; get external value for date received
+11 SET LDT1E=$PIECE(LIDT4,U,1)
+12 IF LDT1E'=""
SET LDT1E1=$PIECE(LDT1E,".",1)
SET LDT1E2=$$FMTE^XLFDT(LDT1E1)
+13 IF LDT1E=""
SET LDT1E2=""
+14 SET V1=LDT1E2_U_$PIECE(LIDT4,U,2)_U_$PIECE(LIDT4,U,3)_U
+15 SET V2=$PIECE(LIDT4,U,4)_U_$PIECE(LIDT4,U,5)_U
+16 SET V3=$PIECE(LIDT4,U,7)_U_$PIECE(LIDT4,U,8)
SET V4=V1_V2_V3
+17 SET LIDT5=PPOKEY_U_ITMID_U_LIDT3_U_V4
+18 IF +(LIDT3)>0
SET ^TMP($JOB,"POITEMDATEREC",POID,ITMID,LIDT3,0)=LIDT5
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
POLIINV ; PO line item Inventory Point multiple
+1 NEW POLIV,POLIV1,POLIV2,POLIV3,POLIV4,V1,V2,V3,POLE1,POLE2,POLE3
+2 SET POLIV=$GET(^PRC(442,POID,2,ITMID,5,0))
+3 SET POLIV1=$PIECE(POLIV,U,3)
+4 IF +POLIV1>0
Begin DoDot:1
+5 SET POLIV2=0
+6 SET POLIV2=$ORDER(^PRC(442,POID,2,ITMID,5,POLIV2))
if POLIV2=""
QUIT
Begin DoDot:2
+7 ; quit at the x-ref ELSE Get data, $P values
if +POLIV2<0
QUIT
+8 ;Get data values
SET POLIV3=$GET(^PRC(442,POID,2,ITMID,5,POLIV2,0))
+9 SET POLE1=$PIECE(POLIV3,U,1)
+10 IF POLE1'=""
SET POLE2=$GET(^PRCP(445,+POLE1,0))
SET POLE3=$PIECE(POLE2,U,1)
+11 IF POLE1=""
SET POLE3=""
+12 SET V1=POLE3_U_$PIECE(POLIV3,U,2)_U_$PIECE(POLIV3,U,3)_U
+13 SET V2=$PIECE(POLIV3,U,4)
SET V3=V1_V2
+14 SET POLIV4=PPOKEY_U_ITMID_U_POLIV2_U_V3
+15 IF +POLIV2>0
SET ^TMP($JOB,"POITEMLNINVPT",POID,ITMID,POLIV2,0)=POLIV4
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
LPPOITM ; Loop on PO Item
+1 ; Initialize with PPOKEY
+2 SET ^TMP($JOB,"POITEM",POID,ITMID,0)=PPOKEY_U_ITMID
+3 ; LineItem#
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,7)=$PIECE(N0,U,1)
+4 ;
+5 ;
+6 ; get value for ItemMast.Description
+7 SET POIA=$PIECE(N0,U,5)
+8 IF POIA'=""
SET POIA1=$GET(^PRC(441,+POIA,0))
SET POIA2=$PIECE(POIA1,U,2)
SET IMID=$PIECE(POIA1,U,1)
SET POIA2A=$PIECE(POIA1,U,1)
+9 IF POIA=""
SET POIA2=""
SET IMID=""
+10 ;
+11 ; ItemMast.ID#
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,8)=IMID
+12 ; ItemMast.Description
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,9)=POIA2
+13 ;
+14 ; Patch 98 CR1 fix . ITEM Master entry may have been deleted if
+15 ; POIA2'="", but value for lookup is missing (POIA2A="")
+16 ; If this is the case, S POIAF="ITEM MASTER FILE ERROR "_POIA
+17 ;
+18 IF POIA2=""
SET POIAF=""
+19 ; new logic RLL 8/9/06
IF POIA2'=""
Begin DoDot:1
+20 IF POIA2A=""
SET POIAF="ITEM MASTER FILE ERROR "_ITMID
+21 IF POIA2A'=""
SET POIAF=$PIECE($GET(^PRC(441,POIA2A,0)),U,15)
+22 QUIT
End DoDot:1
+23 ; I POIA2'="" S POIAF=$P(^PRC(441,POIA2A,0),U,15) ;original logic
+24 ; End Changes Patch 98 RLL 8/9/06
+25 ; NIF #
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,10)=POIAF
+26 ;
+27 ; Quantity
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,11)=$PIECE(N0,U,2)
+28 ; Get external value of Unit of Purchase
+29 SET POI1A=$PIECE(N0,U,3)
+30 IF POI1A'=""
SET POI1B=$GET(^PRCD(420.5,+POI1A,0))
SET POI1C=$PIECE(POI1B,U,1)
+31 IF POI1A=""
SET POI1C=""
+32 ;UnitOfPurchase
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,12)=POI1C
+33 ; PkgMult
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,13)=$PIECE(N0,U,12)
+34 ; ItmDelPoints
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,14)=$PIECE(N0,U,8)
+35 ; BOC
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,15)=$PIECE(N0,U,4)
+36 ; Contract Boa
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,16)=$PIECE(N2,U,2)
+37 ; Act Unit Cost
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,17)=$PIECE(N0,U,9)
+38 ; Est Unit Cost
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,18)=$PIECE(N0,U,7)
+39 ; get external value for Fed Supply Classification
+40 SET PO17E=$PIECE(N2,U,3)
+41 IF PO17E'=""
SET PO17E1=$GET(^PRC(441.2,+PO17E,0))
SET PO17E2=$PIECE(PO17E1,U,1)
+42 IF PO17E=""
SET PO17E2=""
+43 ;FedSupClass
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,19)=PO17E2
+44 ;VenStkNum
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,20)=$PIECE(N0,U,6)
+45 ;NatDrugCode
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,21)=$PIECE(N0,U,15)
+46 ; get external value for SKU
+47 SET PO16E=$PIECE(N0,U,16)
+48 IF PO16E'=""
SET PO16E1=$GET(^PRCD(420.5,+PO16E,0))
SET PO16E2=$PIECE(PO16E1,U,1)
+49 IF PO16E=""
SET PO16E2=""
+50 ;SKU
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,22)=PO16E2
+51 ;NSN
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,23)=$PIECE(N0,U,13)
+52 ;UnitConFactor
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,24)=$PIECE(N0,U,17)
+53 ;TotalCost
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,25)=$PIECE(N2,U,1)
+54 ;DiscItmAmt
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,26)=$PIECE(N2,U,6)
+55 ;Z410ItmNum
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,27)=$PIECE(N2,U,13)
+56 ;LotNum
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,28)=$PIECE(N4,U,17)
+57 ;SerialNum
SET $PIECE(^TMP($JOB,"POITEM",POID,ITMID,0),U,29)=$PIECE(N4,U,18)
+58 ; get 1st Item Description from multiple
DO DITMD
+59 ; get Item Date received Data from multiple
DO POLIDT
+60 DO POLIINV
+61 QUIT
+62 ;
POITDRCH ; PO Item Date Received Header
+1 WRITE "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
+2 WRITE "LineItemIdNum^DateRecIdNum^DateReceived^QtyReceived^Amount^"
+3 WRITE "PartialNumber^DiscountedAmount^AdjustedQuantityRec^AdjustedAmt",!
+4 QUIT
POITDRCW ; PO Item Date Received Data
+1 NEW PIDRC,PIDRC1,PIDRC2,PIDRC3,PIDRC4
+2 SET PIDRC=0
SET PIDRC1=0
SET PIDRC2=0
SET PIDRC3=0
+3 FOR
SET PIDRC=$ORDER(^TMP($JOB,"POITEMDATEREC",PIDRC))
if PIDRC=""
QUIT
Begin DoDot:1
+4 FOR
SET PIDRC1=$ORDER(^TMP($JOB,"POITEMDATEREC",PIDRC,PIDRC1))
if PIDRC1=""
QUIT
Begin DoDot:2
+5 FOR
SET PIDRC2=$ORDER(^TMP($JOB,"POITEMDATEREC",PIDRC,PIDRC1,PIDRC2))
if PIDRC2=""
QUIT
Begin DoDot:3
+6 ;
+7 WRITE $GET(^TMP($JOB,"POITEMDATEREC",PIDRC,PIDRC1,PIDRC2,0)),!
End DoDot:3
+8 QUIT
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
POITDSH ; PO Item Description Header
+1 WRITE "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
+2 WRITE "LineItemIdNum^LineItemDescIdNum^Description",!
+3 QUIT
POITDSW ; PO Item Description Write Data
+1 NEW PDES,PDES1,PDES2,PDES3
+2 SET PDES=0
SET PDES1=0
+3 FOR
SET PDES=$ORDER(^TMP($JOB,"POITEMDESC",PDES))
if PDES=""
QUIT
Begin DoDot:1
+4 FOR
SET PDES1=$ORDER(^TMP($JOB,"POITEMDESC",PDES,PDES1))
if PDES1=""
QUIT
Begin DoDot:2
+5 WRITE $GET(^TMP($JOB,"POITEMDESC",PDES,PDES1,0)),!
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 QUIT
