source: FOIAVistA/tag/r/E_CLAIMS_MGMT_ENGINE-BPS/BPS01P5A.m

Last change on this file was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 9.8 KB
Line 
1BPS01P5A ;BHAM ISC/BEE - Post-Install for BPS*1*5 (cont) ;13-DEC-06
2 ;;1.0;E CLAIMS MGMT ENGINE;**5**;JUN 2004;Build 4;WorldVistA 30-Jan-08
3 ;Modified from FOIA VISTA,
4 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
5 ;General Public License See attached copy of the License.
6 ;
7 ;This program is free software; you can redistribute it and/or modify
8 ;it under the terms of the GNU General Public License as published by
9 ;the Free Software Foundation; either version 2 of the License, or
10 ;(at your option) any later version.
11 ;
12 ;This program is distributed in the hope that it will be useful,
13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;GNU General Public License for more details.
16 ;
17 ;You should have received a copy of the GNU General Public License along
18 ;with this program; if not, write to the Free Software Foundation, Inc.,
19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 ;;Per VHA Directive 2004-038, this routine should not be modified.
21 ;
22 Q
23 ;
24 ; Called by the BPS*1.0*5 Post-Install routine BPS01P5.
25 ;
26 ; This routine will convert or delete the invalid usage of globals
27 ; ^BPSECX and ^BPSECP
28 ; It will also delete several ECME files that are now obsolete
29 ;
30 ; ^BPSECX cleanup - Here are the nodes and what should be done
31 ; "BPSOSRX" is the processing queue - Convert to XTMP and delete
32 ; "R" is the BPS Report Master database (obsolete) and will be
33 ; deleted by BPSO1P5
34 ; "S" is the BPS Statistics database and should not be deleted
35 ; "POS", "BPSOSQ3", and $J were for HL7 packet creation. They
36 ; do not need to be converted and can just be killed.
37 ;
38 ;
39 ; ^BPSECP cleanup - Here are the nodes and what should be done
40 ; "CHECKTIM" - Used for queuing BPSOSQ1. This is no longer
41 ; needed and can just be killed.
42 ; "LOG" - Convert to BPS Log file and then delete.
43 ;
44EN ;
45 ; Remove XTMP global used for logging errors
46 K ^XTMP("BPS01P5A")
47 ;
48 ; First convert ^BPSECP("BPSOSRX") into XTMP and delete it
49 M ^XTMP("BPS-PROC")=^BPSECP("BPSOSRX")
50 K ^BPSECP("BPSOSRX")
51 ; If the global has been created but the zero node is missing, set it
52 I $D(^XTMP("BPS-PROC")),'$D(^XTMP("BPS-PROC",0)) D
53 . N X,X1,X2
54 . S X1=DT,X2=30 D C^%DTC
55 . S ^XTMP("BPS-PROC",0)=X_U_DT_U_"ECME PROCESSING QUEUE"
56 ;
57 ; Second, kill off unneeded ^BPSECX nodes
58 ; Note that we need to loop because of the $J nodes.
59 N SUB
60 S SUB=""
61 F S SUB=$O(^BPSECX(SUB)) Q:SUB="" I SUB'="S",SUB'="RPT" K ^BPSECX(SUB)
62 ;
63 ; Third, kill ^BPSECP("CHECKTIM")
64 K ^BPSECP("CHECKTIM")
65 ;
66 ; Fourth, convert ^BPSECP("LOG")
67 ; Note that we are only converting the transaction log (pattern match .N1"."5N)
68 ; and purge logs (type=5). Other communication logs are being deleted.
69 N SLOT,TXTIEN,PURGE,LOGIEN,PDT
70 N TXTIEN,TM,TMP,TXT,TXT1,TXT2,PDTM
71 S SLOT=""
72 F S SLOT=$O(^BPSECP("LOG",SLOT)) Q:SLOT="" D
73 . ; Set PURGE equal to whether the SLOT if a Purge Log
74 . S PURGE=$P(SLOT,".",2)=5
75 . ; If not transaction log or purge log, delete it and go on
76 . I SLOT'?.N1"."5N,'PURGE K ^BPSECP("LOG",SLOT) Q
77 . ; Create/find LOG IEN
78 . S LOGIEN=$$LOG(SLOT)
79 . I LOGIEN=-1 Q
80 . S PDT="",PDTM=""
81 . I PURGE S PDT=$P(SLOT,".",1)
82 . S TXTIEN=0 F S TXTIEN=$O(^BPSECP("LOG",SLOT,TXTIEN)) Q:TXTIEN="" D
83 .. ; Get data
84 .. S X=$G(^BPSECP("LOG",SLOT,TXTIEN))
85 .. S TM=$P($$HTFM^XLFDT(+$H_","_$P(X,U,1)),".",2),TXT=$P(X,U,2),TXT1=$$UP(TXT)
86 .. ; If it is a transaction log, get the purge date
87 .. I 'PURGE D
88 ... I TXT1["BEFORE SUBMIT OF CLAIM" S TMP=$P($P(TXT1," - ",2)," BEFORE",1) I TMP?1"30"5N S PDT=TMP
89 ... I TXT1["BEFORE SUBMIT OF REVERSAL" S TMP=$P($P(TXT1," - ",2)," BEFORE",1) I TMP?1"30"5N S PDT=TMP
90 ... I TXT1["START OF CLAIM" S X=$P($P(TXT1,"START OF CLAIM - ",2),"@"),PDT=$$CDT(X,PDT)
91 ... I TXT1["LOG TIME STAMP" D
92 .... S X=$P(TXT1,"LOG TIME STAMP",2)
93 .... I $E(X,1)=" " S X=$E(X,2,999)
94 .... S X=$P($P(X," ",1,2),"@",1),PDT=$$CDT(X,PDT)
95 ... S TXT2=","_$E(TXT1,1,3)_","
96 ... I ",JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC,"[TXT2 S X=$P($P(TXT1," ",1,2),"@",1),PDT=$$CDT(X,PDT)
97 .. I PDT="" S ^XTMP("BPS01P5A",1,SLOT,TXTIEN)=TXT Q
98 .. S PDTM=PDT_"."_TM
99 .. D FILE1(LOGIEN,TXTIEN,PDTM,TXT)
100 . I PDTM="" S PDTM=$$NOW^XLFDT(),^XTMP("BPS01P5A",2,SLOT)=PDTM
101 . D FILE2(LOGIEN,PDTM)
102 . K ^BPSECP("LOG",SLOT)
103 ;
104 ; If XTMP("BPS01P5A") global created, add top node with purge date
105 I $D(^XTMP("BPS01P5A")) D
106 . N X,X1,X2
107 . S X1=DT,X2=60 D C^%DTC
108 . S ^XTMP("BPS01P5A",0)=X_U_DT_U_"BPS Log Conversion"
109 ;
110 ; Kill the top node of ^BPSECP if that is all there is left
111 I $D(^BPSECP("LOG"))=1 K ^BPSECP("LOG")
112 Q
113 ;
114LOG(X) ; Create or find slot in BPS LOG
115 N DIC,DLAYGO,Y
116 S DIC=9002313.12,DIC(0)="LBO",DLAYGO=DIC
117 D ^DIC
118 I Y=-1 S ^XTMP("BPS01P5A",3,X)=Y
119 Q +Y
120 ;
121FILE1(LOGIEN,TXTIEN,PDTM,TXT) ; Create multiple entry
122 N FN,FDA,MSG
123 S FN=9002313.1201
124 S FDA(FN,"+1,"_LOGIEN_",",.01)=PDTM
125 S FDA(FN,"+1,"_LOGIEN_",",1)=$TR($E(TXT,1,200),"^","~")
126 D UPDATE^DIE("","FDA","","MSG")
127 I $D(MSG) S ^XTMP("BPS01P5A",4,LOGIEN,TXTIEN)=PDTM_U_TXT M ^XTMP("BPS01P5A",4,LOGIEN,"MSG")=MSG
128 Q
129 ;
130FILE2(LOGIEN,PDTM) ; Update LAST UPDATE field with the last date
131 N FDA,MSG,FN
132 S FN=9002313.12
133 S FDA(FN,LOGIEN_",",.02)=PDTM
134 D FILE^DIE("","FDA","MSG")
135 I $D(MSG) S ^XTMP("BPS01P5A",5,LOGIEN)=PDTM M ^XTMP("BPS01P5A",5,LOGIEN,"MSG")=MSG
136 Q
137 ;
138CDT(X,PDT) ; Convert external date to internal
139 ; If date evaluates to -Y, use default date (PDT)
140 N %DT,Y
141 S %DT="" D ^%DT
142 I Y=-1 S Y=PDT
143 Q Y
144 ;
145UP(X) ; Convert text to uppercase
146 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
147 ;
148 ;DELETE OBSOLETE FILES
149 ; For BPSCOMB and BPSEI, we need to delete each node manually
150 ; to prevent global protection errors.
151 ;
152DEL N DIU,X
153 ;
154 ;Turn global protection off (SACC Exemption has been granted to use $ZU)
155 I $P(^%ZOSF("OS"),"^",2)=3 S X=$ZU(68,28,0)
156 ;
157 ;Remove BPS COMBINED INSURANCE (#9002313.1), which uses an unsubscripted global
158 ;reference to store the data
159 S DIU="^BPSCOMB(",DIU(0)="DS" D EN^DIU2
160 ;
161 ;Remove BPS INSURER (#9002313.4), which uses an unsubscripted global reference to store
162 ;the data
163 S DIU="^BPSEI(",DIU(0)="DS" D EN^DIU2
164 ;
165 ;Turn global protection back on
166 I $P(^%ZOSF("OS"),"^",2)=3 S X=$ZU(68,28,1)
167 ;
168 ;BPS DATA INPUT (#9002313.51)
169 S DIU="^BPS(9002313.51,",DIU(0)="DS" D EN^DIU2
170 ;
171 ;BPS ORIGIN OF INPUT (#9002313.516)
172 S DIU="^BPS(9002313.516,",DIU(0)="DS" D EN^DIU2
173 ;
174 ;BPS DIALOUT (#9002313.55)
175 S DIU="^BPS(9002313.55,",DIU(0)="DS" D EN^DIU2
176 ;
177 ;BPS INPUT USER PREF (#9002313.515)
178 S DIU="^BPS(9002313.515,",DIU(0)="DS" D EN^DIU2
179 ;
180 ;BPS INSURANCE RULES (#9002313.94)
181 S DIU="^BPSF(9002313.94,",DIU(0)="DS" D EN^DIU2
182 ;
183 ;BPS PRICING TABLES (#9002313.53)
184 S DIU="^BPS(9002313.53,",DIU(0)="DS" D EN^DIU2
185 ;
186 ;BPS REPORT MASTER (#9002313.61)
187 S DIU="^BPSECX(""RPT"",",DIU(0)="DS" D EN^DIU2
188 ;
189 ;BPS TRANSLATE (#9002313.81)
190 S DIU="^BPSF(9002313.81,",DIU(0)="DS" D EN^DIU2
191 ;
192 K DIU,X
193 ;
194 Q
195 ;
196 ;BPS SETUP (#9002313.99)
19799 N IEN
198 ;
199 S IEN=0 F S IEN=$O(^BPS(9002313.99,IEN)) Q:'IEN D
200 .;
201 .;'2' Node
202 .K ^BPS(9002313.99,IEN,2)
203 .;
204 .;'BPSOS6*' Node
205 .K ^BPS(9002313.99,IEN,"BPSOS6*")
206 .;
207 .;'BPSOSM1' Node
208 .K ^BPS(9002313.99,IEN,"BPSOSM1")
209 .;
210 .;'BPSOSR1' Node
211 .K ^BPS(9002313.99,IEN,"BPSOSR1")
212 .;
213 .;'BPSOSX' Node
214 .K ^BPS(9002313.99,IEN,"BPSOSX")
215 .;
216 .;'A/R INTERFACE' Node
217 .K ^BPS(9002313.99,IEN,"A/R INTERFACE")
218 .;
219 .;'BILLING' Node
220 .K ^BPS(9002313.99,IEN,"BILLING")
221 .;
222 .;'BILLING - NEW' Node
223 .K ^BPS(9002313.99,IEN,"BILLING - NEW")
224 .;
225 .;'BILLING LOG FILE' Node
226 .K ^BPS(9002313.99,IEN,"BILLING LOG FILE")
227 .;
228 .;'CREATING A/R' Node
229 .K ^BPS(9002313.99,IEN,"CREATING A/R")
230 .;
231 .;'DIAL-OUT DEFAULT' Node
232 .K ^BPS(9002313.99,IEN,"DIAL-OUT DEFAULT")
233 .;
234 .;'EOB-SCREEN' Node
235 .K ^BPS(9002313.99,IEN,"EOB-SCREEN")
236 .;
237 .;'FORMS - NCPDP' Node
238 .K ^BPS(9002313.99,IEN,"FORMS - NCPDP")
239 .;
240 .;'FORMS - PREBILL' Node
241 .K ^BPS(9002313.99,IEN,"FORMS - PREBILL")
242 .;
243 .;'INPUT' Node
244 .K ^BPS(9002313.99,IEN,"INPUT")
245 .;
246 .;'INS' Node
247 .K ^BPS(9002313.99,IEN,"INS")
248 .;
249 .;'INS BASE SCORES'
250 .K ^BPS(9002313.99,IEN,"INS BASE SCORES")
251 .;
252 .;'INS RULES' Node
253 .K ^BPS(9002313.99,IEN,"INS RULES")
254 .;
255 .;'NULL FILE' Node
256 .K ^BPS(9002313.99,IEN,"NULL FILE")
257 .;
258 .;'OUTSIDE LINE' Node
259 .K ^BPS(9002313.99,IEN,"OUTSIDE LINE")
260 .;
261 .;'POSTAGE' Node
262 .K ^BPS(9002313.99,IEN,"POSTAGE")
263 .;
264 .;'RX A/R TYPE' Node
265 .K ^BPS(9002313.99,IEN,"RX A/R TYPE")
266 .;
267 .;'RECEIPT' Node
268 .K ^BPS(9002313.99,IEN,"RECEIPT")
269 .;
270 .;'SPECIAL' Node
271 .K ^BPS(9002313.99,IEN,"SPECIAL")
272 .;
273 .;'STARTUP' Node
274 .K ^BPS(9002313.99,IEN,"STARTUP")
275 .;
276 .;'UNBILLABLE NDC #' Node
277 .K ^BPS(9002313.99,IEN,"UNBILLABLE NDC #")
278 .;
279 .;'UNBILLABLE DRUG NAME' Node
280 .K ^BPS(9002313.99,IEN,"UNBILLABLE DRUG NAME")
281 .;
282 .;'UNBILLABLE OTC' Node
283 .K ^BPS(9002313.99,IEN,"UNBILLABLE OTC")
284 .;
285 .;'WRITEOFF-SCREEN' Node
286 .K ^BPS(9002313.99,IEN,"WRITEOFF-SCREEN")
287 .;
288 .;'WRITEOFF-SCREEN ARTYPE' Node
289 .K ^BPS(9002313.99,IEN,"WRITEOFF-SCREEN ARTYPE")
290 .;
291 .;'WRITEOFF-SCREEN BATCH' Node
292 .K ^BPS(9002313.99,IEN,"WRITEOFF-SCREEN BATCH")
293 .;
294 .;'WRITEOFF-SCREEN CLINIC' Node
295 .K ^BPS(9002313.99,IEN,"WRITEOFF-SCREEN CLINIC")
296 .;
297 .;'WRITEOFF-SCREEN DIAG' Node
298 .K ^BPS(9002313.99,IEN,"WRITEOFF-SCREEN DIAG")
299 .;
300 .;'WRITEOFF-SCREEN INSURER' Node
301 .K ^BPS(9002313.99,IEN,"WRITEOFF-SCREEN INSURER")
302 .;
303 .;'WINNOW' Node
304 .N X
305 .S X=$P($G(^BPS(9002313.99,IEN,"WINNOW")),U)
306 .I X'=0,X'=1 S X=$P($G(^BPS(9002313.99,IEN,"WINNOW TESTING")),U),X=$S(X=1:1,1:0)
307 .S ^BPS(9002313.99,IEN,"WINNOW")=X_"^^365"
308 .K X
309 .;
310 .;'WINNOW TESTING' Node
311 .K ^BPS(9002313.99,IEN,"WINNOW TESTING")
312 .;
313 .;'WINNOW LOG' Node
314 .K ^BPS(9002313.99,IEN,"WINNOW LOG")
315 .;
316 .;'WORKERS COMP' Node
317 .K ^BPS(9002313.99,IEN,"WORKERS COMP")
318 .;
319 .;'WRITE OFF INSURER' Node
320 .K ^BPS(9002313.99,IEN,"WRITE OFF INSURER")
321 .;
322 .;'WRITE OFF SELF PAY' Node
323 .K ^BPS(9002313.99,IEN,"WRITE OFF SELF PAY")
324 .;
325 .;'NCPDP51' Node
326 .K ^BPS(9002313.99,IEN,"NCPDP51")
327 .;
328 .;'WINNOW LOGS' Node
329 .K ^BPS(9002313.99,IEN,"WINNOW LOGS")
330 ;
331 K IEN
332 ;
333 Q
Note: See TracBrowser for help on using the repository browser.