Routine: IBARXEPV

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

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)

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

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)," ","-")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEPV   4955     printed  Feb 18, 2025@23:33: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

IBARXEPV.m