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

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1IBNCPNB ;OAK/ELZ - UTILITIES FOR NCPCP ;24-JUN-2003
2 ;;2.0;INTEGRATED BILLING;**276,342**;21-MAR-94;Build 18
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;NCPDP PHASE III
6 Q
7 ;
8 ;
9NONBR(DFN,IBRX,IBFIL,IBADT,IBCR,IBPAP,IBRC,IBCC,IBUSER) ; Set non-billable reason to CT
10 ; input:
11 ; DFN - Patient
12 ; IBRX - Rx IEN
13 ; IBFIL - fill#
14 ; IBADT - fill date
15 ; IBCR - Close Claim Reason (#356.8)
16 ; IBPAP - Autobillable flag (billable (1) / non-billable (0) flag)
17 ; IBRC - Release Copay (entered by OPECC)
18 ; IBCC - Close Reason Comment (entered by OPECC)
19 ; IBUSER - DUZ of user triggering the billing event
20 N IBTRKRN,DIE,IBRESN,DR,DA,IBRMARK,IBLOCK,IBEABD,IBEABD,IBACT,IBFDA
21 ; update claims tracking
22 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRX,IBFIL,0))
23 I 'IBTRKRN D ; if it doesn't exist - create it
24 . N IBTRKR
25 . S IBTRKR=$G(^IBE(350.9,1,6)) ; claims tracking info
26 . ; date can't be before parameters
27 . S $P(IBTRKR,U)=$S('$P(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
28 . I 'IBTRKR Q ; CT Disabled
29 . D CT^IBNCPDPU(DFN,IBRX,IBFIL,IBADT,$G(IBCR))
30 . S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRX,IBFIL,0))
31 I 'IBTRKRN Q ; CT disabled
32 L +^IBT(356,IBTRKRN):10 S IBLOCK=$T
33 S DIE="^IBT(356,",DA=IBTRKRN
34 ;
35 ;
36 ; if Billable - set EABD+60
37 I '$G(IBCR) D G NONBRQ
38 .Q:$$GET1^DIQ(356,IBTRKRN_",",.19,"I") ;quit if non-billable
39 .S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
40 .I IBEABD S IBEABD=$$FMADD^XLFDT(IBEABD,60)
41 .S DR=".17////^S X=IBEABD" D ^DIE
42 ;
43 ; if still billable, set the EABD.
44 ;
45 ; Don't check for the 2nd insurance in Phase 3 --
46 ; allow the claim to become non-billable, ECME has already warned
47 ; the user and provided information about the 2nd insurance
48 ; in the User Screen
49 ; I IBPAP!$$MOREINS(DFN,IBADT) D G NONBRQ
50 ;
51 I IBPAP D G NONBRQ
52 . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
53 . I IBEABD<DT S IBEABD=DT
54 . S DR=".19///@" D ^DIE ; it re-sets .17 (trigger in #356)
55 . S DR=".17////^S X=IBEABD"
56 . S IBRMARK=$$REASON^IBNCPDPU(IBCR)
57 . I IBCC'="" S IBRMARK=IBRMARK_"; "_IBCC
58 . I $L($G(IBCC))>2 S DR=DR_";1.08////^S X=$E(IBRMARK,1,80)"
59 . D ^DIE
60 ;
61 ; set non-billable reason
62 S IBRMARK=$$REASON^IBNCPDPU(IBCR)
63 I IBRMARK="" S IBRMARK="OTHER" S IBCC="Unknown NBR '"_IBCR_"'. "_$G(IBCC)
64 S DR=".19///"_IBRMARK
65 I $L($G(IBCC))>2 S DR=DR_";1.08////^S X=$E(IBCC,1,80)"
66 D ^DIE
67 ;
68NONBRQ ;
69 I $G(IBRC) D ; Release Copay
70 . S IBACT=+$$RELCOPAY(DFN,IBRX,IBFIL,1,IBADT,0) ; release copay charges off hold
71 . ;if 0 (not found on HOLD) we will have one more attempt, it was scheduled inside RELCOPAY
72 . ; so doesn't make sense to send "NOT RELEASED" e-mail
73 . ; if the 2nd attempt fails then e-mail will be send from RCTASK
74 . ;we send e-mail only if -1 i.e. if charge was found on hold but
75 . ; ^IBR gave an error when we tried to release it
76 . I IBACT=-1 D RELBUL^IBNCPEB(DFN,IBRX,IBFIL,IBADT,IBACT,IBCR,$G(IBCC),0,1)
77 . ;if -2 (there is no copay) then do nothing
78 S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited
79 S IBFDA(356,IBTRKRN_",",1.04)=IBUSER ; last edited by
80 D FILE^DIE("","IBFDA"),MSG^DIALOG()
81 I IBLOCK L -^IBT(356,IBTRKRN)
82 Q
83 ;
84 ;
85RELCOPAY(DFN,IBRX,IBFIL,IBRETRY,IBADT,IBIFN) ; Release copay charges on hold
86 ; Input:
87 ; DFN - Patient IEN
88 ; IBRX - Rx IEN
89 ; IBFIL - fill/refill #
90 ; IBRETRY - retry flag
91 ; IBADT - fill date
92 ; IBIFN - 3rd party bill IEN
93 ; output:
94 ; -2 == there is no any copay
95 ; -1^error code if unsuccessful == if ^IBR error
96 ; 0 == charge was not found (and depends on IBRETRY another attempt can be scheduled)
97 ; >0 == charge was released from HOLD
98 ; this procedure will be called if the Payer agreed to pay 0.00
99 ; or the claim was closed as non-billable by the OPECC.
100 ; if patient exempt from RX copay then there is nothing to release from HOLD - quit
101 I +$$RXEXMT^IBARXEU0(DFN,IBADT)=1 Q -2
102 N IBACT,IBZ,IBFOUND,IBX,IBSEQNO,IBNOS,Y,IBDUZ,RCDUZ
103 ; Schedule the task to speed up the whole process
104 I 'IBRETRY D RCTASK(DFN,IBRX,IBFIL,+IBRETRY,IBADT,IBIFN) Q 0
105 S IBFOUND=0
106 S IBACT="A" F S IBACT=$O(^IB("AH",DFN,IBACT),-1) Q:'IBACT D Q:IBFOUND
107 . S IBZ=$G(^IB(IBACT,0)) Q:IBZ=""
108 . S IBX=$P(IBZ,U,4)
109 . I +IBX'=52 Q ; not an Rx
110 . I +$P(IBX,":",2)'=IBRX Q ; other Rx
111 . I +$P(IBX,":",3)'=IBFIL Q ; other fill
112 . S IBFOUND=IBACT
113 I 'IBFOUND D RCTASK(DFN,IBRX,IBFIL,+$G(IBRETRY),IBADT,IBIFN) Q 0
114 S IBSEQNO=1,IBNOS=IBFOUND
115 S IBDUZ=$P($G(^IB(IBFOUND,1)),U) ; who entered the copay charge?
116 S RCDUZ=IBDUZ
117 D ^IBR I Y<0 Q Y
118 Q IBFOUND
119 ;
120 ;Called by TaskMan
121RELCRG ;
122 N IBACT
123 S IBACT=+$$RELCOPAY(DFN,IBRX,IBFIL,IBRETRY,IBADT,IBIFN)
124 ;if 0 (not found on HOLD) we will have another attempt
125 ;we send e-mail only if -1 (^IBR error)
126 I IBACT=-1 D RELBUL^IBNCPEB(DFN,IBRX,IBFIL,IBADT,IBACT,0,"",IBIFN,IBRETRY)
127 ;
128 Q
129 ;
130 ;Schedule Release Copay
131RCTASK(DFN,IBRX,IBFIL,IBRETRY,IBADT,IBIFN) ;
132 N I,ZTRTN,ZTSAVE,ZTDESC,ZTDTH,ZTIO
133 S IBRETRY=IBRETRY+1
134 I IBRETRY>2 D Q ; Only two extra attempts
135 . ;if all attempts were unsuccessful then send e-mail, set IBACT=0 since we do not have it
136 . D RELBUL^IBNCPEB(DFN,IBRX,IBFIL,IBADT,0,0,"",IBIFN,2)
137 S ZTRTN="RELCRG^IBNCPNB"
138 F I="DFN","IBRX","IBFIL","IBRETRY","IBADT","IBIFN" S ZTSAVE(I)=""
139 S ZTDESC="RELEASE COPAY RX IEN# "_IBRX
140 S ZTIO=""
141 S ZTDTH=$$HADD^XLFDT($H,0,0,0,$S(IBRETRY=1:10,1:600))
142 D ^%ZTLOAD
143 Q
144 ;
145 ;
146 ; does the pat have >1 billable insur with pharm coverage?
147MOREINS(DFN,IBADT) ;
148 ; DFN - ptr to the patient
149 ; IBADT - the effective date
150 N IBANY,IBX,IBINS,IBT,IBRES,IBCAT
151 S IBRES=0 ; No by default
152 S IBCAT=$O(^IBE(355.31,"B","PHARMACY",0))
153 ; -- look up insurance for patient
154 D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
155 S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D Q:IBRES>1
156 . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D Q:IBRES>1
157 . . N IBPL
158 . . S IBPL=+$P($G(IBINS(IBT,0)),U,18) Q:'IBPL
159 . . I '$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q
160 . . S IBRES=IBRES+1
161 ;
162 Q (IBRES>1)
163 ;
164 ;IBNCPNB
Note: See TracBrowser for help on using the repository browser.