source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOP3.m@ 1314

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1PSUOP3 ;BIR/CFL,TJH,PDW-PSU PBM Outpatient Pharmacy shared variables ;08/25/2003
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ; Reference to file #7 supported by DBIA 2495
5 ; Reference to file #50 supported by DBIA 221
6 ; Reference to file #59 supported by DBIA 2510
7 ; Reference to file #200 supported by DBIA 10060
8 ; Reference to file #49 supported by DBIA 10093
9 ; Reference to file #52 supported by DBIA 2512
10 ;
11PROVDR ;Get provider data, site number and AMIS category
12 S PSUSITE=$S(PSUDIVP="":PSUSNDR,1:$$VALI^PSUTL(59,PSUDIVP,.06))
13 ;
14 ;Create storage global of division numbers and names for lab msgs.
15 S X=PSUSITE,DIC=59,DIC(0)="XM" D ^DIC
16 S X=+Y,PSUDIVNM=$$VAL^PSUTL(59,X,.01)
17 ;VMP OIFO BAY PINES;ELR;PSU*3.0*31
18 I '$L(PSUDIVNM) S X=PSUSITE D DIVNM^PSUOP6
19 S ^XTMP("PSU_"_PSUJOB,"DIV",PSUSITE)=PSUDIVNM
20 ;
21GETVAR ;Get shared variables
22 ;Get AMIS workload category
23 S PSUPST=$$VALI^PSUTL(53,PSURXP,6)
24 S PSUSC=$S(PSUPST=1:"SC",PSUPST=2:"AA",PSUPST=3:"OT",PSUPST=4:"IP",1:"")
25 S:$$GET1^DIQ(52,PSURXIEN,201)="YES" PSUSC="NVA"
26 K PSUPROV
27 D GETS^PSUTL(200,PSUPRID,"9;29;53.5;53.6","PSUPROV","I")
28 I '$D(PSUPROV) D NOPROV Q
29 D MOVEI^PSUTL("PSUPROV")
30 S PSUPRSSN=PSUPROV(9)
31 I PSUPRSSN="" S PSUPRSSN=999999999
32 S ^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUPRSSN,PSUPRID)=""
33 S PSUDOC(9)=PSUPRSSN
34 S PSUPTYP=$S(PSUPROV(53.6)=4:"F",1:"S")
35 S:$$GET1^DIQ(52,PSURXIEN,201)="YES" PSUPTYP="NVA"
36 S PSUPCLS="" I PSUPROV(53.5)'="" D
37 .S PSUPCLS=$$VALI^PSUTL(7,PSUPROV(53.5),1)
38 .I PSUPCLS="" S PSUPCLS=$$VALI^PSUTL(7,PSUPROV(53.5),.01)
39 S PSUPSV=$S($L(PSUPROV(29)):$$VAL^PSUTL(49,PSUPROV(29),.01),1:"")
40 S PSUPSV=$$UPPER^PSUTL(PSUPSV),PSUPSERV=""
41 I $L(PSUPSV),$D(PSECT(PSUPSV)) S PSUPSERV=PSECT(PSUPSV)
42 S PSUSPTY=$$GET^XUA4A72(PSUPRID,PSUFDT)
43 S PSUSP1=$P(PSUSPTY,U,3),PSUSP2=$P(PSUSPTY,U,4)
44 ;
45 Q
46 ;
47NOPROV ; set up PSUPROV array when provider isn't found in ^VA(200
48 F I=9,29,53.5,53.6 S PSUPROV(I)=""
49 S (PSUPRSSN,PSUPTYP,PSUPCLS,PSUPSERV,PSUSP1,PSUSP2)=""
50 Q
51GETDRUG ;Get drug data
52 K PSUDRUG
53 D GETS^PSUTL(50,PSUDR,".01;2;3;14.5;20;21;22;25;27;31;51;52","PSUDRUG","I")
54 D MOVEI^PSUTL("PSUDRUG")
55 I '$D(PSUDRUG) F I=.01,2,3,14.5,20,21,22,25,31,51,52 S PSUDRUG(I)=""
56 S PSUGNM=PSUDRUG(.01)
57 I PSUGNM="" S PSUGNM="Unknown Generic Name"
58 S PSUVANM=PSUDRUG(21)
59 I PSUVANM="" S PSUVANM="Unknown VA Product Name"
60 S PSUDEA=PSUDRUG(3)
61 S PSUNFI=$S(PSUDRUG(51)=1:"N/F",1:"")
62 S PSUDUN=PSUDRUG(14.5)
63 S PSUVACLS=PSUDRUG(2)
64 S PSUNDCL=PSUDRUG(22)
65 S PSUNAF=$S(PSUDRUG(52):"N/F",1:"")
66 S PSUNADR=PSUDRUG(20)
67 S PSUCMID=PSUDRUG(27)
68 ;Get the National Formulary Indicator and Restriction
69 S (PSOPNFI,PSOPNFR)=""
70 I $$VERSION^XPDUTL("PSN")'<4 D
71 .S PSOPNFI=$$FORMI^PSNAPIS(PSUNADR,PSUNDCL)
72 .S PSOPNFR=$$FORMR^PSNAPIS(PSUNADR,PSUNDCL)
73GETDRUGQ Q
74 ;
75SETREC ;Set the record into the ^XTMP global
76 S:PSUDIVP="" PSUDIVP=PSUSNDR
77 S REC1="^",REC2="*",PSU2U="^",REC3="*",REC4="*",REC5="*",REC6="*"
78 S REC1=REC1_$TR(PSUSITE,"^","'")_PSU2U_$TR(PSUFD,"^","'")_PSU2U
79 S REC1=REC1_$TR(PSURELDT,"^","'")_PSU2U_$TR(PSURXN,"^","'")_PSU2U
80 S REC1=REC1_$TR(PSUSC,"^","'")_PSU2U_PSUSSN_PSU2U_$TR(PSUVANM,"^","'")_PSU2U
81 S REC1=REC1_$TR(PSUVACLS,"^","'")_PSU2U_$TR(PSUGNM,"^","'")_PSU2U
82 S REC1=REC1_$TR(PSUNDC,"^","'")_PSU2U_$TR(PSUNFI,"^","'")_PSU2U
83 S REC1=REC1_$TR(PSOPNFI,"^","'")_PSU2U_$TR(PSOPNFR,"^","'")_PSU2U
84 S REC1=REC1_$TR(PSUDEA,"^","'")_PSU2U_$TR(PSUTYP,"^","'")_PSU2U
85 S REC1=REC1_$TR(PSUCMOP,"^","'")_PSU2U_$TR(PSUMW,"^","'")_PSU2U
86 S REC1=REC1_$TR(PSUPRSSN,"^","'")_PSU2U_$TR(PSUPTYP,"^","'")_PSU2U
87 S REC1=REC1_PSU2U_$TR(PSUWPC,"^","'")_PSU2U
88 S REC1=REC1_$TR(PSUDUN,"^","'")_PSU2U_$TR(PSUDRCT,"^","'")_PSU2U
89 S REC1=REC1_$TR(PSUDS,"^","'")_PSU2U_$TR(PSUQTY,"^","'")_PSU2U_PSUNAF_U
90 D ICN^PSUV2 S PSUPICN=$G(^XTMP("PSU_"_PSUJOB,"PSUPICN"))
91 S REC1=REC1_$G(PSUPICN)_PSU2U_PSUPRID_PSU2U_$G(PSUCAN)_"^"
92 ;
93 ;
94 ;**Add AMIS data
95 ;
96 S REC2=REC2_$G(PSUCLN)_PSU2U ;Clinic
97 ;
98 S REC2=REC2_$G(PSUCMID)_PSU2U ;CMOP ID
99 ;
100 I $G(PSUFP) D
101 .S REC2=REC2_PSUSITE_$G(PSUFP)_PSU2U ;Finishing person
102 I '$G(PSUFP) D
103 .S REC2=REC2_PSU2U
104 ;
105 ;Login dates for new orders, refills, and partials
106 I PSUTYP="N" S REC2=REC2_$G(PSUORDT)_PSU2U ;New fills
107 I PSUTYP="R" S REC2=REC2_$G(PSUREDT)_PSU2U ;Refills
108 I PSUTYP="P" S REC2=REC2_$G(PSUPDT)_PSU2U ;Partials
109 ;
110 S REC2=REC2_$G(PSUCOPAY)_PSU2U ;Copay status
111 S REC2=REC2_$E($G(PSUPI),1,80)_PSU2U ;Expanded Instructions
112 S REC2=REC2_$G(PSUMDFLG)_PSU2U ;Multidose Flag
113 ;
114 ;**Single dose date and first dose of multidose data
115 ;are in the following records**
116 ;
117 S REC2=REC2_$G(PSUDSG)_PSU2U ;Dosage Ordered
118 S REC2=REC2_$G(PSUDISPU)_PSU2U ;Dispense units
119 S REC2=REC2_$G(PSUNITS)_PSU2U ;Units
120 S REC2=REC2_$G(PSUNOUN)_PSU2U ;Noun
121 S REC2=REC2_$G(PSUDUR)_PSU2U ;Duration
122 S REC2=REC2_$G(PSUCONJ)_PSU2U ;Conjunction
123 S REC2=REC2_$G(PSUROUT)_PSU2U ;Route
124 S REC2=REC2_$G(PSUSCHED)_PSU2U ;Schedule
125 S REC2=REC2_$G(PSUVERB)_PSU2U ;Verb
126 ;
127 ;**End of Single dose/First multidose data
128 ;
129 ;**The following are single dose globals for MailMan
130 ;
131 S PSURCT=1+$P($G(^XTMP(PSUOPSUB,"DATA",PSUSITE,PSURXIEN,0)),U,1)
132 S ^XTMP(PSUOPSUB,"DATA",PSUSITE,PSURXIEN,PSURCT,1)=REC1
133 S ^XTMP(PSUOPSUB,"DATA",PSUSITE,PSURXIEN,PSURCT,2)=REC2
134 S $P(^XTMP(PSUOPSUB,"DATA",PSUSITE,PSURXIEN,0),U,1)=PSURCT
135 I (($E(PSUOPVER)=6)&(PSUTYP="P"))!($E(PSUOPVER)>6) S ^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)=""
136 ;**End of single dose globals for MailMan
137 ;
138 ;**Multidose records
139 ;
140 I $D(PSUMDFLG) D
141 .S PSUD1=1
142 .F S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1)) Q:PSUD1="" D
143 ..S PSUAMMD=^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1,0)
144 ..D MULTI^PSUOPAM ;Set multidose variables
145 ..I $L(REC3)>180 D REC4 Q
146 ..S REC3=REC3_$G(PSUDSGMD)_PSU2U ;Dosage Ordered
147 ..S REC3=REC3_$G(PSUDSPMD)_PSU2U ;Dispense units
148 ..S REC3=REC3_$G(PSUNITMD)_PSU2U ;Units
149 ..S REC3=REC3_$G(PSUNMD)_PSU2U ;Noun
150 ..S REC3=REC3_$G(PSUDURMD)_PSU2U ;Duration
151 ..S REC3=REC3_$G(PSUCONMD)_PSU2U ;Conjunction
152 ..S REC3=REC3_$G(PSURTMD)_PSU2U ;Route
153 ..S REC3=REC3_$G(PSUSCHMD)_PSU2U ;Schedule
154 ..S REC3=REC3_$G(PSUVRBMD)_PSU2U ;Verb
155 ..;
156 ..;**End of Multidose data
157 ..;**End AMIS data
158 ..;
159 ..;
160 ..;global for multidose records for MailMan
161 I $D(PSUMDFLG) D
162 .S PSURCT=1+$P($G(^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,0)),U,1)
163 .S ^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,PSURCT,1)=REC1
164 .S ^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,PSURCT,2)=REC2
165 .S ^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,PSURCT,3)=REC3
166 .I $L(REC4)>1 S ^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,PSURCT,4)=REC4
167 .I $L(REC5)>1 S ^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,PSURCT,5)=REC5
168 .I $L(REC6)>1 S ^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,PSURCT,6)=REC6
169 .;
170 .S $P(^XTMP(PSUOPSUB,"DATAMD",PSUSITE,PSURXIEN,0),U,1)=PSURCT
171 ;
172 I '$D(^XTMP("PSU_"_PSUJOB,"PSUOPFLG")) D
173 .D LAB^PSULR0("OP",PSUSITE,PSURXIEN,DFN,PSUGNM,PSUVACLS)
174SUMDRUG ; total drug info for summary report
175 S PSUVARS="PSUTPART,PSUTFIL,PSUTRFIL,PSUTCST,PSUTQTY"
176 S PSUREC=$G(^XTMP(PSUOPSUB,"DRUG",PSUSITE,PSUGNM,PSUCMOP))
177 F I=1:1:5 S @$P(PSUVARS,",",I)=+$P(PSUREC,U,I)
178 I PSUTYP="P" S PSUTPART=PSUTPART+1
179 I PSUTYP="N" S PSUTFIL=PSUTFIL+1
180 I PSUTYP="R" S PSUTRFIL=PSUTRFIL+1
181 S PSUTQTY=PSUQTY+PSUTQTY
182 S PSUTCST=(PSUDRCT*PSUQTY)+PSUTCST
183 S REC=PSUTPART_U_PSUTFIL_U_PSUTRFIL_U_$J(PSUTCST,0,2)_U_$J(PSUTQTY,0,2)
184 S $P(REC,U,6)=$S(PSUNFI="N/F":"*",1:"")
185 S $P(REC,U,7)=$S(PSOPNFI="0":"#",1:"")
186 S ^XTMP(PSUOPSUB,"DRUG",PSUSITE,PSUGNM,PSUCMOP)=REC
187 Q
188 ;
189REC4 ;Multidose records greater than 200 characters in length
190 ;
191 I $L(REC4)>180 D REC5 Q
192 S REC4=REC4_$G(PSUDSGMD)_PSU2U ;Dosage Ordered
193 S REC4=REC4_$G(PSUDSPMD)_PSU2U ;Dispense units
194 S REC4=REC4_$G(PSUNITMD)_PSU2U ;Units
195 S REC4=REC4_$G(PSUNMD)_PSU2U ;Noun
196 S REC4=REC4_$G(PSUDURMD)_PSU2U ;Duration
197 S REC4=REC4_$G(PSUCONMD)_PSU2U ;Conjunction
198 S REC4=REC4_$G(PSURTMD)_PSU2U ;Route
199 S REC4=REC4_$G(PSUSCHMD)_PSU2U ;Schedule
200 S REC4=REC4_$G(PSUVRBMD)_PSU2U ;Verb
201 Q
202REC5 ;
203 I $L(REC5)>180 D REC6 Q
204 S REC5=REC5_$G(PSUDSGMD)_PSU2U ;Dosage Ordered
205 S REC5=REC5_$G(PSUDSPMD)_PSU2U ;Dispense units
206 S REC5=REC5_$G(PSUNITMD)_PSU2U ;Units
207 S REC5=REC5_$G(PSUNMD)_PSU2U ;Noun
208 S REC5=REC5_$G(PSUDURMD)_PSU2U ;Duration
209 S REC5=REC5_$G(PSUCONMD)_PSU2U ;Conjunction
210 S REC5=REC5_$G(PSURTMD)_PSU2U ;Route
211 S REC5=REC5_$G(PSUSCHMD)_PSU2U ;Schedule
212 S REC5=REC5_$G(PSUVRBMD)_PSU2U ;Verb
213 Q
214REC6 ;
215 S REC6=REC6_$G(PSUDSGMD)_PSU2U ;Dosage Ordered
216 S REC6=REC6_$G(PSUDSPMD)_PSU2U ;Dispense units
217 S REC6=REC6_$G(PSUNITMD)_PSU2U ;Units
218 S REC6=REC6_$G(PSUNMD)_PSU2U ;Noun
219 S REC6=REC6_$G(PSUDURMD)_PSU2U ;Duration
220 S REC6=REC6_$G(PSUCONMD)_PSU2U ;Conjunction
221 S REC6=REC6_$G(PSURTMD)_PSU2U ;Route
222 S REC6=REC6_$G(PSUSCHMD)_PSU2U ;Schedule
223 S REC6=REC6_$G(PSUVRBMD)_PSU2U ;Verb
224 Q
Note: See TracBrowser for help on using the repository browser.