source: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUV2.m

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

initial load of FOIAVistA 6/30/08 version
File size: 7.8 KB
Line 
1PSUV2 ;BIR/CFL - IV functions and subroutines ;25 AUG 1998
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ;DBIA'S
5 ;Reference to file #2 supported by DBIA 10035 and 2701
6 ;
7GETRATE(TYPE) ;Determine if the IV type is schedule or infusion rate and calculate the subtotal of each type
8 S PSURATE=""
9 I TYPE="P" D
10 .S PSURATE=PSUIV(.09)
11 .S ^XTMP(PSUIVSUB,"TPIG",PSUFAC)=$G(^XTMP(PSUIVSUB,"TPIG",PSUFAC))+PSUDISP
12 I TYPE="A" D
13 .S PSURATE=PSUIV(.08)
14 .S ^XTMP(PSUIVSUB,"TADM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TADM",PSUFAC))+PSUDISP
15 I TYPE="H" D
16 .S PSURATE=PSUIV(.08)
17 .S ^XTMP(PSUIVSUB,"THYP",PSUFAC)=$G(^XTMP(PSUIVSUB,"THYP",PSUFAC))+PSUDISP
18 I TYPE="S"&(PSUIV(108)=1) D
19 .S PSURATE=PSUIV(.09)
20 .S ^XTMP(PSUIVSUB,"TSYR",PSUFAC)=$G(^XTMP(PSUIVSUB,"TSYR",PSUFAC))+PSUDISP
21 I TYPE="S"&(PSUIV(108)=0) D
22 .S PSURATE=PSUIV(.08)
23 .S ^XTMP(PSUIVSUB,"TSYR",PSUFAC)=$G(^XTMP(PSUIVSUB,"TSYR",PSUFAC))+PSUDISP
24 I TYPE="C"&(PSUIV(106)="P") D
25 .S PSURATE=PSUIV(.09)
26 .S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
27 I TYPE="C"&(PSUIV(106)="A") D
28 .S PSURATE=PSUIV(.08)
29 .S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
30 I TYPE="C"&(PSUIV(106)="S")&(PSUIV(108)=1) D
31 .S PSURATE=PSUIV(.09)
32 .S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
33 I TYPE="C"&(PSUIV(106)="S")&(PSUIV(108)=0) D
34 .S PSURATE=PSUIV(.08)
35 .S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
36 Q
37SETREC ;Set the ^XTMP global for IV Additives and Solutions
38 S REC="^",DLM="^",INDEX=""
39 I RECTYP="P" D ;Record type of "P" indicates parent record.
40 .S REC=REC_$TR(PSUFAC,"^","'")_DLM_$TR(PSUIV(.02),"^","'")_DLM_PSUIV(.01)_DLM
41 .S REC=REC_RECTYP_DLM_$TR(PSUIV(.04),"^","'")_DLM_PSUOUTP_DLM_PSUSSN_DLM
42 .S REC=REC_$G(PSURATE)_DLM_$TR(PSUDOC(9),"^","'")_DLM ;_$TR(PSUPCLS,"^","'")_DLM
43 .S REC=REC_$TR(PSUDISP,"^","'")_DLM_$TR(PSUPRNM,"^","'")_DLM
44 .S REC=REC_$TR(PSUDCLS,"^","'")_DLM_$TR(PSUNDC,"^","'")_DLM
45 .S REC=REC_$TR(PSUNFI,"^","'")_DLM_$TR(PSIVNFI,"^","'")_DLM
46 .S REC=REC_$TR(PSIVNFR,"^","'")_DLM_$TR(PSUPNAM,"^","'")_DLM
47 .S REC=REC_RECIND_DLM_$TR(PSUGNM,"^","'")_DLM_$TR(PSUDGU,"^","'")_DLM
48 .S REC=REC_PSUDCST_DLM_PSUNITS_DLM_PSUNAF_DLM_PSUDEA_DLM
49 .D ICN
50 .;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
51 .S PSUPICN=$G(^XTMP("PSU_"_PSUJOB,"PSUPICN"))
52 .S REC=REC_$G(PSUPICN)_DLM_$G(PSUIV(.06))_DLM_$G(PSUIV(.03))_U
53 .;
54 .;DAM..ADD PHASE II NEW PIECES HERE
55 .I $G(PSUDISPT) S REC=REC_PSUDISPT_U ;#IV bags dispensed
56 .I '$G(PSUDISPT) S REC=REC_0_U
57 .;
58 .I $G(PSURECT) S REC=REC_PSURECT_U ;#IV bags recycled
59 .I '$G(PSURECT) S REC=REC_0_U
60 .;
61 .I $G(PSUDEST) S REC=REC_PSUDEST_U ;#IV bags destroyed
62 .I '$G(PSUDEST) S REC=REC_0_U
63 .;
64 .I $G(PSUCAN) S REC=REC_PSUCAN_U ;#IV bags cancelled
65 .I '$G(PSUCAN) S REC=REC_0_U
66 .;
67 .I $G(PSUTDSP1) S REC=REC_PSUTDSP1_U ;Total units dispensed
68 .I '$G(PSUTDSP1) S REC=REC_0_U
69 .I $G(PSURCY1) S REC=REC_PSURCY1_U ;Total units recycled
70 .I '$G(PSURCY1) S REC=REC_0_U
71 .I $G(PSUDES1) S REC=REC_PSUDES1_U ;Total units destroyed
72 .I '$G(PSUDES1) S REC=REC_0_U
73 .I $G(PSUCAN1) S REC=REC_PSUCAN1_U ;Total units cancelled
74 .I '$G(PSUCAN1) S REC=REC_0_U
75 .;END DAM
76 .;
77 .S INDEX=$O(^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX),-1)
78 .S INDEX=INDEX+1
79 .S ^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX)=REC
80 I RECTYP'="P" D
81 .S REC=REC_$TR(PSUFAC,"^","'")_DLM_$TR(PSUIV(.02),"^","'")_DLM_PSUIV(.01)_DLM
82 .S REC=REC_DLM_DLM_DLM_PSUSSN_DLM
83 .S REC=REC_$G(PSURATE)_DLM_$TR(PSUDOC(9),"^","'")_DLM ;_$TR(PSUPCLS,"^","'")_DLM
84 .;S REC=REC_$TR(PSUSERV,"^","'")_DLM_$TR(PSUSP1,"^","'")_DLM_$TR(PSUSP2,"^","'")_DLM
85 .S REC=REC_DLM_$TR(PSUPRNM,"^","'")_DLM
86 .S REC=REC_$TR(PSUDCLS,"^","'")_DLM_$TR(PSUNDC,"^","'")_DLM
87 .S REC=REC_$TR(PSUNFI,"^","'")_DLM_$TR(PSIVNFI,"^","'")_DLM
88 .S REC=REC_$TR(PSIVNFR,"^","'")_DLM_$TR(PSUPNAM,"^","'")_DLM
89 .S REC=REC_RECIND_DLM_$TR(PSUGNM,"^","'")_DLM_$TR(PSUDGU,"^","'")_DLM
90 .S REC=REC_PSUDCST_DLM_PSUNITS_DLM_PSUNAF_DLM_PSUDEA_DLM
91 .S REC=REC_$G(PSUPICN)_DLM_$G(PSUDIEN)_DLM_$G(PSUIV(.03))_U
92 .;
93 .;New AMIS Additive/Solution code set here DAM
94 .S REC=REC_U_U_U_U ;sets pieces 29 through 32 to null
95 .I RECIND="A" D ;Additives
96 ..I $G(PSUTDSP1) S REC=REC_PSUTDSP1_U ;Total units dispensed
97 ..I '$G(PSUTDSP1) S REC=REC_0_U
98 ..I $G(PSURCY1) S REC=REC_PSURCY1_U ;Total units recycled
99 ..I '$G(PSURCY1) S REC=REC_0_U
100 ..I $G(PSUDES1) S REC=REC_PSUDES1_U ;Total units destroyed
101 ..I '$G(PSUDES1) S REC=REC_0_U
102 ..I $G(PSUCAN1) S REC=REC_PSUCAN1_U ;Total units cancelled
103 ..I '$G(PSUCAN1) S REC=REC_0_U
104 .;
105 .I RECIND="S" D ;Solutions
106 ..I $G(PSUTSOL1) S REC=REC_PSUTSOL1_U ;Total units dispensed
107 ..I '$G(PSUTSOL1) S REC=REC_0_U
108 ..I $G(PSUTRS1) S REC=REC_PSUTRS1_U ;Total units recycled
109 ..I '$G(PSUTRS1) S REC=REC_0_U
110 ..I $G(PSUTDS1) S REC=REC_PSUTDS1_U ;Total units destroyed
111 ..I '$G(PSUTDS1) S REC=REC_0_U
112 ..I $G(PSUTCS1) S REC=REC_PSUTCS1_U ;Total units cancelled
113 ..I '$G(PSUTCS1) S REC=REC_0_U
114 .;End DAM
115 .;
116 .I '$D(^XTMP(PSUIVSUB,"RECORDS",PSUFAC)) S INDEX=0
117 .S INDEX=$O(^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX),-1)
118 .S INDEX=INDEX+1
119 .S ^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX)=REC
120 D LAB^PSULR0("IV",PSUFAC,PSUODA,PSUPDA,PSUGNM,PSUDCLS)
121 Q
122SETDRUG ;Set the ^XTMP global for the drug distribution report
123 S REC=""
124 I '$D(^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)) S ^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)=""
125 S DATA=^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)
126 S REC=PSUDGU_U_(PSUNITS+$P(DATA,"^",2))
127 S REC=REC_U_(PSUDISP+$P(DATA,"^",3))_U_PSUNFI_U_PSIVNFI
128 S ^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)=REC
129 Q
130SETSUM ;Set the ^XTMP global for the summary information
131 S PSUFAC=""
132 F S PSUFAC=$O(PSUFAC(PSUFAC)) Q:PSUFAC="" D
133 .S PSUTORD=$G(^XTMP(PSUIVSUB,"ORD",PSUFAC),0)
134 .S PSUTPAT=$G(^XTMP(PSUIVSUB,"SSN",PSUFAC),0)
135 .S PSUTCST=$G(^XTMP(PSUIVSUB,"CST",PSUFAC),0)
136 .S PSUTOP=$G(^XTMP(PSUIVSUB,"OORD",PSUFAC),0)
137 .S PSUODSP=$G(^XTMP(PSUIVSUB,"ODISP",PSUFAC),0)
138 .S PSUOCST=$G(^XTMP(PSUIVSUB,"OCST",PSUFAC),0)
139 .S PSUTPIG=$G(^XTMP(PSUIVSUB,"TPIG",PSUFAC),0)
140 .S PSUTSYR=$G(^XTMP(PSUIVSUB,"TSYR",PSUFAC),0)
141 .S PSUTHYP=$G(^XTMP(PSUIVSUB,"THYP",PSUFAC),0)
142 .S PSUTADM=$G(^XTMP(PSUIVSUB,"TADM",PSUFAC),0)
143 .S PSUTCHEM=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC),0)
144 .S PSUSPIG=$G(^XTMP(PSUIVSUB,"SPIG",PSUFAC),0)
145 .S PSUSSYR=$G(^XTMP(PSUIVSUB,"SSYR",PSUFAC),0)
146 .S PSUSHYP=$G(^XTMP(PSUIVSUB,"SHYP",PSUFAC),0)
147 .S PSUSADM=$G(^XTMP(PSUIVSUB,"SADM",PSUFAC),0)
148 .S PSUSCHEM=$G(^XTMP(PSUIVSUB,"SCHEM",PSUFAC),0)
149 .S PSUBPIG=$G(^XTMP(PSUIVSUB,"TYPE_P",PSUFAC),0)
150 .S PSUBSYR=$G(^XTMP(PSUIVSUB,"TYPE_S",PSUFAC),0)
151 .S PSUBHYP=$G(^XTMP(PSUIVSUB,"TYPE_H",PSUFAC),0)
152 .S PSUBADM=$G(^XTMP(PSUIVSUB,"TYPE_A",PSUFAC),0)
153 .S PSUBCHEM=$G(^XTMP(PSUIVSUB,"TYPE_C",PSUFAC),0)
154 .S PSUAPIG=$S(PSUBPIG:PSUSPIG/PSUBPIG,1:"")
155 .S PSUASYR=$S(PSUBSYR:PSUSSYR/PSUBSYR,1:"")
156 .S PSUAHYP=$S(PSUBHYP:PSUSHYP/PSUBHYP,1:"")
157 .S PSUAADM=$S(PSUBADM:PSUSADM/PSUBADM,1:"")
158 .S PSUACHEM=$S(PSUBCHEM:PSUSCHEM/PSUBCHEM,1:"")
159 .S PSUTBAGS=PSUBPIG+PSUBSYR+PSUBHYP+PSUBADM+PSUBCHEM
160 .S REC=PSUTORD_U_PSUTPAT_U_PSUTBAGS_U_$J(PSUTCST,0,2)_U_PSUTOP_U
161 .S REC=REC_PSUODSP_U_$J(PSUOCST,0,2)_U_PSUBPIG_U_$J(PSUAPIG,0,2)
162 .S REC=REC_U_PSUBHYP_U_$J(PSUAHYP,0,2)_U_PSUBADM_U_$J(PSUAADM,0,2)
163 .S REC=REC_U_PSUBCHEM_U_$J(PSUACHEM,0,2)_U_PSUBSYR_U_$J(PSUASYR,0,2)
164 .S ^XTMP(PSUIVSUB,"SUMMARY",PSUFAC,0)=REC
165 .S PSUDIV=PSUFAC D GETDIV^PSUV3 I PSUDIVNM'="" D
166 ..S ^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIVNM)=PSUTPAT
167 .I PSUDIVNM="" S ^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIV)=PSUTPAT
168 Q
169 ;
170ICN ;Find patient ICN
171 ;VMP OIFO BAY PINES;ELR;PSU*3.0*24
172 ;
173 N PSUPICN,PSUPICN1,PSUICN
174 I $G(PSUSSN),PSUSSN'="" D
175 .S PSUPTN=0
176 .F S PSUPTN=$O(^DPT("SSN",PSUSSN,PSUPTN)) Q:PSUPTN="" D
177 ..S PSUPICN1=$$GETICN^MPIF001(PSUPTN) D
178 ...I PSUPICN1'[-1 D
179 ....S ^XTMP("PSU_"_PSUJOB,"PSUPICN")=PSUPICN1
180 ...I PSUPICN1[-1 S ^XTMP("PSU_"_PSUJOB,"PSUPICN")=""
181 Q
Note: See TracBrowser for help on using the repository browser.