IBARXEI ;ALB/AAS - RX COPAY EXEMPTION INQUIRY ; 21-JAN-93
;;2.0; INTEGRATED BILLING ;**34,199**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% I '$D(IOF) D HOME^%ZIS
;
PAT I $G(IBQUIT) G END
D END
S (IBPAG,IBQUIT)=0 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=Y
;
S DIC("W")="N IBX S IBX=$G(^IBA(354,+Y,0)) W ?32,"" "",$P($G(^DPT(+IBX,0)),U,9),?46,"" "",$$TEXT^IBARXEU0($P(IBX,U,4)),?59,"" "",$P($G(^IBE(354.2,+$P(IBX,U,5),0)),U)"
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
W ! S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQM",DIC("A")="Select BILLING PATIENT: " D ^DIC K DIC
G:Y<1 END
S DFN=+Y,IBP=$$PT^IBEFUNC(DFN),IBPBN=$G(^IBA(354,DFN,0))
;
TYP ; -- inquire is active or all
S DIR("?")="Enter 1 or B to see a brief inquiry of all Active Exemptions or enter 2 or F to see a full inquiry of the entire exemption history"
S DIR(0)="SAOM^1:BRIEF;2:FULL",DIR("A")="(B)rief or (Full) Inquiry: ",DIR("B")="Brief"
D ^DIR K DIR G:$D(DIRUT)!($G(Y)<1) END S IBFULL=Y
;
DEV S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^IBARXEI",ZTSAVE("IB*")="",ZTSAVE("DFN")="",ZTDESC="IB INQUIRE TO PATIENT EXEMPTION" D ^%ZTLOAD,HOME^%ZIS K ZTSK D END G PAT
U IO
;
DQ ;
K ^TMP($J)
D @IBFULL
I 'IBQUIT,$E(IOST,1,2)="C-" D PAUSE^IBOUTL
I '$D(ZTQUEUED) D END G PAT
G END
Q
;
1 ; -- brief view active exemptions
D DISP^IBARXEX,STAT^IBARXEX
Q
;
2 ; -- full view all exemptions
D HDR
S IBT=""
;
; -- build list in inverse effective date, inverse date/time added
F S IBT=$O(^IBA(354.1,"APIDT",DFN,IBT)) Q:'IBT S IBIDT="" F S IBIDT=$O(^IBA(354.1,"APIDT",DFN,IBT,IBIDT)) Q:'IBIDT S IBDA="" F S IBDA=$O(^IBA(354.1,"APIDT",DFN,IBT,IBIDT,IBDA)) Q:'IBDA!(IBQUIT) D SET
;
; -- print list
S IBIDT="" F S IBIDT=$O(^TMP($J,DFN,IBIDT)) Q:'IBIDT!(IBQUIT) S IBA="" F S IBA=$O(^TMP($J,DFN,IBIDT,IBA)) Q:'IBA!(IBQUIT) S IBDA="" F S IBDA=$O(^TMP($J,DFN,IBIDT,IBA,IBDA)) Q:'IBDA!(IBQUIT) S IBND=^(IBDA) D FULL
;
Q
;
END K ^TMP($J) S ZTREQ="@" I $D(ZTQUEUED) Q
D ^%ZISC
K C,X,Y,DFN,DIC,DIR,DIRUT,ZTSK,ZTREQ,IBCNT,IBDA,IBDT,IBFULL,IBIDT,IBJ,IBND,IBP,IBPAG,IBPBN,IBPDAT,IBQUIT,IBSTAT,IBSTATR,IBT
Q
;
HDR ; -- print header for full inquiry
I IBPAG!($E(IOST,1,2)="C-") W @IOF
S IBPAG=IBPAG+1
W "Billing Exemption Inquiry",?(IOM-35),$P(IBPDAT,"@")," ",$P(IBPDAT,"@",2)," Page ",IBPAG
W !,$E($P(IBP,"^"),1,20)," ",$P(IBP,"^",3),?27,"Currently: ",$$TEXT^IBARXEU0($P(IBPBN,"^",4))_"-"_$P($G(^IBE(354.2,+$P(IBPBN,"^",5),0)),"^"),?65," ",$$DAT1^IBOUTL($P(IBPBN,"^",3))
W !,$TR($J(" ",IOM)," ","-")
Q
;
FULL ; -- print full inquiry for one exemption
I $Y>(IOSL-8) D PAUSE^IBOUTL Q:IBQUIT D HDR
I $G(IBND)="" W !,"Error, Missing Record - ",IBDA Q
S Y=+IBND D D^DIQ
W !,$S($P(IBND,"^",10):"**",1:" "),"Effective Date: ",Y
W ?36," Type: ",$P($P($P(^DD(354.1,.03,0),"^",3),$P(IBND,"^",3)_":",2),";",1)
W !," Status: ",$P($P($P(^DD(354.1,.04,0),"^",3),$P(IBND,"^",4)_":",2),";",1)
W ?36," Reason: ",$P($G(^IBE(354.2,+$P(IBND,"^",5),0)),"^")
W !," Active: ",$S($P(IBND,"^",10):"YES, ACTIVE",1:"NO, INACTIVE")
W ?36," User: ",$P($G(^VA(200,+$P(IBND,"^",7),0)),"^")
W !," How Added: ",$P($P($P(^DD(354.1,.06,0),"^",3),$P(IBND,"^",6)_":",2),";",1)
W ?36,"When Added: " S Y=$P(IBND,"^",8) D DT^DIQ
I $P(IBND,"^",13)'="" W !,"Charges Canceled: " S Y=$P(IBND,"^",13) D DT^DIQ W ?36," To: " S Y=$P(IBND,"^",14) D DT^DIQ
I $P(IBND,"^",15)'="" W !," Prior Threshold: " S Y=$P(IBND,"^",15) D DT^DIQ
I $G(DUZ(0))="@" W !," Patient DFN: ",$P(IBND,"^",2),?36,"Ex. Number: ",IBDA
W !
Q
;
SET ; -- built tmp array ==> ^tmp($j, dfn, -eff date, -date/time added, da)
N X
S X=$G(^IBA(354.1,+IBDA,0)) Q:X=""
S ^TMP($J,DFN,IBIDT,-$P(X,"^",8),IBDA)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEI 3867 printed Nov 22, 2024@17:17:19 Page 2
IBARXEI ;ALB/AAS - RX COPAY EXEMPTION INQUIRY ; 21-JAN-93
+1 ;;2.0; INTEGRATED BILLING ;**34,199**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% IF '$DATA(IOF)
DO HOME^%ZIS
+1 ;
PAT IF $GET(IBQUIT)
GOTO END
+1 DO END
+2 SET (IBPAG,IBQUIT)=0
DO NOW^%DTC
SET Y=%
DO D^DIQ
SET IBPDAT=Y
+3 ;
+4 SET DIC("W")="N IBX S IBX=$G(^IBA(354,+Y,0)) W ?32,"" "",$P($G(^DPT(+IBX,0)),U,9),?46,"" "",$$TEXT^IBARXEU0($P(IBX,U,4)),?59,"" "",$P($G(^IBE(354.2,+$P(IBX,U,5),0)),U)"
+5 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+6 WRITE !
SET DIC="^DPT("
SET DIC("S")="I $D(^IBA(354,+Y,0))"
SET DIC(0)="AEQM"
SET DIC("A")="Select BILLING PATIENT: "
DO ^DIC
KILL DIC
+7 if Y<1
GOTO END
+8 SET DFN=+Y
SET IBP=$$PT^IBEFUNC(DFN)
SET IBPBN=$GET(^IBA(354,DFN,0))
+9 ;
TYP ; -- inquire is active or all
+1 SET DIR("?")="Enter 1 or B to see a brief inquiry of all Active Exemptions or enter 2 or F to see a full inquiry of the entire exemption history"
+2 SET DIR(0)="SAOM^1:BRIEF;2:FULL"
SET DIR("A")="(B)rief or (Full) Inquiry: "
SET DIR("B")="Brief"
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)!($GET(Y)<1)
GOTO END
SET IBFULL=Y
+4 ;
DEV SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+1 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="DQ^IBARXEI"
SET ZTSAVE("IB*")=""
SET ZTSAVE("DFN")=""
SET ZTDESC="IB INQUIRE TO PATIENT EXEMPTION"
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
DO END
GOTO PAT
+2 USE IO
+3 ;
DQ ;
+1 KILL ^TMP($JOB)
+2 DO @IBFULL
+3 IF 'IBQUIT
IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^IBOUTL
+4 IF '$DATA(ZTQUEUED)
DO END
GOTO PAT
+5 GOTO END
+6 QUIT
+7 ;
1 ; -- brief view active exemptions
+1 DO DISP^IBARXEX
DO STAT^IBARXEX
+2 QUIT
+3 ;
2 ; -- full view all exemptions
+1 DO HDR
+2 SET IBT=""
+3 ;
+4 ; -- build list in inverse effective date, inverse date/time added
+5 FOR
SET IBT=$ORDER(^IBA(354.1,"APIDT",DFN,IBT))
if 'IBT
QUIT
SET IBIDT=""
FOR
SET IBIDT=$ORDER(^IBA(354.1,"APIDT",DFN,IBT,IBIDT))
if 'IBIDT
QUIT
SET IBDA=""
FOR
SET IBDA=$ORDER(^IBA(354.1,"APIDT",DFN,IBT,IBIDT,IBDA))
if 'IBDA!(IBQUIT)
QUIT
DO SET
+6 ;
+7 ; -- print list
+8 SET IBIDT=""
FOR
SET IBIDT=$ORDER(^TMP($JOB,DFN,IBIDT))
if 'IBIDT!(IBQUIT)
QUIT
SET IBA=""
FOR
SET IBA=$ORDER(^TMP($JOB,DFN,IBIDT,IBA))
if 'IBA!(IBQUIT)
QUIT
SET IBDA=""
FOR
SET IBDA=$ORDER(^TMP($JOB,DFN,IBIDT,IBA,IBDA))
if 'IBDA!(IBQUIT)
QUIT
SET IBND=^(IBDA)
DO FULL
+9 ;
+10 QUIT
+11 ;
END KILL ^TMP($JOB)
SET ZTREQ="@"
IF $DATA(ZTQUEUED)
QUIT
+1 DO ^%ZISC
+2 KILL C,X,Y,DFN,DIC,DIR,DIRUT,ZTSK,ZTREQ,IBCNT,IBDA,IBDT,IBFULL,IBIDT,IBJ,IBND,IBP,IBPAG,IBPBN,IBPDAT,IBQUIT,IBSTAT,IBSTATR,IBT
+3 QUIT
+4 ;
HDR ; -- print header for full inquiry
+1 IF IBPAG!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET IBPAG=IBPAG+1
+3 WRITE "Billing Exemption Inquiry",?(IOM-35),$PIECE(IBPDAT,"@")," ",$PIECE(IBPDAT,"@",2)," Page ",IBPAG
+4 WRITE !,$EXTRACT($PIECE(IBP,"^"),1,20)," ",$PIECE(IBP,"^",3),?27,"Currently: ",$$TEXT^IBARXEU0($PIECE(IBPBN,"^",4))_"-"_$PIECE($GET(^IBE(354.2,+$PIECE(IBPBN,"^",5),0)),"^"),?65," ",$$DAT1^IBOUTL($PIECE(IBPBN,"^",3))
+5 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+6 QUIT
+7 ;
FULL ; -- print full inquiry for one exemption
+1 IF $Y>(IOSL-8)
DO PAUSE^IBOUTL
if IBQUIT
QUIT
DO HDR
+2 IF $GET(IBND)=""
WRITE !,"Error, Missing Record - ",IBDA
QUIT
+3 SET Y=+IBND
DO D^DIQ
+4 WRITE !,$SELECT($PIECE(IBND,"^",10):"**",1:" "),"Effective Date: ",Y
+5 WRITE ?36," Type: ",$PIECE($PIECE($PIECE(^DD(354.1,.03,0),"^",3),$PIECE(IBND,"^",3)_":",2),";",1)
+6 WRITE !," Status: ",$PIECE($PIECE($PIECE(^DD(354.1,.04,0),"^",3),$PIECE(IBND,"^",4)_":",2),";",1)
+7 WRITE ?36," Reason: ",$PIECE($GET(^IBE(354.2,+$PIECE(IBND,"^",5),0)),"^")
+8 WRITE !," Active: ",$SELECT($PIECE(IBND,"^",10):"YES, ACTIVE",1:"NO, INACTIVE")
+9 WRITE ?36," User: ",$PIECE($GET(^VA(200,+$PIECE(IBND,"^",7),0)),"^")
+10 WRITE !," How Added: ",$PIECE($PIECE($PIECE(^DD(354.1,.06,0),"^",3),$PIECE(IBND,"^",6)_":",2),";",1)
+11 WRITE ?36,"When Added: "
SET Y=$PIECE(IBND,"^",8)
DO DT^DIQ
+12 IF $PIECE(IBND,"^",13)'=""
WRITE !,"Charges Canceled: "
SET Y=$PIECE(IBND,"^",13)
DO DT^DIQ
WRITE ?36," To: "
SET Y=$PIECE(IBND,"^",14)
DO DT^DIQ
+13 IF $PIECE(IBND,"^",15)'=""
WRITE !," Prior Threshold: "
SET Y=$PIECE(IBND,"^",15)
DO DT^DIQ
+14 IF $GET(DUZ(0))="@"
WRITE !," Patient DFN: ",$PIECE(IBND,"^",2),?36,"Ex. Number: ",IBDA
+15 WRITE !
+16 QUIT
+17 ;
SET ; -- built tmp array ==> ^tmp($j, dfn, -eff date, -date/time added, da)
+1 NEW X
+2 SET X=$GET(^IBA(354.1,+IBDA,0))
if X=""
QUIT
+3 SET ^TMP($JOB,DFN,IBIDT,-$PIECE(X,"^",8),IBDA)=X
+4 QUIT
