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