- 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 Feb 18, 2025@23:33:38 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