source: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR2.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ; 4/1/08 4:09pm
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3
3 ;DBIAs
4 ; Reference to file #58.811 supported by DBIA 2521
5 ; Reference to file #51.5 supported by DBIA 1931
6 ; Reference to file #50 supported by DBIA 221
7 ; Reference to file #58.8 supported by DBIA 2519
8 ; Reference to file #42 supported by DBIA 2440
9 ; Reference to file #40.8 supported by DBIA 2438
10 ; Reference to file #59.5 supported by DBIA 2499
11 ; Reference to file #59 supported by DBIA 2510
12 ;
13EN ;
14 S PSUEND=PSUEDT
15 S PSUEDT=PSUEDT\1+.24
16 S:'$D(PSUPRJOB) PSUPRJOB=$J
17 S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J
18 I '$D(^XTMP(PSUPRSUB)) D
19 . S ^XTMP(PSUPRSUB,"RECORDS",0)=""
20 . S X1=DT,X2=6 D C^%DTC
21 . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction"
22 ;
23 S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
24 D MAP
25 ;
26 ; check for Drug Accountability
27 S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY")
28 I 'X Q ; not installed
29 ;
30 S X1=PSUSDT,X2=-45 ;backup by 45 days per revision
31 D C^%DTC
32 S PSUDT=X
33 ; loop thru invoice date field xref
34 F S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT Q:PSUDT'>0 D
35 . S PSUORDA=0 F S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0 D
36 .. S PSUINVDA=0 F S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0 D INVOICE
37 Q
38 ;
39INVOICE ;EP process an invoice within an order
40 N PSUSTAT
41 S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2)
42 I PSUSTAT'="C" Q ; 3.2.6.1
43 N PSUORD
44 D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD")
45 ;
46 S PSUINV=""
47 N PSURDT,PSUIVNUM
48 D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I")
49 D MOVEI^PSUTL("PSUINV")
50 S PSURDT=PSUINV(8)
51 S PSUIVNUM=PSUINV(.01)
52 ;
53 I $G(PSUINV(4)) D DIV
54 I $L(PSUDIV) S PSUDIVI=""
55 E S PSUDIV=PSUSNDR,PSUDIVI="H"
56 ;
57 ;
58 K ^TMP($J,"PSUMIT") ; array for multiple items
59 D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I")
60 I '$D(^TMP($J,"PSUMIT")) Q ;
61 D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
62 ;
63 S PSUITDA=0 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM
64 Q
65ITEM ;EP process one item within the invoice
66 N PSUIT ; array for one item
67 M PSUIT=^TMP($J,"PSUMIT",PSUITDA)
68 ;
69 I (PSUIT(7)<PSUSDT) Q
70 I (PSUIT(7)>PSUEDT) Q
71 ; pull adjustments 3.2.6.2.8
72 N PSUMADJ
73 D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I")
74 I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ")
75 ;
76 ;
77 ; Review/Process Adjustments
78 I $D(PSUMADJ) S PSUADJDA=0 F S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0 D
79 . N PSUADJ
80 . M PSUADJ=PSUMADJ(PSUADJDA)
81 . ;
82 . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5) ; 3.2.6.2.8 Drug or Supply
83 . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5) ; 3.2.6.2.11 OrderUnits
84 . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5) ; 3.2.6.2.12 Price
85 . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity
86 . Q
87 ;
88 I 'PSUIT(2) Q ; per Lina 10/7/98 if qty = 0 don't send record
89 ; work on the order unit PSUIT(3)
90 I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina
91 I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11
92 ;
93 ; further process item fields 3.2.6.2.9 +
94 ;
95 ; look for/ construct Dispense Units per Order Unit
96 ; Store in PSUIT(9999) 3.2.6.2.13
97 ; Get Related Drug Fields 3.2.6.2.9
98 ;
99 N PSUDRUG
100 S PSUDRDA=0
101 ; if PSUIT(1) is a supply item the following will not be computed
102 I PSUIT(1)=+PSUIT(1) D
103 . S PSUDRDA=PSUIT(1)
104 . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
105 . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I")
106 . D MOVEI^PSUTL("PSUDRUG")
107 . S PSUIT(1)=PSUDRUG(.01) ; Generic Name
108 . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name"
109 . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC"
110 ; further process fields
111 ; fill in drug fields for supply items
112 I 'PSUDRDA D
113 . S PSUDRUG(.01)="Unknown Generic Name"
114 . S PSUDRUG(21)="Unknown VA Product Name"
115 . S PSUDRUG(31)="No NDC"
116 ;
117 ; NDC
118 I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC"
119 ;
120 ; dispense units per order unit 3.2.6.2.13
121 ;
122 S PSUIT(9999)=0
123 I $L(PSUIT(13)),$G(PSUDRDA) D
124 . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,""))
125 . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403")
126 ;
127 I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina
128 ;
129 ;PSU*4*13 Comment out To prevent XINDEX from complaining about
130 ; ^PSUPR7 (CoreFLS remnance)
131 ;Create "RECORDS" global for CoreFLS data
132 ;I $D(PSUFLSFG) S PSUA="" D
133 ;.F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7
134 ;
135 ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC)
136 S PSUR=$$RECORD()
137 ; Store Records by Division
138 S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
139 S PSULC=PSULC+1
140 S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR
141 Q
142 ;
143RECORD() ;EP Assemble record
144 N PSUR
145 S PSUR(2)=$G(PSUDIV)
146 S PSUR(3)=$G(PSUDIVI)
147 S PSUR(4)=PSUIT(7)\1 ; 3.2.6.2.2
148 S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9
149 S PSUR(6)=$G(PSUDRUG(2)) ; ""
150 S PSUR(7)=PSUIT(1) ; 3.2.6.2.8
151 S PSUR(9)=PSUIT(13) ; 3.2.6.2.9
152 S PSUR(10)=PSUIT(14) ; ""
153 S PSUR(11)=PSUIT(15) ; ""
154 S PSUR(12)=$G(PSUDRUG(14.5)) ; ""
155 S PSUR(13)=PSUIT(3) ; 3.2.6.2.11
156 S PSUR(16)=PSUIT(9999) ; 3.2.6.2.13
157 S PSUR(17)=PSUIT(2) ; 3.2.6.2.10
158 S PSUR(18)=PSUIT(4) ; 3.2.6.2.12
159 S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14
160 S PSUR(20)=PSUORD(1) ; 3.2.6.2.5
161 S PSUR(21)=PSUINV(.01) ; 3.2.6.2.6
162 S PSUR(22)=""
163 S PSUR=""
164 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'")
165 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,U,I)=PSUR(I)
166 S PSUR=PSUR_U
167 Q PSUR
168 ;
169DIV ;Find division or outpatient site
170 ;
171 S PSUDIV=""
172 N MAPLOCI
173 D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I")
174 D MOVEMI^PSUTL("MAPLOCI")
175 ;
176 I $G(MAPLOCI(PSUINV(4),.01)) D
177 .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
178 .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
179 I '$G(MAPLOCI(PSUINV(4),.01)) D
180 .S PSUDIV=PSUSNDR
181 .S PSUDIVI="H"
182 Q
183 ;
184 ;
185MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy
186 ;Location is mapped to a division or outpatient site. If it is not
187 ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a
188 ;global to be mailed to the user.
189 ;
190 K NAOU,DAPH
191 K MAPLOCI,MAPLOC
192 S PSUNAM=0 ;This is the name of the NAOU or DA PHARMACY
193 ;
194 F S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM="" D
195 .S IEN=0
196 .F S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN="" D
197 ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)")
198 ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN)
199 ..D MAP1
200 ;
201 Q
202 ;
203MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks
204 ;to see if it is in file 59.7, field 90.02 or 90.03.
205 ;
206 ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is
207 ;no value in subfield .02 or .03, then an NAOU has not been mapped.
208 ;
209 ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is
210 ;no value in subfield .02 or .03, then a DA PHARMACY location has not
211 ;been mapped.
212 ;
213 ;Keep only the entries that are NOT mapped
214 ;
215 N PSUDA
216 ;
217 ;Look for unmapped NAOU's
218 ;I $G(NAOU(IEN),1) D
219 I $G(^PS(59.7,1,90.02,IEN,0)) D
220 .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI")
221 .S PSUDA=0
222 .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D
223 ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA)
224 ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA)
225 M ^XTMP(PSUARSUB,"NAOU")=NAOU ;only unmapped NAOU locations.
226 ;
227 ;
228 ;Look for unmapped DA PHARM
229 I $G(^PS(59.7,1,90.03,IEN,0)) D
230 .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC")
231 .S PSUDA=0
232 .F S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA="" D
233 ..;PSU*4*13 Correct Problm DA Pharm Report
234 ..I $G(MAPLOC(PSUDA,.02))'="" K DAPH(PSUDA)
235 ..I $G(MAPLOC(PSUDA,.03))'="" K DAPH(PSUDA)
236 M ^XTMP(PSUARSUB,"DAPH")=DAPH ;only unmapped DA PHARM locations.
237 Q
238 ;
239WRD() ;EP Process for ward;
240 N PSUWD,PSUWDDA,PSUDIV
241 S PSUDIV=""
242 D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I")
243 D MOVEMI^PSUTL("PSUWD")
244 ; loop ward pointers
245 S PSUWDDA=0
246 F S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0 D Q:$L(PSUDIV)
247 . S X=$$VALI^PSUTL(42,PSUWDDA,.015)
248 . Q:'X
249 . S X=$$VALI^PSUTL(40.8,X,1)
250 . I $L(X) S PSUDIV=X
251 ; return value of PSUDIV "" or = facility number
252 Q PSUDIV
253 ;
254INP() ;EP Process for Inpatient
255 ; within package call to AR/WS that pulls/builds Inpatient AOU Site
256 ; uses IEN Value to AOU STATs file 58.5
257 N PSUARSUB,PSUARJOB
258 S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2)
259 N PSULOC
260 S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB
261 S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found
262 S:X="NULL" X=""
263 Q X
264 ;
265IV() ;EP Process,PSUIVDA for IV
266 ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY)
267 N PSUIV,PSUDIV
268 S PSUDIV=""
269 D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I")
270 D MOVEMI^PSUTL("PSUIV")
271 S PSUIVDA=0
272 F S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0 D Q:$L(PSUDIV)
273 . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02)
274 . I X S X=$$VALI^PSUTL(40.8,X,1)
275 . I $L(X) S PSUDIV=X
276 ;
277 Q PSUDIV
278 ;
279OUT() ;EP Process for Outpatient
280 S X=$$VALI^PSUTL(58.8,PSULOC,20)
281 I X S X=$$VALI^PSUTL(59,X,.06)
282 Q X
283 ;
Note: See TracBrowser for help on using the repository browser.