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

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

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1IBARXEPV ;ALB/AAS - RX COPAY EXEMPTION VERIFY STATUS ; 02/12/2004
2 ;;2.0;INTEGRATED BILLING;**262**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% ; -- print/verify patients whose current exemption does not match
6 ; what is currently computed.
7 I '$D(DT) D DT^DICRW
8 S IBQUIT=0
9 I '$D(IOF) D HOME^%ZIS
10 W @IOF,"Verify Medication Copayment Exemption Status"
11 W !! D DATE^IBOUTL
12 I 'IBBDT!('IBEDT)!(IBEDT<IBBDT) G END
13 ;
14 ; -- update patient status
15 W !
16 S DIR("?")="Answer 'YES' if you want to automatically update patient status to the computed status, or 'NO' to print a report of discrepancies."
17 S DIR(0)="Y",DIR("A")="Update Patient Status",DIR("B")="NO" D ^DIR K DIR S IBUP=+Y
18 I $D(DIRUT) G END
19 W !
20 ;
21DEV W !!,"You will need a 132 column printer for this report!",!
22 S %ZIS="QM" D ^%ZIS G:POP END
23 I $D(IO("Q")) S ZTRTN="DQ^IBARXEPV",ZTSAVE("IB*")="",ZTDESC="IB Verify Medication Copayment exemption" D ^%ZTLOAD K ZTSK,IO("Q") D HOME^%ZIS G END
24 I '$D(ZTQUEUED) W !,"HMMMM, LET ME THINK ABOUT THIS FOR A MINUTE"
25 U IO
26 ;
27DQ ; -- entry point from task man to start comparison
28 S (IBPCNT,IBPAG)=0,IBOK=1 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
29 K ^TMP($J,"IBUNVER")
30 ;
31 ; -- look through inverse date x-ref
32 S IBDT=IBBDT-.00001
33 F S IBDT=$O(^IBA(354.1,"B",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.9)) S IBDA=0 F S IBDA=$O(^IBA(354.1,"B",IBDT,IBDA)) Q:'IBDA D CHK I 'IBOK D UP:IBUP,SET
34 D REPORT,PAUSE^IBOUTL:'IBQUIT
35 G END
36 ;
37END K ^TMP($J,"IBUNVER")
38 I $D(ZTQUEUED) S ZTREQ="@" Q
39 D ^%ZISC
40 K DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
41 K IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
42 Q
43 ;
44REPORT ; -- print report
45 D HDR S IBDCNT=0
46 I '$D(^TMP($J,"IBUNVER")) W !,"No discrepancies found in ",IBPCNT," exemptions checked." G REPORTQ
47 ;
48 S IBNAM=""
49 F S IBNAM=$O(^TMP($J,"IBUNVER",IBNAM)) Q:IBNAM=""!(IBQUIT) S IBDFN="" F S IBDFN=$O(^TMP($J,"IBUNVER",IBNAM,IBDFN)) Q:IBDFN=""!(IBQUIT) S IBER=^(IBDFN) D LINE
50 ;
51 W !!,"There were ",IBDCNT," discrepancies found in ",IBPCNT," exemptions checked."
52 ;
53REPORTQ Q
54 ;
55LINE ; -- write each line
56 S DFN=+IBDFN,IBDCNT=IBDCNT+1
57 I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR
58 W !,$E(IBNAM,1,20),?22,$P(IBER,"^",8)
59 S X=$P(IBER,"^",5) W ?39,$S(X=3:"Exemption incorrect",X=1!(X=2)!(X=5):"Not Current Status",X=4:"Name Missing",1:"Hmmmm")
60 W ?61,$$DAT1^IBOUTL($P(IBER,"^",2))_" "_$E($P($G(^IBE(354.2,+IBER,0)),"^"),1,15)
61 W ?88,$$DAT1^IBOUTL($P(IBER,"^",4))_" "_$E($P($G(^IBE(354.2,+$P(IBER,"^",3),0)),"^"),1,15)
62 W ?115,$P(IBER,"^",6)
63 Q
64 ;
65CHK ; -- check if current status = computed status
66 S IBOK=1,IBMESS="Nothing Updated",IBERR=""
67 S X=$G(^IBA(354.1,+IBDA,0)) G CHKQ:'$P(X,"^",10) ;not active skip
68 S DFN=$P(X,"^",2)
69 S Y=$G(^IBA(354,DFN,0)) I +X<$P(Y,"^",3) G CHKQ ;not current exemption
70 ;
71 N DGMT,CONV,CLN S (CLN,CONV)=0,DGMT=$$LST^DGMTU(DFN,+X,1)
72 I $P(DGMT,U,5)=2 D G:CONV CHKQ ; skip Edb conv. tests
73 .; Loop through the MT comments, Check for EDB converted test
74 .; No comments to check
75 .Q:'$D(^DGMT(408.31,+DGMT,"C",1,0))
76 .F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV) D
77 ..I ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb" S CONV=1
78 ;
79 S IBPCNT=IBPCNT+1
80 I '+Y S IBOK=0,IBERR=4
81 S IBEXREAO=$P(X,"^",5)_"^"_+X ;current exemption
82 I $P($G(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010 G CHKQ ; hardships don't report
83 I +X>$P(Y,"^",3) S IBOK=0,IBERR=1 ;most current exemption not in 354
84 I $P(X,"^",5)'=$P(Y,"^",5) S IBOK=0,IBERR=2 ;Current exemption not in 354
85 I $P(X,"^",4)'=$P(Y,"^",4) S IBOK=0,IBERR=5 ;current status in exemption not in 354
86 S IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
87 I +IBEXREAO'=+IBEXREAN S IBOK=0,IBERR=3
88CHKQ Q
89 ;
90UP ; -- update current exemption status
91 Q:IBOK
92 S IBJOB=15,IBWHER=16
93 I IBERR=4 D G UPQ
94 .S DIE="^IBA(354,",DA=DFN,DR=".01////"_DFN D ^DIE
95 .K DIE,DA,DR,DIC
96 .S IBMESS="Name Corrected"
97UP1 N IBOLDAUT S IBOLDAUT=""
98 ;
99 ; -- if currently not auto exempt make sure not more recent autoexempt
100 I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
101 S IBFORCE=$P(IBEXREAN,"^",2)
102 D MOSTR^IBARXEU5($P(IBEXREAN,"^",2),+IBEXREAN)
103 D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
104 S IBMESS="Updated"
105UPQ K IBFORCE Q
106 ;
107SET ; -- set ^tmp node if not okay
108 Q:IBOK
109 S IBP=$$PT^IBEFUNC(DFN)
110 S IBDFN=DFN
111 I $D(^TMP($J,"IBUNVER",$P(IBP,"^"),DFN)) S IBDFN=DFN_"-"_IBPCNT
112 S ^TMP($J,"IBUNVER",$P(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
113 Q
114 ;
115HDR ; -- print header
116 I IBPAG!($E(IOST,1,2)="C-") W @IOF
117 S IBPAG=IBPAG+1
118 W !,"Medication Copayment Exemption Problem Report",?(IOM-31),IBPDAT," Page ",IBPAG
119 W !,"Patient",?22,"PT. ID",?39,"Error",?61,"Current Exemption",?88,"Computed Exemption",?115,"Action"
120 W !,$TR($J(" ",IOM)," ","-")
121 Q
Note: See TracBrowser for help on using the repository browser.