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

IBARXEI.m

Go to the documentation of this file.
  1. IBARXEI ;ALB/AAS - RX COPAY EXEMPTION INQUIRY ; 21-JAN-93
  1. ;;2.0; INTEGRATED BILLING ;**34,199**; 21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. % I '$D(IOF) D HOME^%ZIS
  1. ;
  1. PAT I $G(IBQUIT) G END
  1. D END
  1. S (IBPAG,IBQUIT)=0 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=Y
  1. ;
  1. 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)"
  1. N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
  1. W ! S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQM",DIC("A")="Select BILLING PATIENT: " D ^DIC K DIC
  1. G:Y<1 END
  1. S DFN=+Y,IBP=$$PT^IBEFUNC(DFN),IBPBN=$G(^IBA(354,DFN,0))
  1. ;
  1. TYP ; -- inquire is active or all
  1. 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"
  1. S DIR(0)="SAOM^1:BRIEF;2:FULL",DIR("A")="(B)rief or (Full) Inquiry: ",DIR("B")="Brief"
  1. D ^DIR K DIR G:$D(DIRUT)!($G(Y)<1) END S IBFULL=Y
  1. ;
  1. DEV S %ZIS="QM" D ^%ZIS G:POP END
  1. 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
  1. U IO
  1. ;
  1. DQ ;
  1. K ^TMP($J)
  1. D @IBFULL
  1. I 'IBQUIT,$E(IOST,1,2)="C-" D PAUSE^IBOUTL
  1. I '$D(ZTQUEUED) D END G PAT
  1. G END
  1. Q
  1. ;
  1. 1 ; -- brief view active exemptions
  1. D DISP^IBARXEX,STAT^IBARXEX
  1. Q
  1. ;
  1. 2 ; -- full view all exemptions
  1. D HDR
  1. S IBT=""
  1. ;
  1. ; -- build list in inverse effective date, inverse date/time added
  1. 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
  1. ;
  1. ; -- print list
  1. 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
  1. ;
  1. Q
  1. ;
  1. END K ^TMP($J) S ZTREQ="@" I $D(ZTQUEUED) Q
  1. D ^%ZISC
  1. 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
  1. Q
  1. ;
  1. HDR ; -- print header for full inquiry
  1. I IBPAG!($E(IOST,1,2)="C-") W @IOF
  1. S IBPAG=IBPAG+1
  1. W "Billing Exemption Inquiry",?(IOM-35),$P(IBPDAT,"@")," ",$P(IBPDAT,"@",2)," Page ",IBPAG
  1. 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))
  1. W !,$TR($J(" ",IOM)," ","-")
  1. Q
  1. ;
  1. FULL ; -- print full inquiry for one exemption
  1. I $Y>(IOSL-8) D PAUSE^IBOUTL Q:IBQUIT D HDR
  1. I $G(IBND)="" W !,"Error, Missing Record - ",IBDA Q
  1. S Y=+IBND D D^DIQ
  1. W !,$S($P(IBND,"^",10):"**",1:" "),"Effective Date: ",Y
  1. W ?36," Type: ",$P($P($P(^DD(354.1,.03,0),"^",3),$P(IBND,"^",3)_":",2),";",1)
  1. W !," Status: ",$P($P($P(^DD(354.1,.04,0),"^",3),$P(IBND,"^",4)_":",2),";",1)
  1. W ?36," Reason: ",$P($G(^IBE(354.2,+$P(IBND,"^",5),0)),"^")
  1. W !," Active: ",$S($P(IBND,"^",10):"YES, ACTIVE",1:"NO, INACTIVE")
  1. W ?36," User: ",$P($G(^VA(200,+$P(IBND,"^",7),0)),"^")
  1. W !," How Added: ",$P($P($P(^DD(354.1,.06,0),"^",3),$P(IBND,"^",6)_":",2),";",1)
  1. W ?36,"When Added: " S Y=$P(IBND,"^",8) D DT^DIQ
  1. 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
  1. I $P(IBND,"^",15)'="" W !," Prior Threshold: " S Y=$P(IBND,"^",15) D DT^DIQ
  1. I $G(DUZ(0))="@" W !," Patient DFN: ",$P(IBND,"^",2),?36,"Ex. Number: ",IBDA
  1. W !
  1. Q
  1. ;
  1. SET ; -- built tmp array ==> ^tmp($j, dfn, -eff date, -date/time added, da)
  1. N X
  1. S X=$G(^IBA(354.1,+IBDA,0)) Q:X=""
  1. S ^TMP($J,DFN,IBIDT,-$P(X,"^",8),IBDA)=X
  1. Q