source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUUD6.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1PSUUD6 ;BIR/DAM - UD AMIS Summary Message I;23 MAR 2004
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ;Reference to file #42.6 supported by DBIA 4597
5 ;Reference to file #42.7 supported by DBIA 4598
6 ;Reference to file #40.8 supported by DBIA 2438
7 ;
8EN ;Entry point to construct globals for AMIS summary message
9 ;Called from PSUUD3
10 ;
11 K UDAM ;array to hold tabulated data
12 K SPEC ;array to hold specialty data
13 ;
14 S PSUDV=0
15 F S PSUDV=$O(^XTMP(PSUUDSUB,"DIS",PSUDV)) Q:PSUDV="" D
16 .D DISP
17 .D RET
18 .D TCOST
19 .D NET
20 .D AVG
21 .D TRUNC
22 .D SPEC
23 .D DIVT
24 .D GRAND
25 ;
26 D TOTAL
27 ;
28 Q
29 ;
30DISP ;Add doses dispensed of all drugs for each division
31 ;
32 N DSP,A
33 S DSP=^XTMP(PSUUDSUB,"DISP",PSUDV)
34 S $P(UDAM(PSUDV),U,1)=DSP
35 ;
36 I $P(UDAM(PSUDV),U,1)["." D
37 .S A=$F($P(UDAM(PSUDV),U,1),".") ;Find 1st position after decimal
38 .S $P(UDAM(PSUDV),U,1)=$E($P(UDAM(PSUDV),U,1),1,(A-2)) ;Truncate
39 ;
40 Q
41 ;
42RET ;Add doses returned of all drugs for each division
43 ;
44 N RET,A
45 S RET=^XTMP(PSUUDSUB,"RET",PSUDV)
46 S $P(UDAM(PSUDV),U,2)=RET
47 ;
48 I $P(UDAM(PSUDV),U,2)["." D
49 .S A=$F($P(UDAM(PSUDV),U,2),".") ;Find 1st position after decimal
50 .S $P(UDAM(PSUDV),U,2)=$E($P(UDAM(PSUDV),U,2),1,(A-2)) ;Truncate
51 Q
52 ;
53NET ;Calculate Net doses dispensed of all drugs
54 ;
55 S $P(UDAM(PSUDV),U,3)=$P(UDAM(PSUDV),U,1)-$P(UDAM(PSUDV),U,2)
56 ;
57 Q
58 ;
59TCOST ;Find total cost per drug
60 ;
61 N CST,DP,RT,NT
62 ;
63 S CST=^XTMP(PSUUDSUB,"CST",PSUDV) ;Price per dispensed unit
64 ;
65 S $P(UDAM(PSUDV),U,4)=CST
66 ;
67 Q
68 ;
69AVG ;Calculate average cost per dose
70 ;
71 N TCST,NET
72 ;
73 S NET=$P(UDAM(PSUDV),U,3) ;Net doses dispensed
74 ;
75 I $G(NET)'>0 S NET=1
76 ;
77 S TCST=$P(UDAM(PSUDV),U,4) ;Total cost
78 ;
79 S $P(UDAM(PSUDV),U,5)=$P($G(UDAM(PSUDV)),U,5)+(TCST/NET)
80 ;
81 Q
82 ;
83TRUNC ;Truncate pieces with dollar values to 2 decimal places
84 ;
85 F I=4:1:5 D
86 .N A,B,C
87 .;
88 .I $P(UDAM(PSUDV),U,I)'["." D Q
89 ..S $P(UDAM(PSUDV),U,I)=$P(UDAM(PSUDV),U,4)_".00"
90 .;
91 .S A=$F($P(UDAM(PSUDV),U,I),".") ;Find 1st position after decimal
92 .;
93 .S B=$E($P(UDAM(PSUDV),U,I),1,(A-1)) ;Extract dollars and decimal
94 .;
95 .S C=$E($P(UDAM(PSUDV),U,I),A,(A+1)) ;Extract cents after decimal
96 .;
97 .I $L(C)'=2 S C=$E(C,1)_0
98 .;
99 .S $P(UDAM(PSUDV),U,I)=B_C
100 ;
101 M ^XTMP(PSUUDSUB,"DOSES",PSUDV)=UDAM(PSUDV)
102 Q
103 ;
104TOTAL ;Add dose totals of all divisions
105 ;
106 N DTOT,RTOT,NETOT,TCST,ACST
107 ;
108 S PSUD=0
109 F S PSUD=$O(UDAM(PSUD)) Q:PSUD="" D
110 .S DTOT=$G(DTOT)+$P(UDAM(PSUD),U,1) ;Total of doses dispensed
111 .S RTOT=$G(RTOT)+$P(UDAM(PSUD),U,2) ;Total of returned doses
112 .S NETOT=$G(NETOT)+$P(UDAM(PSUD),U,3) ;Total of net doses disp
113 .S TCST=$G(TCST)+$P(UDAM(PSUD),U,4) ;Total of total cost
114 .;S ACST=$G(ACST)+$P(UDAM(PSUD),U,5) ;Total of average cost
115 .I $G(NETOT) S ACST=$G(TCST)/$G(NETOT) D
116 ..I ACST'["." S ACST=ACST_".00" Q
117 ..N A,B,C
118 ..S A=$F(ACST,".") ;Find 1st position after decimal
119 ..S B=$E(ACST,1,(A-1)) ;Extract dollars and decimal
120 ..S C=$E(ACST,A,(A+1)) ;Extract cents after decimal
121 ..I $L(C)'=2 S C=$E(C,1)_0
122 ..S ACST=B_C
123 ;
124 S ^XTMP(PSUUDSUB,"DOSTOT")=DTOT_U_RTOT_U_NETOT_U_TCST_U_ACST
125 ;
126 Q
127 ;
128SPEC ;Find out if a monthly extract is being run
129 ;
130 N PSUMT,PSUMTH
131 I $D(PSUMON) D
132 .S PSUMT=PSUMON_"00"
133 .I $D(^DGAM(334,"B",PSUMT)) D SPEC1
134 .;
135 .S PSUMTH=PSUMT
136 .I $D(^DGAM(345,"B",PSUMTH)) D SPEC2
137 ;
138 Q
139 ;
140SPEC1 ;Find division names from File (#42.6) records within
141 ;the month of the extract
142 ;
143 N PSUDNM
144 ;
145 M SPEC(334,PSUMT)=^DGAM(334,PSUMT) ;set node into array
146 ;
147 S PSUD1=0
148 F S PSUD1=$O(SPEC(334,PSUMT,"SE",PSUD1)) Q:PSUD1="" D
149 .S PSUD2=0
150 .F S PSUD2=$O(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2)) Q:PSUD2="" D
151 ..;find division and match to DIVNM
152 ..S X=PSUD2
153 ..S PSUNM=$$VAL^PSUTL(40.8,X,.01)
154 ..S X=PSUDV,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
155 ..S X=+Y S PSUDNM=$$VAL^PSUTL(40.8,X,.01)
156 ..I PSUNM=PSUDNM D REC1
157 Q
158 ;
159REC1 ;Create a record of specialties and days of patient care for File #42.6
160 ;for each division within the month of the extract
161 ;
162 N SPC,DAYA,DAYB,SPCE
163 ;
164 S SPC=$P(SPEC(334,PSUMT,"SE",PSUD1,0),U,1) ;Specialty code
165 ;
166 S DAYA=$P(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,12) ;Days of care
167 ;
168 S DAYB=$P(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,24) ;Days of care >45
169 ;
170 ;
171 ;Find external form of specialty
172 S:SPC=334 SPCE="PSYCHIATRY"
173 S:SPC=335 SPCE="INTERMEDIATE"
174 S:SPC=336 SPCE="MEDICINE"
175 S:SPC=337 SPCE="NEUROLOGY"
176 S:SPC=338 SPCE="REHAB MEDICINE"
177 S:SPC=339 SPCE="BLIND REHAB"
178 S:SPC=340 SPCE="SPINAL CORD INJURY"
179 S:SPC=341 SPCE="SURGERY"
180 ;
181 S ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_(DAYA+DAYB) ;Record created
182 ;
183 Q
184 ;
185SPEC2 ;Find division names from File (#42.7) records within
186 ;the month of the extract
187 ;
188 N PSUDNAM
189 M SPEC(345,PSUMTH)=^DGAM(345,PSUMTH) ;set node into array
190 ;
191 S PSUD1=0
192 F S PSUD1=$O(SPEC(345,PSUMTH,"SE",PSUD1)) Q:PSUD1="" D
193 .S PSUD2=0
194 .F S PSUD2=$O(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2)) Q:PSUD2="" D
195 ..;find division and match to DIVNM
196 ..S X=PSUD2
197 ..S PSUNM=$$VAL^PSUTL(40.8,X,.01)
198 ..S X=PSUDV,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
199 ..S X=+Y S PSUDNAM=$$VAL^PSUTL(40.8,X,.01)
200 ..I PSUNM=PSUDNAM D REC2
201 ;
202 Q
203 ;
204REC2 ;Create a record of specialties and days of patient care for File #42.7
205 ;for each division within the month of the extract
206 ;
207 N SPC,DAY,SPCE
208 ;
209 S SPC=$P($G(SPEC(345,PSUMTH,"SE",PSUD1,0)),U,1) ;Specialty code
210 ;
211 S DAY=$P($G(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2,0)),U,16) ;Days of care
212 ;
213 ;Find external form of specialty
214 S:SPC=345 SPCE="VA NURSING HOME"
215 ;
216 I $D(SPCE) D
217 .S ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_DAY ;Record created
218 Q
219 ;
220DIVT ;Calculate division totals
221 ;
222 N TOT
223 S PSUSP=0
224 F S PSUSP=$O(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP)) Q:PSUSP="" D
225 .S TOT=$G(TOT)+$P(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP),U,2)
226 .S ^XTMP(PSUUDSUB,"DIVTOT",PSUDV)=TOT
227 Q
228 ;
229GRAND ;Calculate grand total of all divisions
230 ;
231 ;
232 S ^XTMP(PSUUDSUB,"GTOT")=$G(^XTMP(PSUUDSUB,"GTOT"))+$G(^XTMP(PSUUDSUB,"DIVTOT",PSUDV))
233 ;
234 Q
Note: See TracBrowser for help on using the repository browser.