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

IBARXEX.m

Go to the documentation of this file.
  1. IBARXEX ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION ; 16-NOV-92
  1. ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. % I '$D(DT) D DT^DICRW
  1. D HOME^%ZIS
  1. PAT W @IOF,"Medication Copayment Exemption Update Option",!!
  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. S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQM",DIC("A")="Select BILLING PATIENT: " D ^DIC G:+Y<1 END S DFN=+Y K DIC I $P(Y,"^",3) S IBNEW=""
  1. ;
  1. EN ; -- entry point from alert processing , dfn defined
  1. S IBQUIT=0,IBTALK=1,IBJOB=13
  1. D DISP
  1. D STAT
  1. I $D(IBNEW)!(IBSTATR'=$P(IBPBN,"^",5))!($P(IBSTAT,"^",4)'=$P(IBPBN,"^",4)) D AUTO^IBARXEX1 G PATQ ;ask if autoupdate
  1. I $P(IBSTAT,"^",4)=$P(IBPBN,"^",4) D MANUAL^IBARXEX1 ; ask if want to change
  1. PATQ I 'IBQUIT D:$D(IBCHANGE) DISP,STAT,PAUSE^IBOUTL
  1. ;
  1. D END
  1. G PAT
  1. ;
  1. DISP ; -- single screen display of Pharmacy co-pay income exemption status
  1. S IBP=$$PT^IBEFUNC(DFN),IBPBN=$G(^IBA(354,DFN,0))
  1. D HDR
  1. S IBCNT=0
  1. ;
  1. S IBDT=-(DT+.000001)
  1. F S IBDT=$O(^IBA(354.1,"AIVDT",1,DFN,IBDT)) Q:'IBDT S IBDA=0 F S IBDA=$O(^IBA(354.1,"AIVDT",1,DFN,IBDT,IBDA)) Q:'IBDA D SHOWONE S IBCNT=IBCNT+1
  1. I 'IBCNT W !,"None"
  1. Q
  1. ;
  1. SHOWONE ; -- write display line for one entry
  1. S X=$G(^IBA(354.1,IBDA,0)) Q:X=""
  1. W !,$$DAT1^IBOUTL(+X),?12,$S($P(X,"^",3)=1:"RX COPAY",1:"")
  1. W ?22,$$TEXT^IBARXEU0($P(X,"^",4))
  1. W ?34,$E($P($G(^IBE(354.2,+$P(X,"^",5),0)),"^"),1,22)
  1. W ?56,$S($P(X,"^",6)=1:"SYSTEM",$G(^VA(200,+$P(X,"^",7),0))]"":$E($P(^(0),U),1,14),1:"Unknown"),"/ ",$$DAT1^IBOUTL($P(X,"^",8))
  1. Q
  1. ;
  1. STAT ; -- show current status
  1. S IBSTATR=+$$STATUS^IBARXEU1(DFN,DT)
  1. S IBSTAT=$G(^IBE(354.2,+IBSTATR,0))
  1. ;
  1. W !!,"Medication Copayment Exemption Status Currently computes to: ",$$TEXT^IBARXEU0($P(IBSTAT,"^",4))
  1. W !,$P(IBSTAT,"^",2),!!
  1. Q
  1. ;
  1. SELCY ; -- select calendar year to work with
  1. ;
  1. W !!
  1. S Y=+$$LST^IBARXEU0(DFN) I Y?7N D D^DIQ S DIR("B")=Y
  1. S DIR("?")="Enter the effective date you wish to add a new exemption record for. If the exemption is computed from income data then the effective date will be the date of the income test. It cannot be in the future."
  1. S DIR(0)="DO^"_$$STDATE^IBARXEU_":"_DT,DIR("A")="Select Effective Date" D ^DIR K DIR
  1. I $D(DIRUT)!(Y'?7N) S IBQUIT=1 G SELCYQ
  1. S IBDT=Y
  1. I '$D(^IBA(354.1,"APIDT",DFN,1,-IBDT))&(IBDT'=DT) K IBDT W !!?4,$C(7),"The DATE selected must be the date of an exemption or today!",!?4,"This is the same date as the date of a Means Test or Copay Test.",! G SELCY
  1. SELCYQ Q
  1. ;
  1. ;
  1. HDR W @IOF,"Medication Copayment Income Exemption Status"
  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 !!,"EFFECTIVE TYPE STATUS REASON ADDED BY/ON"
  1. W !,$TR($J(" ",IOM)," ","-")
  1. Q
  1. ;
  1. END K C,I,J,DA,DIC,DIE,DR,DFN,IBACTIVE,IBADDE,IBALERT,IBCHANGE,IBCNT,IBCODA,IBCODP,IBEXDA,IBDA,IBDT,IBEXREA,IBJ,IBJOB,IBNEW,IBP,IBPBN,DIRUT,IBQUIT,IBSTAT,IBSTATR,IBTALK,IBWHER,X,X1,XCNP,XMZ,Y
  1. Q