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

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1IBARXET ;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 ;
5ADD ; -- 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
19ADDQ K DLAYGO,DIC,DIE,DA,DR,X,Y,IBDA,IBTH,IBX
20 Q
21 ;
22PRINT ; -- 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
29PRINTQ K L,FLDS,BY,FR,TO,DHD,DIC
30 Q
31 ;
32PRIOR ; -- 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 ;
51DQ ; -- 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
67PRIORQ 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 ;
71HDR ; -- 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 ;
79SET ; -- 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 ;
85ONE ; -- 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
98ONEQ Q
Note: See TracBrowser for help on using the repository browser.