source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEPS.m@ 1806

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1IBARXEPS ;ALB/RM/PHH,EG - RX COPAY EXEMPTION UPDATE STATUS ; 12/13/2005
2 ;;2.0;INTEGRATED BILLING;**321**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routine was copied/modified from IBARXEPV.
6 ;
7 Q
8POST ; Entry point from TaskMan
9 I '$D(DT) D
10 .N %,%H,%I,X,DT
11 .D NOW^%DTC
12 .S DT=X
13 N NAMESPC
14 S NAMESPC=$$NAMESPC()
15 D UPDT($E(DT,1,3)_"0101",DT,1)
16 K ^XTMP(NAMESPC,"RUNNING")
17 Q
18START ;Entry Point from post-install
19 N QTIME,X,NAMESPC
20 S NAMESPC=$$NAMESPC()
21 Q:$$RUNCHK(NAMESPC) ; Quit if already running or has run to completion
22 K ^XTMP(NAMESPC)
23 S X=$$QTIME(.QTIME)
24 S ^XTMP(NAMESPC,"USER")=$S($G(DUZ)'="":DUZ,1:"UNKNOWN")
25 S:'$$QUEUE(QTIME) ^XTMP(NAMESPC,"RUNNING")=""
26 Q
27NAMESPC() ; API returns the name space for this patch
28 Q "IBARXEPS"
29RUNCHK(NAMESPC) ; Check to see if clean up is already running
30 Q:NAMESPC="" 1 ; Name Space must be defined
31 Q:$D(^XTMP(NAMESPC,"RUNNING")) 1
32 Q 0
33QTIME(WHEN) ; Get the run time for queuing
34 N %,%H,%I,X
35 D NOW^%DTC
36 S WHEN=$P(%,".")_"."_$E($P(%,".",2),1,4)
37 Q 0
38QUEUE(ZTDTH) ; Queue the process
39 N NAMESPC,QUEERR,ZTDESC,ZTRTN,ZTSK
40 S NAMESPC=$$NAMESPC
41 S QUEERR=0
42 S ZTRTN="POST^IBARXEPS"
43 S ZTDESC=NAMESPC_" - RX COPAY EXEMPTION UPDATE STATUS"
44 S ZTIO=""
45 D ^%ZTLOAD
46 K ^XTMP(NAMESPC,"ZTSK")
47 I '$D(ZTSK) S ^XTMP(NAMESPC,"ZTSK")="Unable to queue post-install process.",QUEERR=1
48 I $D(ZTSK) D
49 . S ^XTMP(NAMESPC,"ZTSK")="Post-install queued. Task ID: "_$G(ZTSK)
50 . D MES^XPDUTL(" This request queued as Task # "_ZTSK)
51 . D MES^XPDUTL("")
52 . Q
53 Q QUEERR
54 ;
55UPDT(IBBDT,IBEDT,IBUP) ;
56 ; IBBDT - Beginning Date for the process
57 ; IBEDT - Ending Date for the process
58 ; IBUP - Update mode (1 - Update, 0 - Report only)
59 ;
60 ; All three input parameters are required
61 I 'IBBDT!('IBEDT)!(IBEDT<IBBDT) Q
62 ;
63 ; Entry point to start comparison
64 N IBJOB,IBWHER,%
65 S (IBPCNT,IBPAG)=0,IBOK=1 D NOW^%DTC S Y=% D D^DIQ
66 S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
67 K ^TMP($J,"IBUNVER")
68 ;
69 ; Look through EFFECTIVE DATE x-ref in BILLING EXEMPTIONS File #354.1
70 S IBDT=IBBDT-.00001
71 F S IBDT=$O(^IBA(354.1,"B",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.9)) D
72 .S IBDA=0 F S IBDA=$O(^IBA(354.1,"B",IBDT,IBDA)) Q:'IBDA D
73 ..D CHK I 'IBOK D UP:IBUP,SET
74 D REPORT
75 ;
76 K ^TMP($J,"IBUNVER")
77 K DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
78 K IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
79 Q
80 ;
81CHK ; Check if current status = computed status
82 S IBOK=1,IBMESS="Nothing Updated",IBERR=""
83 S X=$G(^IBA(354.1,+IBDA,0)) G CHKQ:'$P(X,"^",10) ;not active skip
84 S DFN=$P(X,"^",2)
85 S Y=$G(^IBA(354,DFN,0)) I +X<$P(Y,"^",3) G CHKQ ;not current exemption
86 ;
87 N DGMT,CONV,CLN S (CLN,CONV)=0,DGMT=$$LST^DGMTU(DFN,+X,1)
88 I $P(DGMT,U,5)=2 D G:CONV CHKQ ; skip Edb conv. tests
89 .; Loop through the MT comments, Check for EDB converted test
90 .; No comments to check
91 .Q:'$D(^DGMT(408.31,+DGMT,"C",1,0))
92 .F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV) D
93 ..I ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb" S CONV=1
94 ;
95 S IBPCNT=IBPCNT+1
96 I '+Y S IBOK=0,IBERR=4
97 S IBEXREAO=$P(X,"^",5)_"^"_+X ;current exemption
98 I $P($G(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010 G CHKQ ; hardships don't report
99 I +X>$P(Y,"^",3) S IBOK=0,IBERR=1 ;most current exemption not in 354
100 I $P(X,"^",5)'=$P(Y,"^",5) S IBOK=0,IBERR=2 ;Current exemption not in 354
101 I $P(X,"^",4)'=$P(Y,"^",4) S IBOK=0,IBERR=5 ;current status in exemption not in 354
102 S IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
103 I +IBEXREAO'=+IBEXREAN S IBOK=0,IBERR=3
104CHKQ Q
105 ;
106UP ; -- update current exemption status
107 Q:IBOK
108 S IBJOB=15,IBWHER=16
109 I IBERR=4 D G UPQ
110 .S DIE="^IBA(354,",DA=DFN,DR=".01////"_DFN D ^DIE
111 .K DIE,DA,DR,DIC
112 .S IBMESS="Name Corrected"
113UP1 N IBOLDAUT S IBOLDAUT=""
114 ;
115 ; -- if currently not auto exempt make sure not more recent auto exempt
116 I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
117 S IBFORCE=$P(IBEXREAN,"^",2)
118 D MOSTR^IBARXEU5($P(IBEXREAN,"^",2),+IBEXREAN)
119 D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
120 S IBMESS="Updated"
121UPQ K IBFORCE Q
122 ;
123SET ; Set ^tmp node if not okay
124 Q:IBOK
125 S IBP=$$PT^IBEFUNC(DFN)
126 S IBDFN=DFN
127 I $D(^TMP($J,"IBUNVER",$P(IBP,"^"),DFN)) S IBDFN=DFN_"-"_IBPCNT
128 S ^TMP($J,"IBUNVER",$P(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
129 Q
130 ;
131REPORT ; Send MailMan recap report of updated records
132 N IBMGRP,XMDUZ,XMTEXT,XMY,XMSUB,LNCNT,IBPDAT,IBDCNT,MSG,TXT,EXRSN,XMDUZ
133 S IBMGRP=$$GET1^DIQ(350.9,1,.13)
134 Q:IBMGRP=""
135 S IBMGRP=$O(^XMB(3.8,"B",IBMGRP,""))
136 Q:'IBMGRP
137 D XMY^DGMTUTL(IBMGRP,0,1)
138 S XMDUZ="IB PACKAGE",XMTEXT="MSG(",LNCNT=1,IBDCNT=0
139 S XMY(DUZ)="",XMSUB="IB RX COPAY EXEMPT UPDATE"
140 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
141 S MSG(LNCNT)=" Medication Copayment Exemption Problem Report "_IBPDAT
142 S LNCNT=LNCNT+1,MSG(LNCNT)=" "
143 S TXT="Patient PT. ID Error Current/Calc Exemption"
144 S LNCNT=LNCNT+1,MSG(LNCNT)=TXT
145 S LNCNT=LNCNT+1,MSG(LNCNT)=$TR($J(" ",78)," ","-")
146 D EXRSN
147 S IBNAM="" F S IBNAM=$O(^TMP($J,"IBUNVER",IBNAM)) Q:IBNAM="" D
148 .S IBDFN="" F S IBDFN=$O(^TMP($J,"IBUNVER",IBNAM,IBDFN)) Q:IBDFN="" D
149 ..S IBER=^(IBDFN) D MSGLN(IBNAM,IBER)
150 ;
151 I $D(^TMP($J,"IBUNVER")) D
152 .S LNCNT=LNCNT+1,MSG(LNCNT)=" "
153 .S LNCNT=LNCNT+1,MSG(LNCNT)="There were "_IBDCNT_" discrepancies found in "_IBPCNT_" exemptions checked."
154 I '$D(^TMP($J,"IBUNVER")) S LNCNT=LNCNT+1,MSG(LNCNT)=" No discrepancies found in "_IBPCNT_" exemptions checked."
155 D ^XMD
156REPORTQ Q
157 ;
158MSGLN(IBNAM,IBER) ; Create the body of the report
159 N IBSSN,IBCURX,IBCALX,RECORD
160 S IBNAM=$E(IBNAM,1,20),IBDCNT=IBDCNT+1
161 S IBSSN=$P(IBER,U,8)
162 S X=$P(IBER,U,5),X=$E($S(X=3:"Incorr Exmpt",X=1!(X=2)!(X=5):"Not Curr Stat",X=4:"Name Missing",1:"Hmmmm"),1,13)
163 S IBCURX=EXRSN($P(IBER,U))
164 S IBCALX=EXRSN($P(IBER,U,3))
165 S RECORD=$$LJ^XLFSTR(IBNAM,22," ")_IBSSN_" "_$$LJ^XLFSTR(X,15," ")_IBCURX_"/"_IBCALX
166 S LNCNT=LNCNT+1,MSG(LNCNT)=RECORD
167 Q
168 ;
169EXRSN ; Exempt Reason Array for MailMan Message
170 N IBIEN S IBIEN=0
171 F S IBIEN=$O(^IBE(354.2,IBIEN)) Q:'IBIEN S EXRSN(IBIEN)=$E($P(^IBE(354.2,IBIEN,0),U),1,15)
172 Q
173 ;
Note: See TracBrowser for help on using the repository browser.