- 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 Jan 18, 2025@03:07:28 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