IBARXEPV ;ALB/AAS - RX COPAY EXEMPTION VERIFY STATUS ; 02/12/2004
;;2.0;INTEGRATED BILLING;**262**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% ; -- print/verify patients whose current exemption does not match
; what is currently computed.
I '$D(DT) D DT^DICRW
S IBQUIT=0
I '$D(IOF) D HOME^%ZIS
W @IOF,"Verify Medication Copayment Exemption Status"
W !! D DATE^IBOUTL
I 'IBBDT!('IBEDT)!(IBEDT<IBBDT) G END
;
; -- update patient status
W !
S DIR("?")="Answer 'YES' if you want to automatically update patient status to the computed status, or 'NO' to print a report of discrepancies."
S DIR(0)="Y",DIR("A")="Update Patient Status",DIR("B")="NO" D ^DIR K DIR S IBUP=+Y
I $D(DIRUT) G END
W !
;
DEV W !!,"You will need a 132 column printer for this report!",!
S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) S ZTRTN="DQ^IBARXEPV",ZTSAVE("IB*")="",ZTDESC="IB Verify Medication Copayment exemption" D ^%ZTLOAD K ZTSK,IO("Q") D HOME^%ZIS G END
I '$D(ZTQUEUED) W !,"HMMMM, LET ME THINK ABOUT THIS FOR A MINUTE"
U IO
;
DQ ; -- entry point from task man to start comparison
S (IBPCNT,IBPAG)=0,IBOK=1 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
K ^TMP($J,"IBUNVER")
;
; -- look through inverse date x-ref
S IBDT=IBBDT-.00001
F S IBDT=$O(^IBA(354.1,"B",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.9)) S IBDA=0 F S IBDA=$O(^IBA(354.1,"B",IBDT,IBDA)) Q:'IBDA D CHK I 'IBOK D UP:IBUP,SET
D REPORT,PAUSE^IBOUTL:'IBQUIT
G END
;
END K ^TMP($J,"IBUNVER")
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
K DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
K IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
Q
;
REPORT ; -- print report
D HDR S IBDCNT=0
I '$D(^TMP($J,"IBUNVER")) W !,"No discrepancies found in ",IBPCNT," exemptions checked." G REPORTQ
;
S IBNAM=""
F S IBNAM=$O(^TMP($J,"IBUNVER",IBNAM)) Q:IBNAM=""!(IBQUIT) S IBDFN="" F S IBDFN=$O(^TMP($J,"IBUNVER",IBNAM,IBDFN)) Q:IBDFN=""!(IBQUIT) S IBER=^(IBDFN) D LINE
;
W !!,"There were ",IBDCNT," discrepancies found in ",IBPCNT," exemptions checked."
;
REPORTQ Q
;
LINE ; -- write each line
S DFN=+IBDFN,IBDCNT=IBDCNT+1
I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR
W !,$E(IBNAM,1,20),?22,$P(IBER,"^",8)
S X=$P(IBER,"^",5) W ?39,$S(X=3:"Exemption incorrect",X=1!(X=2)!(X=5):"Not Current Status",X=4:"Name Missing",1:"Hmmmm")
W ?61,$$DAT1^IBOUTL($P(IBER,"^",2))_" "_$E($P($G(^IBE(354.2,+IBER,0)),"^"),1,15)
W ?88,$$DAT1^IBOUTL($P(IBER,"^",4))_" "_$E($P($G(^IBE(354.2,+$P(IBER,"^",3),0)),"^"),1,15)
W ?115,$P(IBER,"^",6)
Q
;
CHK ; -- check if current status = computed status
S IBOK=1,IBMESS="Nothing Updated",IBERR=""
S X=$G(^IBA(354.1,+IBDA,0)) G CHKQ:'$P(X,"^",10) ;not active skip
S DFN=$P(X,"^",2)
S Y=$G(^IBA(354,DFN,0)) I +X<$P(Y,"^",3) G CHKQ ;not current exemption
;
N DGMT,CONV,CLN S (CLN,CONV)=0,DGMT=$$LST^DGMTU(DFN,+X,1)
I $P(DGMT,U,5)=2 D G:CONV CHKQ ; skip Edb conv. tests
.; Loop through the MT comments, Check for EDB converted test
.; No comments to check
.Q:'$D(^DGMT(408.31,+DGMT,"C",1,0))
.F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV) D
..I ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb" S CONV=1
;
S IBPCNT=IBPCNT+1
I '+Y S IBOK=0,IBERR=4
S IBEXREAO=$P(X,"^",5)_"^"_+X ;current exemption
I $P($G(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010 G CHKQ ; hardships don't report
I +X>$P(Y,"^",3) S IBOK=0,IBERR=1 ;most current exemption not in 354
I $P(X,"^",5)'=$P(Y,"^",5) S IBOK=0,IBERR=2 ;Current exemption not in 354
I $P(X,"^",4)'=$P(Y,"^",4) S IBOK=0,IBERR=5 ;current status in exemption not in 354
S IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
I +IBEXREAO'=+IBEXREAN S IBOK=0,IBERR=3
CHKQ Q
;
UP ; -- update current exemption status
Q:IBOK
S IBJOB=15,IBWHER=16
I IBERR=4 D G UPQ
.S DIE="^IBA(354,",DA=DFN,DR=".01////"_DFN D ^DIE
.K DIE,DA,DR,DIC
.S IBMESS="Name Corrected"
UP1 N IBOLDAUT S IBOLDAUT=""
;
; -- if currently not auto exempt make sure not more recent autoexempt
I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
S IBFORCE=$P(IBEXREAN,"^",2)
D MOSTR^IBARXEU5($P(IBEXREAN,"^",2),+IBEXREAN)
D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
S IBMESS="Updated"
UPQ K IBFORCE Q
;
SET ; -- set ^tmp node if not okay
Q:IBOK
S IBP=$$PT^IBEFUNC(DFN)
S IBDFN=DFN
I $D(^TMP($J,"IBUNVER",$P(IBP,"^"),DFN)) S IBDFN=DFN_"-"_IBPCNT
S ^TMP($J,"IBUNVER",$P(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
Q
;
HDR ; -- print header
I IBPAG!($E(IOST,1,2)="C-") W @IOF
S IBPAG=IBPAG+1
W !,"Medication Copayment Exemption Problem Report",?(IOM-31),IBPDAT," Page ",IBPAG
W !,"Patient",?22,"PT. ID",?39,"Error",?61,"Current Exemption",?88,"Computed Exemption",?115,"Action"
W !,$TR($J(" ",IOM)," ","-")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEPV 4955 printed Apr 09, 2024@21:24:45 Page 2
IBARXEPV ;ALB/AAS - RX COPAY EXEMPTION VERIFY STATUS ; 02/12/2004
+1 ;;2.0;INTEGRATED BILLING;**262**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% ; -- print/verify patients whose current exemption does not match
+1 ; what is currently computed.
+2 IF '$DATA(DT)
DO DT^DICRW
+3 SET IBQUIT=0
+4 IF '$DATA(IOF)
DO HOME^%ZIS
+5 WRITE @IOF,"Verify Medication Copayment Exemption Status"
+6 WRITE !!
DO DATE^IBOUTL
+7 IF 'IBBDT!('IBEDT)!(IBEDT<IBBDT)
GOTO END
+8 ;
+9 ; -- update patient status
+10 WRITE !
+11 SET DIR("?")="Answer 'YES' if you want to automatically update patient status to the computed status, or 'NO' to print a report of discrepancies."
+12 SET DIR(0)="Y"
SET DIR("A")="Update Patient Status"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
SET IBUP=+Y
+13 IF $DATA(DIRUT)
GOTO END
+14 WRITE !
+15 ;
DEV WRITE !!,"You will need a 132 column printer for this report!",!
+1 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+2 IF $DATA(IO("Q"))
SET ZTRTN="DQ^IBARXEPV"
SET ZTSAVE("IB*")=""
SET ZTDESC="IB Verify Medication Copayment exemption"
DO ^%ZTLOAD
KILL ZTSK,IO("Q")
DO HOME^%ZIS
GOTO END
+3 IF '$DATA(ZTQUEUED)
WRITE !,"HMMMM, LET ME THINK ABOUT THIS FOR A MINUTE"
+4 USE IO
+5 ;
DQ ; -- entry point from task man to start comparison
+1 SET (IBPCNT,IBPAG)=0
SET IBOK=1
DO NOW^%DTC
SET Y=%
DO D^DIQ
SET IBPDAT=$PIECE(Y,"@")_" "_$EXTRACT($PIECE(Y,"@",2),1,5)
+2 KILL ^TMP($JOB,"IBUNVER")
+3 ;
+4 ; -- look through inverse date x-ref
+5 SET IBDT=IBBDT-.00001
+6 FOR
SET IBDT=$ORDER(^IBA(354.1,"B",IBDT))
if 'IBDT!(IBDT>(IBEDT+.9))
QUIT
SET IBDA=0
FOR
SET IBDA=$ORDER(^IBA(354.1,"B",IBDT,IBDA))
if 'IBDA
QUIT
DO CHK
IF 'IBOK
if IBUP
DO UP
DO SET
+7 DO REPORT
if 'IBQUIT
DO PAUSE^IBOUTL
+8 GOTO END
+9 ;
END KILL ^TMP($JOB,"IBUNVER")
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 DO ^%ZISC
+3 KILL DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
+4 KILL IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
+5 QUIT
+6 ;
REPORT ; -- print report
+1 DO HDR
SET IBDCNT=0
+2 IF '$DATA(^TMP($JOB,"IBUNVER"))
WRITE !,"No discrepancies found in ",IBPCNT," exemptions checked."
GOTO REPORTQ
+3 ;
+4 SET IBNAM=""
+5 FOR
SET IBNAM=$ORDER(^TMP($JOB,"IBUNVER",IBNAM))
if IBNAM=""!(IBQUIT)
QUIT
SET IBDFN=""
FOR
SET IBDFN=$ORDER(^TMP($JOB,"IBUNVER",IBNAM,IBDFN))
if IBDFN=""!(IBQUIT)
QUIT
SET IBER=^(IBDFN)
DO LINE
+6 ;
+7 WRITE !!,"There were ",IBDCNT," discrepancies found in ",IBPCNT," exemptions checked."
+8 ;
REPORTQ QUIT
+1 ;
LINE ; -- write each line
+1 SET DFN=+IBDFN
SET IBDCNT=IBDCNT+1
+2 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
if IBQUIT
QUIT
DO HDR
+3 WRITE !,$EXTRACT(IBNAM,1,20),?22,$PIECE(IBER,"^",8)
+4 SET X=$PIECE(IBER,"^",5)
WRITE ?39,$SELECT(X=3:"Exemption incorrect",X=1!(X=2)!(X=5):"Not Current Status",X=4:"Name Missing",1:"Hmmmm")
+5 WRITE ?61,$$DAT1^IBOUTL($PIECE(IBER,"^",2))_" "_$EXTRACT($PIECE($GET(^IBE(354.2,+IBER,0)),"^"),1,15)
+6 WRITE ?88,$$DAT1^IBOUTL($PIECE(IBER,"^",4))_" "_$EXTRACT($PIECE($GET(^IBE(354.2,+$PIECE(IBER,"^",3),0)),"^"),1,15)
+7 WRITE ?115,$PIECE(IBER,"^",6)
+8 QUIT
+9 ;
CHK ; -- check if current status = computed status
+1 SET IBOK=1
SET IBMESS="Nothing Updated"
SET IBERR=""
+2 ;not active skip
SET X=$GET(^IBA(354.1,+IBDA,0))
if '$PIECE(X,"^",10)
GOTO CHKQ
+3 SET DFN=$PIECE(X,"^",2)
+4 ;not current exemption
SET Y=$GET(^IBA(354,DFN,0))
IF +X<$PIECE(Y,"^",3)
GOTO CHKQ
+5 ;
+6 NEW DGMT,CONV,CLN
SET (CLN,CONV)=0
SET DGMT=$$LST^DGMTU(DFN,+X,1)
+7 ; skip Edb conv. tests
IF $PIECE(DGMT,U,5)=2
Begin DoDot:1
+8 ; Loop through the MT comments, Check for EDB converted test
+9 ; No comments to check
+10 if '$DATA(^DGMT(408.31,+DGMT,"C",1,0))
QUIT
+11 FOR
SET CLN=$ORDER(^DGMT(408.31,+DGMT,"C",CLN))
if 'CLN!(CONV)
QUIT
Begin DoDot:2
+12 IF ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb"
SET CONV=1
End DoDot:2
End DoDot:1
if CONV
GOTO CHKQ
+13 ;
+14 SET IBPCNT=IBPCNT+1
+15 IF '+Y
SET IBOK=0
SET IBERR=4
+16 ;current exemption
SET IBEXREAO=$PIECE(X,"^",5)_"^"_+X
+17 ; hardships don't report
IF $PIECE($GET(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010
GOTO CHKQ
+18 ;most current exemption not in 354
IF +X>$PIECE(Y,"^",3)
SET IBOK=0
SET IBERR=1
+19 ;Current exemption not in 354
IF $PIECE(X,"^",5)'=$PIECE(Y,"^",5)
SET IBOK=0
SET IBERR=2
+20 ;current status in exemption not in 354
IF $PIECE(X,"^",4)'=$PIECE(Y,"^",4)
SET IBOK=0
SET IBERR=5
+21 SET IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
+22 IF +IBEXREAO'=+IBEXREAN
SET IBOK=0
SET IBERR=3
CHKQ QUIT
+1 ;
UP ; -- update current exemption status
+1 if IBOK
QUIT
+2 SET IBJOB=15
SET IBWHER=16
+3 IF IBERR=4
Begin DoDot:1
+4 SET DIE="^IBA(354,"
SET DA=DFN
SET DR=".01////"_DFN
DO ^DIE
+5 KILL DIE,DA,DR,DIC
+6 SET IBMESS="Name Corrected"
End DoDot:1
GOTO UPQ
UP1 NEW IBOLDAUT
SET IBOLDAUT=""
+1 ;
+2 ; -- if currently not auto exempt make sure not more recent autoexempt
+3 IF $LENGTH($PIECE($GET(^IBE(354.2,+IBEXREAN,0)),"^",5))>2
DO OLDAUT^IBARXEX1(IBEXREAN)
+4 SET IBFORCE=$PIECE(IBEXREAN,"^",2)
+5 DO MOSTR^IBARXEU5($PIECE(IBEXREAN,"^",2),+IBEXREAN)
+6 DO ADDEX^IBAUTL6(+IBEXREAN,$PIECE(IBEXREAN,"^",2),1,1,IBOLDAUT)
+7 SET IBMESS="Updated"
UPQ KILL IBFORCE
QUIT
+1 ;
SET ; -- set ^tmp node if not okay
+1 if IBOK
QUIT
+2 SET IBP=$$PT^IBEFUNC(DFN)
+3 SET IBDFN=DFN
+4 IF $DATA(^TMP($JOB,"IBUNVER",$PIECE(IBP,"^"),DFN))
SET IBDFN=DFN_"-"_IBPCNT
+5 SET ^TMP($JOB,"IBUNVER",$PIECE(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
+6 QUIT
+7 ;
HDR ; -- print header
+1 IF IBPAG!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET IBPAG=IBPAG+1
+3 WRITE !,"Medication Copayment Exemption Problem Report",?(IOM-31),IBPDAT," Page ",IBPAG
+4 WRITE !,"Patient",?22,"PT. ID",?39,"Error",?61,"Current Exemption",?88,"Computed Exemption",?115,"Action"
+5 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+6 QUIT
