source: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUV8.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.7 KB
Line 
1PSUV8 ;BIR/DAM - IV TPN AMIS Summary Data ;11 March 2004
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**4**;MARCH, 2005
3 ;
4 ;This routine gathers IV TPN 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="H" S PSUOR=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,4) ;IV order #
34 .D LVPDSP
35 .D LVPREC
36 .D LVPDES
37 .D LVPCAN
38 .D LVPNET
39 .D LVPTOT
40 .D CNET
41 .D REC
42 D TOTAL
43 ;
44 Q
45 ;
46LVPDSP ;Gather TPN Dispensed data
47 ;
48 I PSUTYP="H",PSUP="P" D ;TPNs Dispensed
49 .N DSP
50 .S DSP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,29)
51 .S $P(PSUIVA(PSUDIV),U,1)=$P($G(PSUIVA(PSUDIV)),U,1)+DSP
52 ;
53 Q
54 ;
55LVPREC ;Gather TPN Recycled data
56 ;
57 I PSUTYP="H",PSUP="P" D ;TPN's recycled
58 .N REC
59 .S REC=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,30)
60 .S $P(PSUIVA(PSUDIV),U,2)=$P($G(PSUIVA(PSUDIV)),U,2)+REC
61 ;
62 Q
63 ;
64LVPDES ;Gather TPN Destroyed data
65 ;
66 I PSUTYP="H",PSUP="P" D ;TPN's destroyed
67 .N DES
68 .S DES=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,31)
69 .S $P(PSUIVA(PSUDIV),U,3)=$P($G(PSUIVA(PSUDIV)),U,3)+DES
70 ;
71 Q
72 ;
73LVPCAN ;Gather TPN Cancelled data
74 ;
75 I PSUTYP="H",PSUP="P" D ;TPN's cancelled
76 .N CAN
77 .S CAN=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,32)
78 .S $P(PSUIVA(PSUDIV),U,4)=$P($G(PSUIVA(PSUDIV)),U,4)+CAN
79 ;
80 Q
81 ;
82LVPNET ;Calculate net amount of TPN's Dispensed
83 ;
84 ;
85 I PSUTYP="H",PSUP="P" D
86 .N NET
87 .S NET=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,11)
88 .S $P(PSUIVA(PSUDIV),U,5)=$P($G(PSUIVA(PSUDIV)),U,5)+NET
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 TPN'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 TPN's dispensed
150 .;
151 .S LREC=$G(LREC)+$P(PSUIVA(PSUDI),U,2) ;Total TPN's recycled
152 .;
153 .S LDES=$G(LDES)+$P(PSUIVA(PSUDI),U,3) ;Total TPN's destroyed
154 .;
155 .S CLAN=$G(CLAN)+$P(PSUIVA(PSUDI),U,4) ;Total TPN's cancelled
156 .;
157 .S NDSP=$G(NDSP)+$P(PSUIVA(PSUDI),U,5) ;Total Net TPN'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,"TPNTOT")=$G(LDSP)_U_$G(LREC)_U_$G(LDES)_U_$G(CLAN)_U_$G(NDSP)_U_$G(LTOT)_U_$G(CNDSP)
180 ;
181 Q
182 ;
183REC ;Place contents of arrays into ^XTMP globals
184 ;
185 M ^XTMP(PSUIVSUB,"TPN",PSUDIV)=PSUIVA(PSUDIV) ;TPN RECORDS
186 ;
187 Q
Note: See TracBrowser for help on using the repository browser.