IBAERR3 ;ALB/AAS - RX COPAY EXEMPTION ALERT PROCESSOR ;15-JAN-93
;;2.0;INTEGRATED BILLING;**356,546**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
% ; -- medication copayment exemption errors
;
SEND ; -- use kernel alerts
N X,Y,IBA,IBDA,IBP,XQA,XQAID,XQAKILL,XQAMSG,XQAROU,XQAOPT,XQADATA,DIC,DA,DR,DIE,DLAYGO
S:'$D(IBALERT) IBALERT=$G(IBEXERR)+10 G:'IBALERT SENDQ
S IBP=$$PT^IBEFUNC(DFN)
S IBA=$G(^IBE(354.5,IBALERT,0)) G:IBA="" SENDQ
S X=$P($G(^IBE(354.5,IBALERT,3)),"^",1) I X="D" G SENDQ
S X=+IBALERT,DIC(0)="L",DIC="^IBA(354.4,",DLAYGO=354.4 K DD,DO D FILE^DICN S IBDA=+Y
S XQAID=$P(IBA,"^",2)_IBDA,XQAKILL=0
S XQAMSG=$P(IBP,"^")_" ("_$P(IBP,"^",3)_") - "_$P(IBA,"^",3)
I $P(IBA,"^",5)="R" S XQAROU=$S($P(IBA,"^",6)'="":$P(IBA,"^",6,7),1:$P(IBA,"^",7))
;
S XQADATA=$G(IBALERT)_";"_$G(DFN)_";"_$G(IBEXDA)_";"_$G(IBJOB)_";"_$G(IBWHER)_";"_$G(DUZ)_";"_$G(DT)_";"_$G(IBDA)
;
S DA=IBDA,DIE="^IBA(354.4,",DR=".02///NOW" D ^DIE K DIC,DIE,DA,DR
;
I $G(IBEXDA) S DA=IBEXDA,DIE="^IBA(354.1,",DR=".09////^S X=IBDA" D ^DIE K DIC,DIE,DA,DR
;
D TOWHO
;
D SETUP^XQALERT
;
SENDQ I $G(IBEXERR) S IBEXERR="" ; clear error flag
Q
;
TOWHO ; -- set xqa array to deliver to
N I,J
S I="" F S I=$O(^IBE(354.5,+IBALERT,200,I)) Q:'I S J=+^(I,0),XQA(J)=""
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)),"^"))=""
I '$D(XQA) D
.S J=+$P($G(^IBE(350.9,1,0)),"^",$S($G(IBALERT)<10:13,1:9))
.I +J'=0 S XQA("G."_$P($G(^XMB(3.8,+J,0)),"^"))=""
.I +J=0 S XQA("G.IB EDI SUPERVISOR")=""
;S XQA(DUZ)=""
TOWHOQ Q
;
1 ; -- process info only alerts
Q:$G(XQADATA)="" K XQAKILL
N DFN,IBP,IBCLEAR,DIR,DIRUT,DUOUT S IBCLEAR="YES"
D WRITE,CLEAR,UP
K IBCLEAR Q
;
11 ; -- process action alerts
Q:$G(XQADATA)="" K XQAKILL
N DFN,IBP,IBCLEAR,DIR,DIRUT,DUOUT S IBCLEAR="YES"
D WRITE,PROC,CLEAR,UP
Q
;
PROC ; -- process alert
; -- run ^ibarxex to see if okay
N IBDFN,DIR,X,Y W !!
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."
S DIR(0)="Y",DIR("A")="Run Manual Update Option",DIR("B")="YES" D ^DIR
I $D(DIRUT)!(Y=0) S IBCLEAR="NO" G PROCQ
S IBDFN=DFN D EN^IBARXEX S DFN=IBDFN
PROCQ Q
;
CLEAR ; -- clear entry in 354.4 and alert in 354.1
Q:$D(DIRUT)
N DIR,X,Y W !!
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."
S DIR(0)="Y",DIR("A")="Clear alert for all users ('^' to save alert)",DIR("B")=IBCLEAR D ^DIR
I $D(DIRUT) G CLEARQ
; -- xqakill=0 clear for all, =1 clear for current user only
S XQAKILL='Y
W !
CLEARQ Q
;
WRITE ; -- write out long message
; xqadata = alert type;dfn;exemption;ibjob;ibwhere;duz;dt;alert entry
N XQATMP,XQATMP1,XQATMP2
S DFN=$P(XQADATA,";",2),IBP=$$PT^IBEFUNC(DFN)
W !!,"Patient: ",$P(IBP,"^"),?40,$P(IBP,"^",2)
D DISP^IBARXEU(DFN,DT,3,0)
W:+XQADATA<11 !!,$P($T(MSG+(+XQADATA)),";;",2)
I +XQADATA>10 D
.S XQATMP=+XQADATA-10
.W !!,"The error that occurred was: ",$P($T(ERR+XQATMP^IBAERR2),";;",2),!,"Processed"
W " by ",$P($G(^VA(200,+$P(XQADATA,";",6),0)),"^")," on ",$$DAT1^IBOUTL($P(XQADATA,";",7)),"."
;
; -- this only handles ibjobs>10 (exemption)
I $P(XQADATA,";",4)>10 D
.S XQATMP1=$P(XQADATA,";",4)-10
.W !,"This occurred during the ",$P($T(JOB+XQATMP1^IBAERR2),";;",2)
I $P(XQADATA,";",5)>10 D
.S XQATMP2=$P(XQADATA,";",5)-10
.W !,$P($T(WHERE+XQATMP2^IBAERR2),";;",2)
;
WRITEQ Q
;
UP ; -- update error file with user
Q:'$D(XQAKILL)
N DA,DIC,DIE,DR,X,Y
G:'$P(XQADATA,";",8) UPQ
S DA=$P(XQADATA,";",8) S X=$G(^IBA(354.4,DA,0)) G:X=""!($P(X,"^",3)'="") UPQ
S DIE="^IBA(354.4,",DR=".03////"_DUZ_";.04///NOW" D ^DIE
;
G:$P($G(^IBA(354.1,+$P(XQADATA,";",3),0)),"^",9)="" UPQ
K DIC,DIE,DA,DR,X,Y
S DA=$P(XQADATA,";",3),DIE="^IBA(354.1,",DR=".09///@" D ^DIE
UPQ Q
;
MSG ;;
;;Patient has been given a Hardship Exemption
;;Patient's Hardship Exemption has been removed
;;Patient's Exemption based on Income has expired
;;
Q
;
PURGE ; -- purge entries in 354.4, clear pointer in 354.1, delete alert
; purge cleared entries older than 30 days, all over 60 days
;
; -- called by IBAMTC (nightly means test job)
; not user interactive (friendly)
;
Q:'$O(^IBA(354.4,"AC",0))
S X1=DT,X2=-30 D C^%DTC S IB30=X
S X1=DT,X2=-60 D C^%DTC S IB60=X
S IBDT=""
W:'$D(ZTQUEUED) !!,"Purging Alerts..."
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
.;
.S X=$G(^IBA(354.4,IBDA,0))
.I '$P(X,"^",3),(IBDT>IB60) Q
.;
.S XQAID=$P(^IBE(354.5,+1,0),"^",2)_IBDA
.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
.;
.S IBALERT=+$G(^IBA(354.4,+IBDA,0))
.D TOWHO S XQAKILL=0 D DELETEA^XQALERT
.;
.S DA=IBDA,DIK="^IBA(354.4," D ^DIK K DA,DIK
.Q
K IB30,IB60,IBDA,XQA,XQAID,XQAKILL,X,X1,X2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAERR3 5144 printed Dec 13, 2024@02:06:15 Page 2
IBAERR3 ;ALB/AAS - RX COPAY EXEMPTION ALERT PROCESSOR ;15-JAN-93
+1 ;;2.0;INTEGRATED BILLING;**356,546**;21-MAR-94;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% ; -- medication copayment exemption errors
+1 ;
SEND ; -- use kernel alerts
+1 NEW X,Y,IBA,IBDA,IBP,XQA,XQAID,XQAKILL,XQAMSG,XQAROU,XQAOPT,XQADATA,DIC,DA,DR,DIE,DLAYGO
+2 if '$DATA(IBALERT)
SET IBALERT=$GET(IBEXERR)+10
if 'IBALERT
GOTO SENDQ
+3 SET IBP=$$PT^IBEFUNC(DFN)
+4 SET IBA=$GET(^IBE(354.5,IBALERT,0))
if IBA=""
GOTO SENDQ
+5 SET X=$PIECE($GET(^IBE(354.5,IBALERT,3)),"^",1)
IF X="D"
GOTO SENDQ
+6 SET X=+IBALERT
SET DIC(0)="L"
SET DIC="^IBA(354.4,"
SET DLAYGO=354.4
KILL DD,DO
DO FILE^DICN
SET IBDA=+Y
+7 SET XQAID=$PIECE(IBA,"^",2)_IBDA
SET XQAKILL=0
+8 SET XQAMSG=$PIECE(IBP,"^")_" ("_$PIECE(IBP,"^",3)_") - "_$PIECE(IBA,"^",3)
+9 IF $PIECE(IBA,"^",5)="R"
SET XQAROU=$SELECT($PIECE(IBA,"^",6)'="":$PIECE(IBA,"^",6,7),1:$PIECE(IBA,"^",7))
+10 ;
+11 SET XQADATA=$GET(IBALERT)_";"_$GET(DFN)_";"_$GET(IBEXDA)_";"_$GET(IBJOB)_";"_$GET(IBWHER)_";"_$GET(DUZ)_";"_$GET(DT)_";"_$GET(IBDA)
+12 ;
+13 SET DA=IBDA
SET DIE="^IBA(354.4,"
SET DR=".02///NOW"
DO ^DIE
KILL DIC,DIE,DA,DR
+14 ;
+15 IF $GET(IBEXDA)
SET DA=IBEXDA
SET DIE="^IBA(354.1,"
SET DR=".09////^S X=IBDA"
DO ^DIE
KILL DIC,DIE,DA,DR
+16 ;
+17 DO TOWHO
+18 ;
+19 DO SETUP^XQALERT
+20 ;
SENDQ ; clear error flag
IF $GET(IBEXERR)
SET IBEXERR=""
+1 QUIT
+2 ;
TOWHO ; -- set xqa array to deliver to
+1 NEW I,J
+2 SET I=""
FOR
SET I=$ORDER(^IBE(354.5,+IBALERT,200,I))
if 'I
QUIT
SET J=+^(I,0)
SET XQA(J)=""
+3 SET I=""
FOR
SET I=$ORDER(^IBE(354.5,+IBALERT,2,I))
if 'I
QUIT
SET J=+^(I,0)
SET XQA("G."_$PIECE($GET(^XMB(3.8,+J,0)),"^"))=""
+4 IF '$DATA(XQA)
Begin DoDot:1
+5 SET J=+$PIECE($GET(^IBE(350.9,1,0)),"^",$SELECT($GET(IBALERT)<10:13,1:9))
+6 IF +J'=0
SET XQA("G."_$PIECE($GET(^XMB(3.8,+J,0)),"^"))=""
+7 IF +J=0
SET XQA("G.IB EDI SUPERVISOR")=""
End DoDot:1
+8 ;S XQA(DUZ)=""
TOWHOQ QUIT
+1 ;
1 ; -- process info only alerts
+1 if $GET(XQADATA)=""
QUIT
KILL XQAKILL
+2 NEW DFN,IBP,IBCLEAR,DIR,DIRUT,DUOUT
SET IBCLEAR="YES"
+3 DO WRITE
DO CLEAR
DO UP
+4 KILL IBCLEAR
QUIT
+5 ;
11 ; -- process action alerts
+1 if $GET(XQADATA)=""
QUIT
KILL XQAKILL
+2 NEW DFN,IBP,IBCLEAR,DIR,DIRUT,DUOUT
SET IBCLEAR="YES"
+3 DO WRITE
DO PROC
DO CLEAR
DO UP
+4 QUIT
+5 ;
PROC ; -- process alert
+1 ; -- run ^ibarxex to see if okay
+2 NEW IBDFN,DIR,X,Y
WRITE !!
+3 SET 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."
+4 SET DIR(0)="Y"
SET DIR("A")="Run Manual Update Option"
SET DIR("B")="YES"
DO ^DIR
+5 IF $DATA(DIRUT)!(Y=0)
SET IBCLEAR="NO"
GOTO PROCQ
+6 SET IBDFN=DFN
DO EN^IBARXEX
SET DFN=IBDFN
PROCQ QUIT
+1 ;
CLEAR ; -- clear entry in 354.4 and alert in 354.1
+1 if $DATA(DIRUT)
QUIT
+2 NEW DIR,X,Y
WRITE !!
+3 SET 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."
+4 SET DIR(0)="Y"
SET DIR("A")="Clear alert for all users ('^' to save alert)"
SET DIR("B")=IBCLEAR
DO ^DIR
+5 IF $DATA(DIRUT)
GOTO CLEARQ
+6 ; -- xqakill=0 clear for all, =1 clear for current user only
+7 SET XQAKILL='Y
+8 WRITE !
CLEARQ QUIT
+1 ;
WRITE ; -- write out long message
+1 ; xqadata = alert type;dfn;exemption;ibjob;ibwhere;duz;dt;alert entry
+2 NEW XQATMP,XQATMP1,XQATMP2
+3 SET DFN=$PIECE(XQADATA,";",2)
SET IBP=$$PT^IBEFUNC(DFN)
+4 WRITE !!,"Patient: ",$PIECE(IBP,"^"),?40,$PIECE(IBP,"^",2)
+5 DO DISP^IBARXEU(DFN,DT,3,0)
+6 if +XQADATA<11
WRITE !!,$PIECE($TEXT(MSG+(+XQADATA)),";;",2)
+7 IF +XQADATA>10
Begin DoDot:1
+8 SET XQATMP=+XQADATA-10
+9 WRITE !!,"The error that occurred was: ",$PIECE($TEXT(ERR+XQATMP^IBAERR2),";;",2),!,"Processed"
End DoDot:1
+10 WRITE " by ",$PIECE($GET(^VA(200,+$PIECE(XQADATA,";",6),0)),"^")," on ",$$DAT1^IBOUTL($PIECE(XQADATA,";",7)),"."
+11 ;
+12 ; -- this only handles ibjobs>10 (exemption)
+13 IF $PIECE(XQADATA,";",4)>10
Begin DoDot:1
+14 SET XQATMP1=$PIECE(XQADATA,";",4)-10
+15 WRITE !,"This occurred during the ",$PIECE($TEXT(JOB+XQATMP1^IBAERR2),";;",2)
End DoDot:1
+16 IF $PIECE(XQADATA,";",5)>10
Begin DoDot:1
+17 SET XQATMP2=$PIECE(XQADATA,";",5)-10
+18 WRITE !,$PIECE($TEXT(WHERE+XQATMP2^IBAERR2),";;",2)
End DoDot:1
+19 ;
WRITEQ QUIT
+1 ;
UP ; -- update error file with user
+1 if '$DATA(XQAKILL)
QUIT
+2 NEW DA,DIC,DIE,DR,X,Y
+3 if '$PIECE(XQADATA,";",8)
GOTO UPQ
+4 SET DA=$PIECE(XQADATA,";",8)
SET X=$GET(^IBA(354.4,DA,0))
if X=""!($PIECE(X,"^",3)'="")
GOTO UPQ
+5 SET DIE="^IBA(354.4,"
SET DR=".03////"_DUZ_";.04///NOW"
DO ^DIE
+6 ;
+7 if $PIECE($GET(^IBA(354.1,+$PIECE(XQADATA,";",3),0)),"^",9)=""
GOTO UPQ
+8 KILL DIC,DIE,DA,DR,X,Y
+9 SET DA=$PIECE(XQADATA,";",3)
SET DIE="^IBA(354.1,"
SET DR=".09///@"
DO ^DIE
UPQ QUIT
+1 ;
MSG ;;
+1 ;;Patient has been given a Hardship Exemption
+2 ;;Patient's Hardship Exemption has been removed
+3 ;;Patient's Exemption based on Income has expired
+4 ;;
+5 QUIT
+6 ;
PURGE ; -- purge entries in 354.4, clear pointer in 354.1, delete alert
+1 ; purge cleared entries older than 30 days, all over 60 days
+2 ;
+3 ; -- called by IBAMTC (nightly means test job)
+4 ; not user interactive (friendly)
+5 ;
+6 if '$ORDER(^IBA(354.4,"AC",0))
QUIT
+7 SET X1=DT
SET X2=-30
DO C^%DTC
SET IB30=X
+8 SET X1=DT
SET X2=-60
DO C^%DTC
SET IB60=X
+9 SET IBDT=""
+10 if '$DATA(ZTQUEUED)
WRITE !!,"Purging Alerts..."
+11 FOR
SET IBDT=$ORDER(^IBA(354.4,"AC",IBDT))
if 'IBDT!(IBDT>IB30)
QUIT
SET IBDA=0
FOR
SET IBDA=$ORDER(^IBA(354.4,"AC",IBDT,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+12 ;
+13 SET X=$GET(^IBA(354.4,IBDA,0))
+14 IF '$PIECE(X,"^",3)
IF (IBDT>IB60)
QUIT
+15 ;
+16 SET XQAID=$PIECE(^IBE(354.5,+1,0),"^",2)_IBDA
+17 SET X=$ORDER(^IBA(354.1,"ALERT",IBDA,0))
IF X
SET DA=X
SET DR=".09///@"
SET DIE="^IBA(354.1,"
DO ^DIE
KILL DA,DR,DIE
+18 ;
+19 SET IBALERT=+$GET(^IBA(354.4,+IBDA,0))
+20 DO TOWHO
SET XQAKILL=0
DO DELETEA^XQALERT
+21 ;
+22 SET DA=IBDA
SET DIK="^IBA(354.4,"
DO ^DIK
KILL DA,DIK
+23 QUIT
End DoDot:1
+24 KILL IB30,IB60,IBDA,XQA,XQAID,XQAKILL,X,X1,X2
