source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHLO2.m@ 1154

Last change on this file since 1154 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 7.8 KB
Line 
1PRCHLO2 ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 10/16/06 2:09pm
2V ;;5.1;IFCAP;**83,98**; Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ; Continuation of PRCHLO1. This program includes the extract
5 ; logic for each of the 19 identified tables.
6 ;
7POITEM ; PoItem Table
8 ;
9 Q
10 ;
11POITEMH ; PoItem Table Header
12 ;
13 W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
14 W "LineItemIdNum^LineItemNumber^ItemMasterFileNumber^"
15 W "ItemMasterDescription^NIFNumber^"
16 ;
17 W "Quantity^UnitOfPurchase^PackagingMultiple^ItemDeliveryPoints^"
18 W "BOC^ContractBOA^ActualUnitCost^EstUnitCost^FedSupplyClass^"
19 W "VendorStockNumber^NationalDrugCode^SKU^NSN^"
20 W "UnitConversionFactor^TotalCost^DiscountedAmount^"
21 W "Z410ItemNumber^LotNumber^SerialNumber"
22 Q
23POITEMW ; Write PO Item Data
24 ;
25 N GPOID,GPOND
26 S GPOID=0,GPOND=""
27 F S GPOID=$O(^TMP($J,"POITEM",GPOID)) Q:GPOID="" D
28 . F S GPOND=$O(^TMP($J,"POITEM",GPOID,GPOND)) Q:GPOND="" D
29 . . W !,$G(^TMP($J,"POITEM",GPOID,GPOND,0))
30 . . Q
31 . Q
32 Q
33POITLNH ; Write PO Line Inventory Point Header
34 W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
35 W "LineItemIdNum^LineInvPtIdNum^LineInvPt^LineQty^LineDelivery^"
36 W "QtyReceivedToDate",!
37 Q
38POITLNW ; Write PO Line Inventory Point Data
39 N PITL,PITL1,PITL2
40 S PITL=0,PITL1=0,PITL2=0
41 F S PITL=$O(^TMP($J,"POITEMLNINVPT",PITL)) Q:PITL="" D
42 . F S PITL1=$O(^TMP($J,"POITEMLNINVPT",PITL,PITL1)) Q:PITL1="" D
43 . . W $G(^TMP($J,"POITEMLNINVPT",PITL,PITL1,1,0)),!
44 . . Q
45 . Q
46 Q
47GPOITEM ; Get PO Item record
48 S U="^"
49 N N0,N2,N4,PONUMB,STNUMB,PR2237,PODAT,CKIT,CKIT1,ITMID
50 N POI1A,POI1B,POI1C,POIA,POIA1,POIA2,PO16E,PO16E1,PO16E2
51 N PO17E,PO17E1,PO17E2,POIAF,POIA2A,IMID
52 S CKIT=$G(^PRC(442,POID,2,0)),ITMID=0
53 S CKIT1=$P(CKIT,U,3)
54 I +CKIT1>0 D
55 . S ITMID=0
56 . F S ITMID=$O(^PRC(442,POID,2,ITMID)) Q:ITMID="" D
57 . . I +ITMID>0 D ; Got an item
58 . . . S N0=$G(^PRC(442,POID,2,ITMID,0))
59 . . . S N2=$G(^PRC(442,POID,2,ITMID,2))
60 . . . S N4=$G(^PRC(442,POID,2,ITMID,4))
61 . . . D LPPOITM ; Loop on item
62 . . . Q
63 . . Q
64 . Q
65 Q
66DITMD ; Set PO Item Description Data
67 N ITMD,ITMD1,ITMD2,ITMD3
68 ; get 1st 50 characters from 1st desc.
69 S ITMD=$G(^PRC(442,POID,2,ITMID,1,1,0))
70 Q:ITMD="" ; make sure a description exists for the PO
71 S ITMD1=$P(ITMD,U,1)
72 S ITMD2=$E(ITMD1,1,175)
73 S ITMD3=PPOKEY_U_ITMID_U_1_U_ITMD2
74 S ^TMP($J,"POITEMDESC",POID,ITMID,0)=ITMD3
75 Q
76POLIDT ; PO line item date received
77 N LIDT1,LIDT2,LIDT3,LIDT4,LIDT5,V1,V2,V3,V4,LDT1E,LDT1E1,LDT1E2
78 S LIDT1=$G(^PRC(442,POID,2,ITMID,3,0))
79 S LIDT2=$P(LIDT1,U,3)
80 I +LIDT2>0 D
81 . S LIDT3=0
82 . F S LIDT3=$O(^PRC(442,POID,2,ITMID,3,LIDT3)) Q:LIDT3="" D
83 . . Q:+LIDT3<0 ; quit at the x-ref
84 . . S LIDT4=$G(^PRC(442,POID,2,ITMID,3,LIDT3,0))
85 . . ; V1-V4 Get the data,$P the values, pad with "^" delimiters
86 . . ; get external value for date received
87 . . S LDT1E=$P(LIDT4,U,1)
88 . . I LDT1E'="" S LDT1E1=$P(LDT1E,".",1),LDT1E2=$$FMTE^XLFDT(LDT1E1)
89 . . I LDT1E="" S LDT1E2=""
90 . . S V1=LDT1E2_U_$P(LIDT4,U,2)_U_$P(LIDT4,U,3)_U
91 . . S V2=$P(LIDT4,U,4)_U_$P(LIDT4,U,5)_U
92 . . S V3=$P(LIDT4,U,7)_U_$P(LIDT4,U,8),V4=V1_V2_V3
93 . . S LIDT5=PPOKEY_U_ITMID_U_LIDT3_U_V4
94 . . I +(LIDT3)>0 S ^TMP($J,"POITEMDATEREC",POID,ITMID,LIDT3,0)=LIDT5
95 . . Q
96 . Q
97 Q
98POLIINV ; PO line item Inventory Point multiple
99 N POLIV,POLIV1,POLIV2,POLIV3,POLIV4,V1,V2,V3,POLE1,POLE2,POLE3
100 S POLIV=$G(^PRC(442,POID,2,ITMID,5,0))
101 S POLIV1=$P(POLIV,U,3)
102 I +POLIV1>0 D
103 . S POLIV2=0
104 . S POLIV2=$O(^PRC(442,POID,2,ITMID,5,POLIV2)) Q:POLIV2="" D
105 . . Q:+POLIV2<0 ; quit at the x-ref ELSE Get data, $P values
106 . . S POLIV3=$G(^PRC(442,POID,2,ITMID,5,POLIV2,0)) ;Get data values
107 . . S POLE1=$P(POLIV3,U,1)
108 . . I POLE1'="" S POLE2=$G(^PRCP(445,+POLE1,0)),POLE3=$P(POLE2,U,1)
109 . . I POLE1="" S POLE3=""
110 . . S V1=POLE3_U_$P(POLIV3,U,2)_U_$P(POLIV3,U,3)_U
111 . . S V2=$P(POLIV3,U,4),V3=V1_V2
112 . . S POLIV4=PPOKEY_U_ITMID_U_POLIV2_U_V3
113 . . I +POLIV2>0 S ^TMP($J,"POITEMLNINVPT",POID,ITMID,POLIV2,0)=POLIV4
114 . . Q
115 . Q
116 Q
117LPPOITM ; Loop on PO Item
118 ; Initialize with PPOKEY
119 S ^TMP($J,"POITEM",POID,ITMID,0)=PPOKEY_U_ITMID
120 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,7)=$P(N0,U,1) ; LineItem#
121 ;
122 ;
123 ; get value for ItemMast.Description
124 S POIA=$P(N0,U,5)
125 I POIA'="" S POIA1=$G(^PRC(441,+POIA,0)),POIA2=$P(POIA1,U,2),IMID=$P(POIA1,U,1),POIA2A=$P(POIA1,U,1)
126 I POIA="" S POIA2="",IMID=""
127 ;
128 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,8)=IMID ; ItemMast.ID#
129 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,9)=POIA2 ; ItemMast.Description
130 ;
131 ; Patch 98 CR1 fix . ITEM Master entry may have been deleted if
132 ; POIA2'="", but value for lookup is missing (POIA2A="")
133 ; If this is the case, S POIAF="ITEM MASTER FILE ERROR "_POIA
134 ;
135 I POIA2="" S POIAF=""
136 I POIA2'="" D ; new logic RLL 8/9/06
137 . I POIA2A="" S POIAF="ITEM MASTER FILE ERROR "_ITMID
138 . I POIA2A'="" S POIAF=$P($G(^PRC(441,POIA2A,0)),U,15)
139 . Q
140 ; I POIA2'="" S POIAF=$P(^PRC(441,POIA2A,0),U,15) ;original logic
141 ; End Changes Patch 98 RLL 8/9/06
142 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,10)=POIAF ; NIF #
143 ;
144 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,11)=$P(N0,U,2) ; Quantity
145 ; Get external value of Unit of Purchase
146 S POI1A=$P(N0,U,3)
147 I POI1A'="" S POI1B=$G(^PRCD(420.5,+POI1A,0)),POI1C=$P(POI1B,U,1)
148 I POI1A="" S POI1C=""
149 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,12)=POI1C ;UnitOfPurchase
150 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,13)=$P(N0,U,12) ; PkgMult
151 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,14)=$P(N0,U,8) ; ItmDelPoints
152 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,15)=$P(N0,U,4) ; BOC
153 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,16)=$P(N2,U,2) ; Contract Boa
154 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,17)=$P(N0,U,9) ; Act Unit Cost
155 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,18)=$P(N0,U,7) ; Est Unit Cost
156 ; get external value for Fed Supply Classification
157 S PO17E=$P(N2,U,3)
158 I PO17E'="" S PO17E1=$G(^PRC(441.2,+PO17E,0)),PO17E2=$P(PO17E1,U,1)
159 I PO17E="" S PO17E2=""
160 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,19)=PO17E2 ;FedSupClass
161 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,20)=$P(N0,U,6) ;VenStkNum
162 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,21)=$P(N0,U,15) ;NatDrugCode
163 ; get external value for SKU
164 S PO16E=$P(N0,U,16)
165 I PO16E'="" S PO16E1=$G(^PRCD(420.5,+PO16E,0)),PO16E2=$P(PO16E1,U,1)
166 I PO16E="" S PO16E2=""
167 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,22)=PO16E2 ;SKU
168 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,23)=$P(N0,U,13) ;NSN
169 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,24)=$P(N0,U,17) ;UnitConFactor
170 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,25)=$P(N2,U,1) ;TotalCost
171 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,26)=$P(N2,U,6) ;DiscItmAmt
172 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,27)=$P(N2,U,13) ;Z410ItmNum
173 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,28)=$P(N4,U,17) ;LotNum
174 S $P(^TMP($J,"POITEM",POID,ITMID,0),U,29)=$P(N4,U,18) ;SerialNum
175 D DITMD ; get 1st Item Description from multiple
176 D POLIDT ; get Item Date received Data from multiple
177 D POLIINV
178 Q
179 ;
180POITDRCH ; PO Item Date Received Header
181 W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
182 W "LineItemIdNum^DateRecIdNum^DateReceived^QtyReceived^Amount^"
183 W "PartialNumber^DiscountedAmount^AdjustedQuantityRec^AdjustedAmt",!
184 Q
185POITDRCW ; PO Item Date Received Data
186 N PIDRC,PIDRC1,PIDRC2,PIDRC3,PIDRC4
187 S PIDRC=0,PIDRC1=0,PIDRC2=0,PIDRC3=0
188 F S PIDRC=$O(^TMP($J,"POITEMDATEREC",PIDRC)) Q:PIDRC="" D
189 . F S PIDRC1=$O(^TMP($J,"POITEMDATEREC",PIDRC,PIDRC1)) Q:PIDRC1="" D
190 . . F S PIDRC2=$O(^TMP($J,"POITEMDATEREC",PIDRC,PIDRC1,PIDRC2)) Q:PIDRC2="" D
191 . . . ;
192 . . . W $G(^TMP($J,"POITEMDATEREC",PIDRC,PIDRC1,PIDRC2,0)),!
193 . . Q
194 . . Q
195 . Q
196 Q
197POITDSH ; PO Item Description Header
198 W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
199 W "LineItemIdNum^LineItemDescIdNum^Description",!
200 Q
201POITDSW ; PO Item Description Write Data
202 N PDES,PDES1,PDES2,PDES3
203 S PDES=0,PDES1=0
204 F S PDES=$O(^TMP($J,"POITEMDESC",PDES)) Q:PDES="" D
205 . F S PDES1=$O(^TMP($J,"POITEMDESC",PDES,PDES1)) Q:PDES1="" D
206 . . W $G(^TMP($J,"POITEMDESC",PDES,PDES1,0)),!
207 . . Q
208 . Q
209 Q
Note: See TracBrowser for help on using the repository browser.