source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAERR3.m@ 1147

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

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1IBAERR3 ;ALB/AAS - RX COPAY EXEMPTION ALERT PROCESSOR ; 15-JAN-93
2 ;;2.0;INTEGRATED BILLING;**356**;21-MAR-94
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5% ; -- medication copayment exemption errors
6 ;
7SEND ; -- use kernel alerts
8 N X,Y,IBA,IBP,XQA,XQAID,XQAKILL,XQAMSG,XQAROU,XQAOPT,XQADATA,DIC,DA,DR,DIE,DLAYGO
9 S:'$D(IBALERT) IBALERT=$G(IBEXERR)+10 G:'IBALERT SENDQ
10 S IBP=$$PT^IBEFUNC(DFN)
11 S IBA=$G(^IBE(354.5,IBALERT,0)) G:IBA="" SENDQ
12 S X=$P($G(^IBE(354.5,IBALERT,3)),"^",1) I X="D" G SENDQ
13 S X=+IBALERT,DIC(0)="L",DIC="^IBA(354.4,",DLAYGO=354.4 K DD,DO D FILE^DICN S IBDA=+Y
14 S XQAID=$P(IBA,"^",2)_IBDA,XQAKILL=0
15 S XQAMSG=$P(IBP,"^")_" ("_$P(IBP,"^",3)_") - "_$P(IBA,"^",3)
16 I $P(IBA,"^",5)="R" S XQAROU=$S($P(IBA,"^",6)'="":$P(IBA,"^",6,7),1:$P(IBA,"^",7))
17 ;
18 S XQADATA=$G(IBALERT)_";"_$G(DFN)_";"_$G(IBEXDA)_";"_$G(IBJOB)_";"_$G(IBWHER)_";"_$G(DUZ)_";"_$G(DT)_";"_$G(IBDA)
19 ;
20 S DA=IBDA,DIE="^IBA(354.4,",DR=".02///NOW" D ^DIE K DIC,DIE,DA,DR
21 ;
22 I $G(IBEXDA) S DA=IBEXDA,DIE="^IBA(354.1,",DR=".09////^S X=IBDA" D ^DIE K DIC,DIE,DA,DR
23 ;
24 D TOWHO
25 ;
26 D SETUP^XQALERT
27 ;
28SENDQ I $G(IBEXERR) S IBEXERR="" ; clear error flag
29 Q
30 ;
31TOWHO ; -- set xqa array to deliver to
32 N I,J
33 S I="" F S I=$O(^IBE(354.5,+IBALERT,200,I)) Q:'I S J=+^(I,0),XQA(J)=""
34 S I="" F S I=$O(^IBE(354.5,+IBALERT,2,I)) Q:'I S J=+^(I,0),XQA("G."_$P($G(^XMB(3.8,+J,0)),"^"))=""
35 I '$D(XQA) D
36 .S J=+$P($G(^IBE(350.9,1,0)),"^",$S($G(IBALERT)<10:13,1:9))
37 .I +J'=0 S XQA("G."_$P($G(^XMB(3.8,+J,0)),"^"))=""
38 .I +J=0 S XQA("G.IB EDI SUPERVISOR")=""
39 ;S XQA(DUZ)=""
40TOWHOQ Q
41 ;
421 ; -- process info only alerts
43 Q:$G(XQADATA)="" K XQAKILL
44 N DFN,IBP,IBCLEAR,DIR,DIRUT,DUOUT S IBCLEAR="YES"
45 D WRITE,CLEAR,UP
46 K IBCLEAR Q
47 ;
4811 ; -- process action alerts
49 Q:$G(XQADATA)="" K XQAKILL
50 N DFN,IBP,IBCLEAR,DIR,DIRUT,DUOUT S IBCLEAR="YES"
51 D WRITE,PROC,CLEAR,UP
52 Q
53 ;
54PROC ; -- process alert
55 ; -- run ^ibarxex to see if okay
56 N IBDFN,DIR,X,Y W !!
57 S DIR("?")="Enter YES to run the Manual Update option for this patient or NO if everything appears in order or enter '^' to exit and save this alert for later processing."
58 S DIR(0)="Y",DIR("A")="Run Manual Update Option",DIR("B")="YES" D ^DIR
59 I $D(DIRUT)!(Y=0) S IBCLEAR="NO" G PROCQ
60 S IBDFN=DFN D EN^IBARXEX S DFN=IBDFN
61PROCQ Q
62 ;
63CLEAR ; -- clear entry in 354.4 and alert in 354.1
64 Q:$D(DIRUT)
65 N DIR,X,Y W !!
66 S DIR("?")="Enter YES to clear this alert for all users or NO to clear this alert for the current user or '^' to exit and save this alert for later processing."
67 S DIR(0)="Y",DIR("A")="Clear alert for all users ('^' to save alert)",DIR("B")=IBCLEAR D ^DIR
68 I $D(DIRUT) G CLEARQ
69 ; -- xqakill=0 clear for all, =1 clear for current user only
70 S XQAKILL='Y
71 W !
72CLEARQ Q
73 ;
74WRITE ; -- write out long message
75 ; xqadata = alert type;dfn;exemption;ibjob;ibwhere;duz;dt;alert entry
76 N XQATMP,XQATMP1,XQATMP2
77 S DFN=$P(XQADATA,";",2),IBP=$$PT^IBEFUNC(DFN)
78 W !!,"Patient: ",$P(IBP,"^"),?40,$P(IBP,"^",2)
79 D DISP^IBARXEU(DFN,DT,3,0)
80 W:+XQADATA<11 !!,$P($T(MSG+(+XQADATA)),";;",2)
81 I +XQADATA>10 D
82 .S XQATMP=+XQADATA-10
83 .W !!,"The error that occurred was: ",$P($T(ERR+XQATMP^IBAERR2),";;",2),!,"Processed"
84 W " by ",$P($G(^VA(200,+$P(XQADATA,";",6),0)),"^")," on ",$$DAT1^IBOUTL($P(XQADATA,";",7)),"."
85 ;
86 ; -- this only handles ibjobs>10 (exemption)
87 I $P(XQADATA,";",4)>10 D
88 .S XQATMP1=$P(XQADATA,";",4)-10
89 .W !,"This occurred during the ",$P($T(JOB+XQATMP1^IBAERR2),";;",2)
90 I $P(XQADATA,";",5)>10 D
91 .S XQATMP2=$P(XQADATA,";",5)-10
92 .W !,$P($T(WHERE+XQATMP2^IBAERR2),";;",2)
93 ;
94WRITEQ Q
95 ;
96UP ; -- update error file with user
97 Q:'$D(XQAKILL)
98 N DA,DIC,DIE,DR,X,Y
99 G:'$P(XQADATA,";",8) UPQ
100 S DA=$P(XQADATA,";",8) S X=$G(^IBA(354.4,DA,0)) G:X=""!($P(X,"^",3)'="") UPQ
101 S DIE="^IBA(354.4,",DR=".03////"_DUZ_";.04///NOW" D ^DIE
102 ;
103 G:$P($G(^IBA(354.1,+$P(XQADATA,";",3),0)),"^",9)="" UPQ
104 K DIC,DIE,DA,DR,X,Y
105 S DA=$P(XQADATA,";",3),DIE="^IBA(354.1,",DR=".09///@" D ^DIE
106UPQ Q
107 ;
108MSG ;;
109 ;;Patient has been given a Hardship Exemption
110 ;;Patient's Hardship Exemption has been removed
111 ;;Patient's Exemption based on Income has expired
112 ;;
113 Q
114 ;
115PURGE ; -- purge entries in 354.4, clear pointer in 354.1, delete alert
116 ; purge cleared entries older than 30 days, all over 60 days
117 ;
118 ; -- called by IBAMTC (nightly means test job)
119 ; not user interactive (friendly)
120 ;
121 Q:'$O(^IBA(354.4,"AC",0))
122 S X1=DT,X2=-30 D C^%DTC S IB30=X
123 S X1=DT,X2=-60 D C^%DTC S IB60=X
124 S IBDT=""
125 W:'$D(ZTQUEUED) !!,"Purging Alerts..."
126 F S IBDT=$O(^IBA(354.4,"AC",IBDT)) Q:'IBDT!(IBDT>IB30) S IBDA=0 F S IBDA=$O(^IBA(354.4,"AC",IBDT,IBDA)) Q:'IBDA D
127 .;
128 .S X=$G(^IBA(354.4,IBDA,0))
129 .I '$P(X,"^",3),(IBDT>IB60) Q
130 .;
131 .S XQAID=$P(^IBE(354.5,+1,0),"^",2)_IBDA
132 .S X=$O(^IBA(354.1,"ALERT",IBDA,0)) I X S DA=X,DR=".09///@",DIE="^IBA(354.1," D ^DIE K DA,DR,DIE
133 .;
134 .S IBALERT=+$G(^IBA(354.4,+IBDA,0))
135 .D TOWHO S XQAKILL=0 D DELETEA^XQALERT
136 .;
137 .S DA=IBDA,DIK="^IBA(354.4," D ^DIK K DA,DIK
138 .Q
139 K IB30,IB60,IBDA,XQA,XQAID,XQAKILL,X,X1,X2
Note: See TracBrowser for help on using the repository browser.