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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1IBNCPDP4 ;DALOI/AAT - HANDLE ECME EVENTS ;20-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 ;
8CLOSE(DFN,IBD) ; Close Claim Event
9 N IBADT,IBTRKR,IBTRKRN,IBRXN,IBFIL,IBEABD,IBRES,IBLOCK,IBDUZ
10 N IBRXTYP,IBCR,DA,DIE,DR,IBUSR
11 S IBDUZ=.5
12 S IBRES=1,IBLOCK=0
13 ;
14 I 'DFN S IBRES="0^No patient" G CLOSEQ
15 S IBADT=+$G(IBD("FILL DATE")) I 'IBADT S IBRES="0^No fill date" G CLOSEQ
16 S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G CLOSEQ
17 S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G CLOSEQ
18 S IBCR=+$G(IBD("CLOSE REASON")) I 'IBCR S IBRES="0^No close reason" G CLOSEQ
19 I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G CLOSEQ
20 S IBD("BCID")=IBD("CLAIMID")_";"_IBADT
21 S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
22 L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
23 ;
24 ; -- claims tracking info
25 S IBTRKR=$G(^IBE(350.9,1,6))
26 ; date can't be before parameters
27 S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
28 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
29 ;
30 I 'IBTRKRN S IBRES="0^CT record not found" G CLOSEQ
31 ;
32 D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,$G(IBD("DROP TO PAPER")),$G(IBD("RELEASE COPAY")),$G(IBD("CLOSE COMMENT")),IBUSR)
33 ;
34 S DIE="^IBT(356,",DA=IBTRKRN
35 ; add ECME #,ECME flag, remove total charges
36 S DR="1.1///"_IBD("CLAIMID")_";1.11///2;.29////@"
37 D ^DIE
38 ;
39 S IBRES=1 ; OK
40CLOSEQ ;
41 D LOG^IBNCPDP2("CLOSE",IBRES)
42 I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
43 Q IBRES
44 ;
45 ;
46RELEASE(DFN,IBD) ;
47 N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKR,IBTRKRN
48 N IBEABD,IBNBR,DA,DIE,DR,IBUSR
49 S IBLOCK=0
50 I 'DFN S IBRES="0^No patient" G RELQ
51 S IBADT=+$G(IBD("FILL DATE")) I 'IBADT S IBRES="0^No fill date" G RELQ
52 S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G RELQ
53 S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RELQ
54 S IBRDT=+$G(IBD("RELEASE DATE"),-1) I 'IBRDT S IBRES="0^No release date" G RELQ
55 I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G RELQ
56 S IBD("BCID")=IBD("CLAIMID")_";"_IBADT
57 S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
58 L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
59 ; -- claims tracking info
60 S IBTRKR=$G(^IBE(350.9,1,6))
61 ; date can't be before parameters
62 S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
63 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
64 I 'IBTRKRN S IBRES="0^No CT record found." G RELQ
65 ;
66 ; Remove NBR from CT and set T+60 (if not billed yet)
67 ; Set ECME flags in CT
68 ;
69 L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
70 S DIE="^IBT(356,",DA=IBTRKRN,DR=""
71 S IBNBR=+$P($G(^IBT(356,IBTRKRN,0)),U,19)
72 ; Clean up "Rx not released"
73 I IBNBR,$P($G(^IBE(356.8,IBNBR,0)),U)="PRESCRIPTION NOT RELEASED" S DR=DR_".19////@;",IBNBR=""
74 ;
75 ; Set EABD if no bill and no NBR
76 I '$P($G(^IBT(356,IBTRKRN,0)),U,11),'IBNBR D
77 . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
78 . S:'IBEABD IBEABD=DT
79 . S IBEABD=$$FMADD^XLFDT(IBEABD,60)
80 . S DR=DR_".17////^S X=IBEABD;"
81 ;
82 ; Set ECME Flags
83 S DR=DR_"1.1////"_IBD("CLAIMID")_";"
84 ; Reject status will not be set here
85 ;
86 D ^DIE
87 S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited
88 S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by
89 D FILE^DIE("","IBFDA"),MSG^DIALOG()
90 I IBLOCK2 L -^IBT(356,IBTRKRN)
91 ;
92 S IBRES=1
93RELQ ;
94 D LOG^IBNCPDP2("RELEASE",IBRES)
95 I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
96 Q IBRES
97 ;
98SUBMIT(DFN,IBD) ;
99 N IBRES,IBLOCK,IBADT,IBRXN,IBFIL,IBRDT,IBNBR,IBFLAG,IBTRKR,IBTRKRN
100 N IBRESP,DA,DIE,DR,IBUSR
101 S IBLOCK=0
102 I 'DFN S IBRES="0^No patient" G SUBQ
103 S IBADT=+$G(IBD("FILL DATE")) I 'IBADT S IBRES="0^No fill date" G SUBQ
104 S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G SUBQ
105 S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G SUBQ
106 S IBRESP=$G(IBD("RESPONSE")) I IBRESP="" S IBRES="0^No response from the payer" G SUBQ
107 S IBRDT=+$G(IBD("RELEASE DATE"),-1)
108 I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G SUBQ
109 S IBD("BCID")=IBD("CLAIMID")_";"_IBADT
110 S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
111 L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
112 ;
113 ; -- claims tracking info
114 S IBTRKR=$G(^IBE(350.9,1,6))
115 ; date can't be before parameters
116 S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
117 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
118 ;
119 ; If the Rx is not released - set NBR in CT
120 I 'IBRDT,'$P($G(^IBT(356,IBTRKRN,0)),U,19) D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"PRESCRIPTION NOT RELEASED","","","",IBUSR)
121 ;
122 ; If the Rx is released - clean up NBR in CT
123 I IBRDT,$P($G(^IBE(356.8,+$P($G(^IBT(356,IBTRKRN,0)),U,19),0)),U)="PRESCRIPTION NOT RELEASED" D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"","","","",IBUSR)
124 ; Set ECME fields in CT
125 S DIE="^IBT(356,",DA=IBTRKRN
126 S IBFLAG=$S(IBRESP["REJECT":1,1:0)
127 S DR="1.1///"_IBD("CLAIMID")_";1.11///"_IBFLAG
128 D ^DIE
129 S IBRES=1
130SUBQ ;
131 D LOG^IBNCPDP2("SUBMIT",IBRES)
132 I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
133 Q IBRES
134 ;
135 ;
136REOPEN(DFN,IBD) ;
137 N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKRN
138 N IBEABD,IBNBR,DA,DIE,DR,IBUSR,IBEABD
139 S (IBLOCK,IBLOCK2)=0
140 I 'DFN S IBRES="0^No patient" G REOPQ
141 S IBADT=+$G(IBD("FILL DATE")) I 'IBADT S IBRES="0^No fill date" G REOPQ
142 S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G REOPQ
143 S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G REOPQ
144 I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G REOPQ
145 S IBRDT=$$RXRLDT^PSOBPSUT(IBRXN,IBFIL) ; release date (if null is returned then Rx is not released)
146 S IBD("BCID")=IBD("CLAIMID")_";"_IBADT
147 S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
148 L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
149 ;
150 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) ;get the claim entry associated with the Rx fill (or refill)
151 L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
152 S DIE="^IBT(356,",DA=IBTRKRN
153 ;
154 I IBRDT D ; if Rx released assign earliest autobill date
155 . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
156 . S:'IBEABD IBEABD=DT
157 . S IBEABD=$$FMADD^XLFDT(IBEABD,60)
158 ;
159 N IBFDA
160 S IBFDA(356,IBTRKRN_",",.19)=$S('IBRDT:$O(^IBE(356.8,"B","PRESCRIPTION NOT RELEASED","")),1:"@") ;non-billable reason
161 D FILE^DIE("","IBFDA"),MSG^DIALOG()
162 K IBFDA
163 S IBFDA(356,IBTRKRN_",",.17)=$S('IBRDT:"@",1:IBEABD) ; earliest autobill date
164 S IBFDA(356,IBTRKRN_",",1.08)="@" ;additional comments
165 S IBFDA(356,IBTRKRN_",",1.11)=0 ; reject flag - reset to "no"
166 S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited
167 S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by
168 D FILE^DIE("","IBFDA"),MSG^DIALOG()
169 ;
170 S IBRES=1
171REOPQ ;
172 D LOG^IBNCPDP2("REOPEN",IBRES)
173 I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
174 I IBLOCK2 L -^IBT(356,IBTRKRN)
175 Q IBRES
176 ;IBNCPDP4
Note: See TracBrowser for help on using the repository browser.