source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEX.m@ 1464

Last change on this file since 1464 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1IBARXEX ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION ; 16-NOV-92
2 ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% I '$D(DT) D DT^DICRW
6 D HOME^%ZIS
7PAT W @IOF,"Medication Copayment Exemption Update Option",!!
8 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)"
9 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
10 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=""
11 ;
12EN ; -- entry point from alert processing , dfn defined
13 S IBQUIT=0,IBTALK=1,IBJOB=13
14 D DISP
15 D STAT
16 I $D(IBNEW)!(IBSTATR'=$P(IBPBN,"^",5))!($P(IBSTAT,"^",4)'=$P(IBPBN,"^",4)) D AUTO^IBARXEX1 G PATQ ;ask if autoupdate
17 I $P(IBSTAT,"^",4)=$P(IBPBN,"^",4) D MANUAL^IBARXEX1 ; ask if want to change
18PATQ I 'IBQUIT D:$D(IBCHANGE) DISP,STAT,PAUSE^IBOUTL
19 ;
20 D END
21 G PAT
22 ;
23DISP ; -- single screen display of Pharmacy co-pay income exemption status
24 S IBP=$$PT^IBEFUNC(DFN),IBPBN=$G(^IBA(354,DFN,0))
25 D HDR
26 S IBCNT=0
27 ;
28 S IBDT=-(DT+.000001)
29 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
30 I 'IBCNT W !,"None"
31 Q
32 ;
33SHOWONE ; -- write display line for one entry
34 S X=$G(^IBA(354.1,IBDA,0)) Q:X=""
35 W !,$$DAT1^IBOUTL(+X),?12,$S($P(X,"^",3)=1:"RX COPAY",1:"")
36 W ?22,$$TEXT^IBARXEU0($P(X,"^",4))
37 W ?34,$E($P($G(^IBE(354.2,+$P(X,"^",5),0)),"^"),1,22)
38 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))
39 Q
40 ;
41STAT ; -- show current status
42 S IBSTATR=+$$STATUS^IBARXEU1(DFN,DT)
43 S IBSTAT=$G(^IBE(354.2,+IBSTATR,0))
44 ;
45 W !!,"Medication Copayment Exemption Status Currently computes to: ",$$TEXT^IBARXEU0($P(IBSTAT,"^",4))
46 W !,$P(IBSTAT,"^",2),!!
47 Q
48 ;
49SELCY ; -- select calendar year to work with
50 ;
51 W !!
52 S Y=+$$LST^IBARXEU0(DFN) I Y?7N D D^DIQ S DIR("B")=Y
53 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."
54 S DIR(0)="DO^"_$$STDATE^IBARXEU_":"_DT,DIR("A")="Select Effective Date" D ^DIR K DIR
55 I $D(DIRUT)!(Y'?7N) S IBQUIT=1 G SELCYQ
56 S IBDT=Y
57 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
58SELCYQ Q
59 ;
60 ;
61HDR W @IOF,"Medication Copayment Income Exemption Status"
62 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))
63 W !!,"EFFECTIVE TYPE STATUS REASON ADDED BY/ON"
64 W !,$TR($J(" ",IOM)," ","-")
65 Q
66 ;
67END 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
68 Q
Note: See TracBrowser for help on using the repository browser.