Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHLO2

PRCHLO2.m

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