| [613] | 1 | IBARXET ;ALB/AAS - RX COPAY EXEMPTION THRESHOLD ENTER/LIST ; 20-JAN-93
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**26,74**; 21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ADD ; -- add/edit new thresholds
|
|---|
| 6 | S IBTH=""
|
|---|
| 7 | S DIC="^IBE(354.3,",DIC(0)="AEQLMN",DLAYGO=354.3,DIC("DR")="" D ^DIC G ADDQ:Y<1
|
|---|
| 8 | S DA=+Y,DIE="^IBE(354.3,",DR="[IB ENTER THRESHOLD]" D ^DIE
|
|---|
| 9 | ;I $D(DA) S IBX=$G(^IBE(354.3,DA,0)),$P(IBX,"^",2)=2 D
|
|---|
| 10 | I $D(DA) S IBX=$G(^IBE(354.3,DA,0)),$P(IBX,"^",2)=$S($E($P(IBX,"^",1),1,5)<29612:2,1:1) D
|
|---|
| 11 | .I $P(IBX,"^",3)'="",$P(IBX,"^",4)'="",$P(IBX,"^",12)'="" Q
|
|---|
| 12 | .S DIK="^IBE(354.3," D ^DIK
|
|---|
| 13 | .W !!,"Entry Deleted, not enough information."
|
|---|
| 14 | .K DA,DIK
|
|---|
| 15 | .Q
|
|---|
| 16 | ;
|
|---|
| 17 | D:$D(DA)#2 PRIOR
|
|---|
| 18 | W ! G ADD
|
|---|
| 19 | ADDQ K DLAYGO,DIC,DIE,DA,DR,X,Y,IBDA,IBTH,IBX
|
|---|
| 20 | Q
|
|---|
| 21 | ;
|
|---|
| 22 | PRINT ; -- print threshold list
|
|---|
| 23 | I '$D(IOF) D HOME^%ZIS
|
|---|
| 24 | W @IOF,?15,"Print Medication Copayment Income Thresholds",!!!
|
|---|
| 25 | W !!,"You will need a 132 column printer for this report!",!
|
|---|
| 26 | S DIC="^IBE(354.3,",L=0,FLDS="[IB PRINT THRESHOLD]",BY="[IB PRINT THRESHOLD]",FR="?,?",TO="?,?"
|
|---|
| 27 | S DHD="Medication Copayment Income Thresholds"
|
|---|
| 28 | D EN1^DIP
|
|---|
| 29 | PRINTQ K L,FLDS,BY,FR,TO,DHD,DIC
|
|---|
| 30 | Q
|
|---|
| 31 | ;
|
|---|
| 32 | PRIOR ; -- check to see if prior year thresholds used
|
|---|
| 33 | S IBPR=$G(^IBE(354.3,+DA,0)) I IBPR="" G PRIORQ
|
|---|
| 34 | ;I $P(IBPR,"^",2)'=2 G PRIORQ
|
|---|
| 35 | S X=$S($P(IBPR,"^",2)=2:1,$P(IBPR,"^",2)=1:1,1:"") G:X="" PRIORQ
|
|---|
| 36 | ;S IBPRDT=$O(^IBE(354.3,"AIVDT",2,-($P(IBPR,"^")))) ;threshold prior to the one entered
|
|---|
| 37 | S X=$S($E($P(IBPR,"^"),1,5)'<29712:1,1:2) S IBPRDT=$O(^IBE(354.3,"AIVDT",X,-($P(IBPR,"^")))) ;threshold prior to the one entered
|
|---|
| 38 | I IBPRDT<0 S IBPRDT=-IBPRDT ; minus a negative to make positive
|
|---|
| 39 | G:IBPRDT="" PRIORQ I '$D(^IBA(354.1,"APRIOR",IBPRDT)) G PRIORQ
|
|---|
| 40 | ;
|
|---|
| 41 | ; -- is exemptions based on prior thresholds
|
|---|
| 42 | W !!,"There are Medication Copayment Exemptions based on prior thresholds",!
|
|---|
| 43 | S DIR("?")="There are exemptions that were based on the threshold values over a year old. You can ignore this, print a list of patients with old exemptions, or automatically update while printing the same list"
|
|---|
| 44 | S DIR(0)="S^1:IGNORE;2:PRINT;3:UPDATE AND PRINT",DIR("A")="Select ACTION",DIR("B")="IGNORE" D ^DIR K DIR I $D(DIRUT)!(Y<2)!(Y>3) G PRIORQ
|
|---|
| 45 | S IBACT=Y
|
|---|
| 46 | ;
|
|---|
| 47 | S %ZIS="QM" D ^%ZIS G:POP PRIORQ
|
|---|
| 48 | I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^IBARXET",ZTDESC="IB PRIOR YEAR THRESHOLD PRINT"_$S(IBACT=3:" AND UPDATE",1:""),ZTSAVE("IB*")="" D ^%ZTLOAD K ZTSK D HOME^%ZIS G PRIORQ
|
|---|
| 49 | U IO
|
|---|
| 50 | ;
|
|---|
| 51 | DQ ; -- entry point from tasking
|
|---|
| 52 | S (IBQUIT,IBPAG)=0 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=Y
|
|---|
| 53 | K ^TMP($J,"IBPRIOR") S IBJOB=17
|
|---|
| 54 | D HDR
|
|---|
| 55 | S IBEX=""
|
|---|
| 56 | F S IBEX=$O(^IBA(354.1,"APRIOR",IBPRDT,IBEX)) Q:IBEX="" D SET
|
|---|
| 57 | ;
|
|---|
| 58 | S IBNAM=""
|
|---|
| 59 | F S IBNAM=$O(^TMP($J,"IBPRIOR",IBNAM)) Q:IBNAM=""!IBQUIT D
|
|---|
| 60 | .S DFN="" F S DFN=$O(^TMP($J,"IBPRIOR",IBNAM,DFN)) Q:DFN=""!IBQUIT D
|
|---|
| 61 | ..S IBXXX=0 F S IBXXX=$O(^TMP($J,"IBPRIOR",IBNAM,DFN,IBXXX)) Q:'IBXXX!IBQUIT S IBP=^(IBXXX) D ONE
|
|---|
| 62 | ;
|
|---|
| 63 | I 'IBQUIT D PAUSE^IBOUTL
|
|---|
| 64 | K ^TMP($J,"IBPRIOR")
|
|---|
| 65 | I $D(ZTQUEUED) S ZTREQ="@" Q
|
|---|
| 66 | D ^%ZISC
|
|---|
| 67 | PRIORQ K X,Y,DFN,DIR,DIRUT,IBACT,IBPR,IBPRDT,IBQUIT,IBPAG,IBPDAT,IBPRIOR
|
|---|
| 68 | K IBEX,IBNAM,IBND,IBP,IBEXREA,IBJOB,IBQUIT,IBXXX,IBWHER,IBEXERR,IBADDE,IBADD,IBCODA,IBCODP
|
|---|
| 69 | Q
|
|---|
| 70 | ;
|
|---|
| 71 | HDR ; -- print prior threshold header
|
|---|
| 72 | I IBPAG!($E(IOST,1,2)="C-") W @IOF,*13
|
|---|
| 73 | S IBPAG=IBPAG+1
|
|---|
| 74 | W "Exemptions Based on Prior Year Thresholds",?(IOM-35),$P(IBPDAT,"@")," @ ",$P(IBPDAT,"@",2)," Page ",IBPAG
|
|---|
| 75 | W !,"Patient",?22,"PT. ID",?36,"Exemption Date",?52,"Status" W:IBACT=3 ?63,"Action"
|
|---|
| 76 | W !,$TR($J(" ",IOM)," ","-")
|
|---|
| 77 | Q
|
|---|
| 78 | ;
|
|---|
| 79 | SET ; -- set up sortable array by patient
|
|---|
| 80 | S IBND=$G(^IBA(354.1,IBEX,0)) Q:IBND=""
|
|---|
| 81 | S DFN=$P(IBND,"^",2),IBP=$$PT^IBEFUNC(DFN)
|
|---|
| 82 | S ^TMP($J,"IBPRIOR",$P(IBP,"^"),DFN,IBEX)=IBEX_"^"_IBP
|
|---|
| 83 | Q
|
|---|
| 84 | ;
|
|---|
| 85 | ONE ; -- print line for one patient
|
|---|
| 86 | S IBEX=+IBP,IBP=$P(IBP,"^",2,5)
|
|---|
| 87 | I $Y>(IOSL-5) D PAUSE^IBOUTL G:IBQUIT ONEQ D HDR
|
|---|
| 88 | S IBND=$G(^IBA(354.1,IBEX,0)) G ONEQ:IBND=""
|
|---|
| 89 | S Y=+IBND D D^DIQ
|
|---|
| 90 | W !,$E(IBNAM,1,20),?22,$P(IBP,"^",2),?36,Y,?52,$$TEXT^IBARXEU0($P(IBND,"^",4))
|
|---|
| 91 | ;
|
|---|
| 92 | ; -- compute exempt, add if different, else delete prior
|
|---|
| 93 | G:IBACT'=3 ONEQ
|
|---|
| 94 | S IBEXREA=$$STATUS^IBARXEU1(DFN,+IBND)
|
|---|
| 95 | I +IBEXREA'=$P(IBND,"^",5) D ADDEX^IBAUTL6(+IBEXREA,+IBND,1,1) W ?63,"Exemption updated"
|
|---|
| 96 | I +IBEXREA=$P(IBND,"^",5) S DA=IBEX,DIE="^IBA(354.1,",DR=".15///@" D ^DIE W ?63,"No Change"
|
|---|
| 97 | K DIE,DA,DR,DIC
|
|---|
| 98 | ONEQ Q
|
|---|
