source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR3.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: 7.1 KB
Line 
1IBTRKR3 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK RX FILLS ;13-AUG-93
2 ;;2.0;INTEGRATED BILLING;**13,43,121,160,247,275,260,309,336,312,339,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5% ; -- entry point for nightly background job
6 N IBTSBDT,IBTSEDT
7 S IBTSBDT=$$FMADD^XLFDT(DT,-14)-.1
8 S IBTSEDT=$$FMADD^XLFDT(DT,-7)+.9
9 D EN1
10 Q
11 ;
12EN ; -- entry point to ask date range
13 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
14 N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK,IBMESS
15 S IBTALK=1
16 I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prescription Refills is currently turned off." G ENQ
17 W !!!,"Select the Date Range of Rx Refills to Add to Claims Tracking.",!
18 D DATE^IBOUTL
19 I IBBDT<1!(IBEDT<1) G ENQ
20 S IBTSBDT=IBBDT,IBTSEDT=IBEDT
21 ;
22 ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Date ;IB*2.0*312
23 I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D G EN
24 .W !!,"The Begin OR End Date CANNOT be on or after"
25 .W !,"the PFSS Effective Date: ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
26 ;
27 ; -- check selected dates
28 S IBTRKR=$G(^IBE(350.9,1,6))
29 ; start date can't be before parameters
30 I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
31 ; -- end date into future
32 I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
33 ;
34 W !!!,"I'm going to automatically queue this off and send you a"
35 W !,"mail message when complete.",!
36 S ZTIO="",ZTRTN="EN1^IBTRKR3",ZTSAVE("IB*")="",ZTDESC="IB - Add Rx Refills to Claims Tracking"
37 D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued"
38ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
39 D HOME^%ZIS
40 Q
41 ;
42EN1 ; -- add rx refills to claims tracking file
43 N I,J,X,Y,IBTRKR,IBDT,IBRXN,IBFILL,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,LIST1
44 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
45 N IBICD,IBCOPAY
46 ;
47 ; -- check parameters
48 S IBTRKR=$G(^IBE(350.9,1,6))
49 G:'$P(IBTRKR,"^",4) EN1Q ; quit if rx tracking off
50 I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters
51 ;
52 ; -- users can queue into future, make sure dates not after date run
53 I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3)
54 ;
55 S IBRXTYP=$O(^IBE(356.6,"AC",4,0)) ; event type pointer for rx billing
56 ;
57 ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
58 S (IBCNT,IBCNT1,IBCNT2)=0
59 S IBDT=IBTSBDT-.0001
60 S LIST1="IBTRKAD"
61 D REF^PSO52EX(IBDT,IBTSEDT,LIST1)
62 S IBDT=0
63 F S IBDT=$O(^TMP($J,LIST1,"AD",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D
64 .S IBRXN=0
65 .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q
66 .F S IBRXN=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN)) Q:'IBRXN D
67 ..S IBFILL=""
68 ..F S IBFILL=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN,IBFILL)) Q:IBFILL="" D RXCHK
69 K ^TMP($J,LIST1)
70 ;
71 I $G(IBTALK) D BULL^IBTRKR31
72EN1Q I $D(ZTQUEUED) S ZTREQ="@"
73 Q
74 ;
75RXCHK ; -- check and add rx
76 N IBND,LIST,NODE
77 S IBCNT=IBCNT+1
78 ;I IBFILL<1 G RXCHKQ ; original fill
79 I IBDT>(DT+.24) G RXCHKQ ; future fill
80 I '$D(ZTQUEUED),($G(IBTALK)) W "."
81 ;
82 S DFN=$$FILE^IBRXUTL(IBRXN,2)
83 S IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN),IBRXSTAT=$$FILE^IBRXUTL(IBRXN,100,"I")
84 ;I IBDT=$P($O(^DPT(DFN,"S",(IBDT-.00001))),".") G RXCHKQ ;scheduled appointment on same day as fill date
85 ;I $$BABCSC^IBEFUNC(DFN,$P(IBDT,".",1)) G RXCHKQ ; is billable clinic stop in encounter file for data (allows telephone stops on same day, but not others) (P121 - RC, can now bill Rx if on same day as opt visit)
86 ;
87 ; -- not already in claims tracking
88 I $O(^IBT(356,"ARXFL",IBRXN,IBFILL,"")) G RXCHKQ ; already in claims tracking
89 ;
90 ; -- see if tracking only insured and pt is insured
91 I $P(IBTRKR,"^",4)=1,'$$INSURED^IBCNS1(DFN,IBDT) G RXCHKQ ; patient not insure
92 ;
93 ; -- check rx status (not deleted)
94 I IBRXSTAT=13 G RXCHKQ
95 ;
96 ; -- Don't PROCESS IF there is already a PFSS ACCT REF# -- ;IB*2.0*312
97 I 'IBFILL,+$$FILE^IBRXUTL(IBRXN,125) G RXCHKQ
98 I +IBFILL,+$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,21) G RXCHKQ
99 ;
100 ; -- original fill not released or returned to stock
101 I 'IBFILL,'$$FILE^IBRXUTL(IBRXN,31) G RXCHKQ
102 I 'IBFILL,$$FILE^IBRXUTL(IBRXN,32.1) G RXCHKQ
103 ;
104 ; -- refill not released or returned to stock
105 I +IBFILL,'$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,17) G RXCHKQ
106 I +IBFILL,$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,14) G RXCHKQ
107 ;
108 ; -- check drug (not investigational, supply, or over the counter drug
109 S IBDRUG=$P(IBRXDATA,"^",6)
110 D ZERO^IBRXUTL(IBDRUG)
111 S IBDEA=$G(^TMP($J,"IBDRUG",+IBDRUG,3))
112 K ^TMP($J,"IBDRUG")
113 I IBDEA["I"!(IBDEA["S")!(IBDEA["9") G RXCHKQ ; investigational drug, supply or otc
114 ;
115 ; -- see if insured for prescriptions
116 I '$$PTCOV^IBCNSU3(DFN,IBDT,"PHARMACY",.IBANY) S IBRMARK=$S($G(IBANY):"SERVICE NOT COVERED",1:"NOT INSURED")
117 ;
118 ; -- check sc status and others
119 ; -- new ICD node in PSO with CIDC, if it exists use this for determination
120 S LIST="IBTRKRLST"
121 S NODE="ICD"
122 S IBICD=0,IBCOPAY=0
123 D RX^PSO52API(DFN,LIST,IBRXN,,NODE,,)
124 I +$G(^TMP($J,LIST,DFN,IBRXN,"ICD",0))>0 S IBICD=1 ;Setup ICD Flag
125 I +$$IBND^IBRXUTL(DFN,IBRXN)>0 S IBCOPAY=1 ;Setup Copay Flag
126 I $G(IBRMARK)="",IBICD D CL^SDCO21(DFN,IBDT,"",.IBARR) I $D(IBARR) D
127 .S IBM=0
128 .F S IBM=$O(^TMP($J,LIST,DFN,IBRXN,"ICD",IBM)) Q:'IBM!($G(IBRMARK)'="") D
129 ..S IBZ=$$ICD^IBRXUTL1(DFN,IBRXN,IBM,LIST) F IBP=1:1:7 Q:$G(IBRMARK)'="" I $D(IBARR(IBP)) D
130 ... S IBRMARK=$S($P(IBZ,"^",IBP+1):$P($T(EXEMPT+IBP),";",3),$P(IBZ,"^",IBP+1)=0:"",1:"NEEDS SC DETERMINATION")
131 ;
132 ; -- no new ICD node in PSO, use old method of determining status
133 I $G(IBRMARK)="",'IBICD D
134 . D ELIG^VADPT
135 . ;if the patient is covered by insurance for pharmacy ($G(IBRMARK)="")
136 . ;AND if no copay in #350
137 . ;then we need to determine the non billable reason and set IBRMARK
138 . ;
139 . ;IF VAEL(3) -- if this is a veteran with SC(service connection) status
140 . I VAEL(3),'IBCOPAY D
141 . . I $P(VAEL(3),"^",2)>49 S IBRMARK="NEEDS SC DETERMINATION"
142 . . ;in case of POW and Unempl.vet we cannot decide if the 3rd party should be exempt
143 . . N IBPOWUNV,IBAUTRET S IBAUTRET=$$AUTOINFO^DGMTCOU1(DFN),IBPOWUNV=$S($P(IBAUTRET,U,8):1,$P(IBAUTRET,U,9):1,1:0)
144 . . I $P(VAEL(3),"^",2)<50 S IBRMARK=$S(IBPOWUNV:"NEEDS SC DETERMINATION",1:"SC TREATMENT")
145 . . I $$RXST^IBARXEU(DFN,$P(IBRXDATA,U,13))>0 S IBRMARK="NEEDS SC DETERMINATION"
146 . ;
147 . ;IF +VAEL(3)=0 if the veteran doesn't have SC status, but
148 . ;the veteran still may have CV status active
149 . I $G(IBRMARK)="",+VAEL(3)=0,'IBCOPAY D
150 . . I $$CVEDT^IBACV(DFN,IBDT) S IBRMARK="NEEDS SC DETERMINATION" ;SC-because IB staff usually is using this reason to search for cases that need to be reviewed. COMBAT VETERAN reason will be used after review if this was a case
151 K ^TMP($J,LIST)
152 ;
153 ;
154 ; -- ok to add to tracking module
155 D REFILL^IBTUTL1(DFN,IBRXTYP,IBDT,IBRXN,IBFILL,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
156 I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
157 I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
158 K IBANY,IBRMARK,VAEL,VA,IBDEA,IBDRUG,IBRXSTAT,IBRXDATA,DFN,X,Y
159 K IBARR,IBM,IBZ,IBP
160RXCHKQ Q
161 ;
162EXEMPT ; exemption reasons
163 ;;AGENT ORANGE
164 ;;IONIZING RADIATION
165 ;;SC TREATMENT
166 ;;SOUTHWEST ASIA
167 ;;MILITARY SEXUAL TRAUMA
168 ;;HEAD/NECK CANCER
169 ;;COMBAT VETERAN
170 ;;PROJECT 112/SHAD
171 ;;
Note: See TracBrowser for help on using the repository browser.