source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUAR1.m@ 1499

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1PSUAR1 ;BIR/PDW - Start AR/WS Extract ;11 AUG 1999
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;;
4 ;PSUDTDA - IEN FOR DATE
5 ;PSUSDA - IEN FOR INPATIENT SITE
6 ;PSUDRDA - IEN FOR DRUG
7 ;PSUCDA - IEN FOR CATEGORY
8 ;PSUDIV - IEN FOR DIVISION OR "NONE"
9 ;
10 ;DBIAs
11 ; Reference to file #58.5 supported by DBIA 456
12 ; Reference to file #58.1 supported by DBIA 2515
13 ; Reference to file #59.4 supported by DBIA 2498
14 ; Reference to file #44 supported by DBIA 2439
15 ; Reference to file #40.8 supported by DBIA 2438
16 ; Reference to file #59 supported by DBIA 1876
17 ; Reference to file #59.7 supported by DBIA 2854
18 ;
19EN ;EP MAIN ENTRY POINT
20 ;
21 K PSUTDSP,PSUTRET
22 ;
23START ;Start date scan thru stats file
24 S PSUSDT=PSUSDT-.1
25 S PSUDT=PSUSDT
26 S PSUEDT=PSUEDT\1+.24
27Q F S PSUDT=$O(^PSI(58.5,"B",PSUDT)) Q:'PSUDT Q:PSUDT>PSUEDT D DATE Q:$G(PSUQUIT)
28 Q
29DATE ;PROCESS ONE DATE - Loop through inpatient sites
30 S PSUDTDA=$O(^PSI(58.5,"B",PSUDT,0))
31 K PSUSITE
32 D GETM^PSUTL(58.5,PSUDTDA,"1*^.01","PSUSITE")
33 S PSUSDA=0
34 F S PSUSDA=$O(PSUSITE(PSUSDA)) Q:PSUSDA'>0 D SITE Q:$G(PSUQUIT)
35 K PSUSITE
36 Q
37 ;
38SITE ;Process one site for one date
39 ; Find division for site for loading drug stats
40 S PSUDIV=$$DIV(PSUSDA,PSUDTDA)
41 ;
42 I PSUDIV="NULL" S PSUDIV=PSUSNDR
43 ;
44 ; Process individual Drug information from 58.52
45 ; Drug multiple loaded into PSUDRUG
46 K PSUDRUG
47 D GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","2*^.01","PSUDRUG")
48 S PSUDRDA=0
49 F S PSUDRDA=$O(PSUDRUG(PSUDRDA)) Q:PSUDRDA'>0 D DRUG Q:$G(PSUQUIT)
50 K PSUDRUG
51 ;
52 D MAP
53 ; Process Amis categories from 58.501
54 ; Category multiple loaded into PSUCAT
55 K PSUCAT
56CATEGORY ;EP Pull Categories
57 K PSUAMCAT
58 D GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","1*^.01;1;2;3;4","PSUAMCAT","I")
59 ;
60 ; Move (da,Fld,"I") values to (da,Fld) nodes
61 D MOVEMI^PSUTL("PSUAMCAT")
62 ;
63 ; Gather totals for categories and accumulate in
64 ; ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP":COST")
65 N PSUDISP,PSUCOST
66 S PSUCDA=0 F S PSUCDA=$O(PSUAMCAT(PSUCDA)) Q:PSUCDA'>0 D
67 . S PSUDISP=PSUAMCAT(PSUCDA,1)-PSUAMCAT(PSUCDA,3)
68 . S PSUCOST=PSUAMCAT(PSUCDA,2)-PSUAMCAT(PSUCDA,4)
69 . S PSUAMCAT=PSUAMCAT(PSUCDA,.01) ; "03"-"04"-"06" etc
70 . S X=$G(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP"))
71 . S ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP")=X+PSUDISP
72 . S X=$G(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST"))
73 . S ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")=X+PSUCOST
74 . M ^XTMP("PSUTCST",PSUDIV,PSUAMCAT)=^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")
75 ;
76 Q
77 ;
78DRUG ; Process one drug for one site for one day
79 ; Load & loop categories within Drug
80 ; total dispense & returns
81 ; Category multiple loaded into PSUCAT
82 ;
83 S PSUDRIEN=$$VALI^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA",.01)
84 K PSUCAT
85 D GETM^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA","1*^.01;1","PSUCAT","I")
86 ;
87 S PSUCDA=0,PSUDISP=0,PSUTR=0
88 F S PSUCDA=$O(PSUCAT(PSUCDA)) Q:PSUCDA'>0 Q:$G(PSUQUIT) D
89 . S X=PSUCAT(PSUCDA,.01,"I")
90 . S Y=PSUCAT(PSUCDA,1,"I")
91 . I (X="A")!(X="W") S PSUDISP=PSUDISP+Y,PSUTDS=PSUDISP
92 . I (X="RA")!(X="RW") S PSUDISP=PSUDISP-Y,PSUTR=PSUTR+Y
93 ; Adjust accumulative dispenses
94 ;
95 S X=$G(^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN))
96 S ^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN)=X+PSUDISP
97 ;
98 N PSUT
99 S PSUT=$G(PSUTDSP(PSUDIV,PSUDRIEN))
100 I $D(PSUTDS) D
101 .S PSUTDSP(PSUDIV,PSUDRIEN)=PSUTDS+PSUT ;Total Quantity dispensed
102 .I (PSUTDS+PSUT)=0 S PSUTDSP(PSUDIV,PSUDRIEN)=""
103 ;
104 N PSUT1
105 S PSUT1=$G(PSUTRET(PSUDIV,PSUDRIEN))
106 I $D(PSUTR) D
107 .S PSUTRET(PSUDIV,PSUDRIEN)=PSUTR+PSUT1 ;Total Quantity returned
108 .I (PSUTR+PSUT1)=0 S PSUTRET(PSUDIV,PSUDRIEN)=""
109 K PSUCAT
110 Q
111DIV(PSUSDA,PSUDTDA) ;EP process for a site the associated divisions by date.
112 ; uses PSUSDA as entry for site ien in file 59.4 : returns division
113 ; as of 2/99 date is no longer used as a parameter
114 N PSUDIV,PSUDT
115 I '$D(^XTMP(PSUARSUB,"DIVLK",PSUSDA)) D AOU
116 ; ^XTMP(PSUARSUB,"DIVlk",Site IEN, AOU Inactive Date -1)=Division IEN
117 ;
118 ; if AOU did not set division then return null
119 I '$D(^XTMP(PSUARSUB,"DIVLK",PSUSDA)) S PSUDIV="NULL" Q PSUDIV
120 ;
121 S PSUDIV=$O(^XTMP(PSUARSUB,"DIVLK",PSUSDA,""))
122 Q PSUDIV
123 ;
124AOU ;EP map divisions by dates for inpatient sites from the AOU file
125 ;PSUADA - ien for AOU Stock file
126 ;
127 N PSUADA,PSUDIV,PSUINACT,PSUDIV,PSUSLOC,MAPLOCI
128 ;
129 D GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI","I")
130 ;set array MAPLOCI(ien,fld)=internal value
131 ;field .02 points to 40.8 Medical Center Division where fac num is #1
132 ;field .03 points to 59 Outpatient site where site num is #.06
133 D MOVEMI^PSUTL("MAPLOCI")
134 ;
135 K ^XTMP(PSUARSUB,"DIVLK")
136 ;
137 S PSUADA=0
138 F S PSUADA=$O(^PSI(58.1,"ASITE",PSUSDA,PSUADA)) Q:PSUADA'>0 D
139 . N PSUDIV S PSUDIV=""
140 . S PSUSLOC=$$VALI^PSUTL(59.4,PSUSDA,.01)
141 . S PSUINACT=$$VALI^PSUTL(58.1,PSUADA,3)
142 . I PSUINACT Q ; inactivated sites are to be ignored regardles of date
143 . S:'PSUINACT PSUINACT=DT+1
144 . I '$G(MAPLOCI(PSUADA,.01)) S PSUDIV="NULL"
145 . I $G(MAPLOCI(PSUADA,.01)) D
146 .. S X=$G(MAPLOCI(PSUADA,.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
147 .. S X=$G(MAPLOCI(PSUADA,.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
148 .. S ^XTMP(PSUARSUB,"DIVLK",PSUSDA,PSUDIV)=""
149 ;
150 Q
151 ;
152MAP ;Find out whether an Area of Use (AOU) is mapped to a division or
153 ;outpatient site. If it is not mapped, store the NAME and INACTIVATION
154 ;DATE (if applicable) in a global to be mailed to the user.
155 ;
156 S PSUNAM=0 ;This is the name of the Area of USE
157 ;
158 F S PSUNAM=$O(^PSI(58.1,"B",PSUNAM)) Q:PSUNAM="" D
159 .S IEN=0 ;This is the IEN for file 58.1
160 .F S IEN=$O(^PSI(58.1,"B",PSUNAM,IEN)) Q:IEN="" D
161 ..K AOU
162 ..D GETS^PSUTL(58.1,IEN,".01;3","AOU(IEN)") ;Name & Inactive Date
163 ..D MAP1
164 Q
165 ;
166MAP1 ;MAP continued. This subroutine takes the IEN from file 58.1 and looks
167 ;to see if it is in file 59.7, field 90.01. If it is, then it has
168 ;been mapped if there is a value in subfield .02 or .03.
169 ;If there is no value in subfield .02 or .03 it has not been mapped
170 ;
171 ;Keep only the entries that are NOT mapped
172 ;
173 N PSUDA
174 ;
175 I $G(^PS(59.7,1,90.01,IEN,0)) D
176 .D GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI")
177 .S PSUDA=0
178 .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D
179 ..I MAPLOCI(PSUDA,.02)'="" K AOU(PSUDA)
180 ..I $G(MAPLOCI(PSUDA,.03))'="" K AOU(PSUDA)
181 M ^XTMP(PSUARSUB,"AOU")=AOU ;Contains only unmapped locations
182 Q
183 ;
184CLEAR ;EP Clear ^XTMP("PSUAR*")
185 S X="PSUAR",Y=X
186 F S Y=$O(^XTMP(Y)) Q:($E(Y,1,5)'=X) W !,Y K ^XTMP(Y)
187 Q
Note: See TracBrowser for help on using the repository browser.