source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUV7.m@ 1688

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1PSUV7 ;BIR/DAM - IV PB AMIS Summary Data ;11 March 2004
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**4**;MARCH, 2005
3 ;
4 ;This routine gathers IV Piggyback AMIS summary data
5 ;No DBIA's needed
6 ;
7EN ;Entry point to gather AMIS data. Called from PSUV3
8 ;
9 K PSUIVA ;Array to hold temporary data
10 ;
11 ;Initialize variables for column totals
12 ;
13 ;
14 S PSUDIV=0
15 S PSUCT=0
16 F S PSUDIV=$O(^XTMP(PSUIVSUB,"RECORDS",PSUDIV)) Q:PSUDIV="" D EN1
17 Q
18 ;
19EN1 ;EN CONTINUED
20 ;
21 S PSUOR=""
22 N LDSP,LREC,LDES,CLAN,NDSP,LTOT,CNDSP
23 F S PSUCT=$O(^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT)) Q:PSUCT="" D
24 .K PSUAMIS
25 .M PSUAMIS(PSUDIV,PSUCT)=^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT)
26 .;
27 .S PSUP=""
28 .S PSUP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,5) ;parent record
29 .;
30 .S PSUTYP=""
31 .S PSUTYP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,6) ;IV TYPE
32 .;
33 .I PSUTYP="P" S PSUOR=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,4) ;IV order #
34 .;
35 .D LVPDSP
36 .D LVPREC
37 .D LVPDES
38 .D LVPCAN
39 .D LVPNET
40 .D LVPTOT
41 .D CNET
42 .D REC
43 D TOTAL
44 ;
45 Q
46 ;
47LVPDSP ;Gather PB Dispensed data
48 ;
49 I PSUTYP="P",PSUP="P" D ;PBs Dispensed
50 .N DSP
51 .S DSP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,29)
52 .S $P(PSUIVA(PSUDIV),U,1)=$P($G(PSUIVA(PSUDIV)),U,1)+DSP
53 ;
54 Q
55 ;
56LVPREC ;Gather PB Recycled data
57 ;
58 I PSUTYP="P",PSUP="P" D ;PB's recycled
59 .N REC
60 .S REC=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,30)
61 .S $P(PSUIVA(PSUDIV),U,2)=$P($G(PSUIVA(PSUDIV)),U,2)+REC
62 ;
63 Q
64 ;
65LVPDES ;Gather PB Destroyed data
66 ;
67 I PSUTYP="P",PSUP="P" D ;PB's destroyed
68 .N DES
69 .S DES=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,31)
70 .S $P(PSUIVA(PSUDIV),U,3)=$P($G(PSUIVA(PSUDIV)),U,3)+DES
71 ;
72 Q
73 ;
74LVPCAN ;Gather PB Cancelled data
75 ;
76 I PSUTYP="P",PSUP="P" D ;PB's cancelled
77 .N CAN
78 .S CAN=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,32)
79 .S $P(PSUIVA(PSUDIV),U,4)=$P($G(PSUIVA(PSUDIV)),U,4)+CAN
80 ;
81 Q
82 ;
83LVPNET ;Calculate net amount of PB's Dispensed
84 ;
85 ;
86 I PSUTYP="P",PSUP="P" D
87 .N NET
88 .S NET=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,11)
89 .S $P(PSUIVA(PSUDIV),U,5)=$P($G(PSUIVA(PSUDIV)),U,5)+NET
90 Q
91 ;
92LVPTOT ;Calculate Total cost
93 ;
94 N NDIS,COST,PSUOR1
95 S PSUCTA=0
96 F S PSUCTA=$O(PSUAMIS(PSUDIV,PSUCTA)) Q:PSUCTA="" D
97 .S PSUOR1=$P(PSUAMIS(PSUDIV,PSUCTA),U,4)
98 .Q:(PSUOR1'=PSUOR)
99 .S NDIS=$P($G(PSUAMIS(PSUDIV,PSUCTA)),U,33)
100 .S COST=$P($G(PSUAMIS(PSUDIV,PSUCTA)),U,22)
101 .S $P(PSUIVA(PSUDIV),U,6)=$P($G(PSUIVA(PSUDIV)),U,6)+(NDIS*$G(COST))
102 .;
103 .;Truncate cost to 2 decimal places
104 .N A,B,C
105 .;
106 .I $P(PSUIVA(PSUDIV),U,6)'["." D Q
107 ..S $P(PSUIVA(PSUDIV),U,6)=$P(PSUIVA(PSUDIV),U,6)_".00"
108 .;
109 .S A=$F($P(PSUIVA(PSUDIV),U,6),".") ;Find 1st position after decimal
110 .;
111 .S B=$E($P(PSUIVA(PSUDIV),U,6),1,(A-1)) ;Extract dollars and decimal
112 .;
113 .S C=$E($P(PSUIVA(PSUDIV),U,6),A,(A+1)) ;Extract cents after decimal
114 .I $L(C)'=2 S C=$E(C,1)_0
115 .;
116 .S $P(PSUIVA(PSUDIV),U,6)=B_C
117 Q
118 ;
119CNET ;Calculate Cost per Net PB's dispensed
120 ;
121 N CNET,TCOST
122 ;
123 S CNET=$P($G(PSUIVA(PSUDIV)),U,5)
124 S TCOST=$P($G(PSUIVA(PSUDIV)),U,6)
125 ;
126 I CNET'="",CNET'=0,TCOST'="" D
127 .S $P(PSUIVA(PSUDIV),U,7)=TCOST/CNET
128 .;
129 .;Truncate cost to 2 decimal places
130 .N A,B,C
131 .;
132 .I $P(PSUIVA(PSUDIV),U,7)'["." D Q
133 ..S $P(PSUIVA(PSUDIV),U,7)=$P(PSUIVA(PSUDIV),U,7)_".00"
134 .;
135 .S A=$F($P(PSUIVA(PSUDIV),U,7),".") ;Find 1st position after decimal
136 .;
137 .S B=$E($P(PSUIVA(PSUDIV),U,7),1,(A-1)) ;Extract dollars and decimal
138 .;
139 .S C=$E($P(PSUIVA(PSUDIV),U,7),A,(A+1)) ;Extract cents after decimal
140 .I $L(C)'=2 S C=$E(C,1)_0
141 .;
142 .S $P(PSUIVA(PSUDIV),U,7)=B_C
143 ;
144 Q
145 ;
146TOTAL ;Add up column totals and place into ^XTMP global
147 ;
148 S PSUDI=0
149 F S PSUDI=$O(PSUIVA(PSUDI)) Q:PSUDI="" D
150 .S LDSP=$G(LDSP)+$P(PSUIVA(PSUDI),U,1) ;Total PB's dispensed
151 .;
152 .S LREC=$G(LREC)+$P(PSUIVA(PSUDI),U,2) ;Total PB's recycled
153 .;
154 .S LDES=$G(LDES)+$P(PSUIVA(PSUDI),U,3) ;Total PB's destroyed
155 .;
156 .S CLAN=$G(CLAN)+$P(PSUIVA(PSUDI),U,4) ;Total PB's cancelled
157 .;
158 .S NDSP=$G(NDSP)+$P(PSUIVA(PSUDI),U,5) ;Total Net PB's dispensed
159 .;
160 .S LTOT=$G(LTOT)+$P(PSUIVA(PSUDI),U,6) ;Total of Total cost
161 .;
162 .;S CNDSP=$G(CNDSP)+$P(PSUIVA(PSUDI),U,7) ;Total of cost/net column
163 .I $G(NDSP) S CNDSP=$G(LTOT)/NDSP D
164 ..I CNDSP'["." S CNDSP=CNDSP_".00" Q
165 ..N A,B,C
166 ..S A=$F(CNDSP,".") ;Find 1st position after decimal
167 ..S B=$E(CNDSP,1,(A-1)) ;Extract dollars and decimal
168 ..S C=$E(CNDSP,A,(A+1)) ;Extract cents after decimal
169 ..I $L(C)'=2 S C=$E(C,1)_0
170 ..S CNDSP=B_C
171 ;
172 I '$D(LDSP) S LDSP=0
173 I '$D(LREC) S LREC=0
174 I '$D(LDES) S LDES=0
175 I '$D(CLAN) S CLAN=0
176 I '$D(NDSP) S NDSP=0
177 I '$D(LTOT) S LTOT="0.00"
178 I '$D(CNDSP) S CNDSP="0.00"
179 ;
180 S ^XTMP(PSUIVSUB,"PBTOT")=LDSP_U_LREC_U_LDES_U_CLAN_U_NDSP_U_LTOT_U_CNDSP
181 ;
182 Q
183 ;
184REC ;Place contents of arrays into ^XTMP globals
185 ;
186 M ^XTMP(PSUIVSUB,"PB",PSUDIV)=PSUIVA(PSUDIV) ;PB RECORDS
187 ;
188 Q
Note: See TracBrowser for help on using the repository browser.