Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAERR3

IBAERR3.m

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