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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89
2 ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361,371,377**;21-MAR-94;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;MAP TO DGCRBB
6 ;
7 ;IBNDn = IBND(n) = ^ib(399,n)
8 ;RETURNS:
9 ;IBER=fields with errors separated by semi-colons
10 ;PRCASV("OKAY")=1 if iber="" and $D(prcasv("array")) compete
11 ;
12GVAR ;set up variables for mccr
13 Q:'$D(IBIFN) F I=0,"M","U","U1","S","MP","TX","UF3","UF31","U2" S @("IBND"_I)=$G(^DGCR(399,IBIFN,I))
14 S IBBNO=$P(IBND0,"^"),DFN=$P(IBND0,"^",2),IBEVDT=$P(IBND0,"^",3)
15 S IBLOC=$P(IBND0,"^",4),IBCL=$P(IBND0,"^",5),IBTF=$P(IBND0,"^",6)
16 S IBAT=$P(IBND0,"^",7),IBWHO=$P(IBND0,"^",11),IBST=$P(IBND0,"^",13),IBFT=$P(IBND0,"^",19)
17 S IBFDT=$P(IBNDU,"^",1),IBTDT=$P(IBNDU,"^",2)
18 S IBTC=$P(IBNDU1,"^",1),IBFY=$P(IBNDU1,"^",9),IBFYC=$P(IBNDU1,"^",10)
19 S IBEU=$P(IBNDS,"^",2),IBRU=$P(IBNDS,"^",5),IBAU=$P(IBNDS,"^",8)
20 S IBTOB=$$TOB(IBND0),IBTOB12=$E(IBTOB,1,2)
21 K ^TMP($J,"BILL-WARN")
22 Q
23 ;
24EN ;Entry to check for errors
25 N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBFOR,IBC
26 I $D(IBFL) N IBFL
27 K ^TMP($J)
28 W !
29 S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q
30 ;
31 ;patient in patient file
32 I DFN="" S IBER=IBER_"IB057;"
33 I DFN]"",'$D(^DPT(DFN)) S IBER=IBER_"IB057;"
34 ;
35 ;Event date in correct format
36 I IBEVDT="" S IBER=IBER_"IB049;"
37 I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) S IBER=IBER_"IB049;"
38 ;
39 ;Rate Type
40 I IBAT="" S IBER=IBER_"IB059;"
41 I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;"
42 I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT=""
43 I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3)
44 ;Check that AR category expects same debtor as defined in who's responsible.
45 I $D(IBARTP),IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N")) S IBER=IBER_"IB058;"
46 ;
47 ;Who's Responsible
48 I IBWHO=""!($L(IBWHO)>1)!("iop"'[IBWHO) S IBER=IBER_"IB065;"
49 S IBMRA=$S($$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)):$$TXMT^IBCEF4(IBIFN)>0,1:0)
50 ; MCR will not reimburse is only valid if there is subsequent insurance
51 ; that will reimburse
52 I IBWHO="i" D
53 . I IBMRA D Q
54 .. N Z,IBZ
55 .. S IBZ=0
56 .. F Z=$$COBN^IBCEF(IBIFN):1:3 I $D(^DGCR(399,IBIFN,"I"_(Z+1))),$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"I"_(Z+1))),0)),U,2)'="N" S IBZ=1 Q
57 .. I 'IBZ S IBER=IBER_"IB054;" D WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse")
58 ..
59 . I $$COB^IBCEF(IBIFN)="S",$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1,$D(^DGCR(399,IBIFN,"I3")) Q
60 . I $S('IBNDMP:1,1:$P(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1)) S IBER=IBER_"IB054;"
61 I IBWHO="o",'$P(IBNDM,"^",11) S IBER=IBER_"IB053;"
62 ;
63 ; All insurance subscribers must have a birth date on file
64 ; - 11/10/04 - IB*2.0*288
65 ; - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too
66 ; IB error codes
67 ; IB221 - Primary insurance subscriber missing date of birth
68 ; IB222 - Secondary insurance subscriber missing date of birth
69 ; IB223 - Tertiary insurance subscriber missing date of birth
70 ; IB261 - Primary insurance subscriber is missing INSURED'S SEX
71 ; IB262 - Secondary insurance subscriber is missing INSURED'S SEX
72 ; IB263 - Tertiary insurance subscriber is missing INSURED'S SEX
73 ;
74 F IBISEQ=1:1:3 D
75 . I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q ; no insurance here
76 . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
77 . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ)
78 . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
79 . ;
80 . I '$P(IDDATA,U,1) D ERR(221) ; birth date missing
81 . ;
82 . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ERR(261) ; sex missing
83 . ;
84 . ; IB*2*371 - esg - check for other missing insurance pieces
85 . ; check insured's name, primary ID#, pt. relationship to insured,
86 . ; and subscriber address data
87 . N INNAME,SUBID,PTREL,SFA,CAS,LN,FN
88 . ;
89 . ; IB273 - Primary Insurance name of insured missing
90 . ; IB274 - Secondary Insurance name of insured missing
91 . ; IB275 - Tertiary Insurance name of insured missing
92 . S INNAME=$$POLICY^IBCEF(IBIFN,17,IBISEQ)
93 . S LN=$P(INNAME,",",1),FN=$P(INNAME,",",2) ; last name,first name
94 . S LN=$$NOPUNCT^IBCEF(LN,1)
95 . S FN=$$NOPUNCT^IBCEF(FN,1)
96 . I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid
97 . S LN=$$NAME^IBCEFG1(INNAME) ; additional name checks
98 . S FN=$P(LN,U,2)
99 . S LN=$P(LN,U,1)
100 . I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid
101 . ;
102 . ; IB276 - Primary Insurance subscriber ID missing
103 . ; IB277 - Secondary Insurance subscriber ID missing
104 . ; IB278 - Tertiary Insurance subscriber ID missing
105 . S SUBID=$$NOPUNCT^IBCEF($$POLICY^IBCEF(IBIFN,2,IBISEQ),1)
106 . I SUBID="" D ERR(276) ; subscriber ID# missing
107 . ;
108 . ; IB279 - Primary Insurance missing pt relationship
109 . ; IB280 - Secondary Insurance missing pt relationship
110 . ; IB281 - Tertiary Insurance missing pt relationship
111 . S PTREL=$$POLICY^IBCEF(IBIFN,16,IBISEQ)
112 . I PTREL="" D ERR(279) ; missing patient relationship to insured
113 . ;
114 . ; subscriber address section
115 . S SFA=$$INSADDR^IBCEF(IBIFN,IBISEQ) ; full address all pieces
116 . S CAS=$$NOPUNCT^IBCEF($P(SFA,U,2,5),1) ; string city,st,zip,addr1
117 . ;
118 . ; IB282 - Primary Insurance address line 1 missing
119 . ; IB283 - Secondary Insurance address line 1 missing
120 . ; IB284 - Tertiary Insurance address line 1 missing
121 . I $$NOPUNCT^IBCEF($P(SFA,U,5),1)="" D ; address line 1 is blank
122 .. ; pat=subscriber and current insurance - address is required
123 .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(282) Q
124 .. ; if any part of the address is there, then all fields are required
125 .. I CAS'="" D ERR(282) Q
126 .. Q
127 . ;
128 . ; IB285 - Primary Insurance city missing
129 . ; IB286 - Secondary Insurance city missing
130 . ; IB287 - Tertiary Insurance city missing
131 . I $$NOPUNCT^IBCEF($P(SFA,U,2),1)="" D ; city is blank
132 .. ; pat=subscriber and current insurance - address is required
133 .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(285) Q
134 .. ; if any part of the address is there, then all fields are required
135 .. I CAS'="" D ERR(285) Q
136 .. Q
137 . ;
138 . ; IB288 - Primary Insurance state missing
139 . ; IB289 - Secondary Insurance state missing
140 . ; IB290 - Tertiary Insurance state missing
141 . I $$NOPUNCT^IBCEF($P(SFA,U,3),1)="" D ; state is blank
142 .. ; pat=subscriber and current insurance - address is required
143 .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(288) Q
144 .. ; if any part of the address is there, then all fields are required
145 .. I CAS'="" D ERR(288) Q
146 .. Q
147 . ;
148 . ; IB291 - Primary Insurance zipcode missing
149 . ; IB292 - Secondary Insurance zipcode missing
150 . ; IB293 - Tertiary Insurance zipcode missing
151 . I $$NOPUNCT^IBCEF($P(SFA,U,4),1)="" D ; zipcode is blank
152 .. ; pat=subscriber and current insurance - address is required
153 .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(291) Q
154 .. ; if any part of the address is there, then all fields are required
155 .. I CAS'="" D ERR(291) Q
156 .. Q
157 . ;
158 . Q
159 ;
160 ; esg - IB*2*371 - check patient address fields
161 K ^UTILITY("VAPA",$J)
162 ;
163 S IBFOR=0 ; foreign address flag
164 S IBC=+$$PTADDR^IBCEF(IBIFN,25) ; country code ien
165 I IBC D
166 . N CODE
167 . S CODE=$$GET1^DIQ(779.004,IBC,.01) ; .01 code field file 779.004
168 . I CODE'="",CODE'="USA" S IBFOR=1 ; foreign country exists
169 . Q
170 ;
171 I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,1),1)="" S IBER=IBER_"IB269;"
172 I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,4),1)="" S IBER=IBER_"IB270;"
173 I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,5),1)="",'IBFOR S IBER=IBER_"IB271;"
174 I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,11),1)="",'IBFOR S IBER=IBER_"IB272;"
175 K ^UTILITY("VAPA",$J)
176 ;
177 D PAYERADD^IBCBB0(IBIFN) ; check the payer addresses
178 ;
179 ; esg - 9/20/07 - IB patch 371 - prevent EDI transmission for 3 payer
180 ; claims for all but the first payer. To be removed when Emdeon
181 ; and FSC are able to deal with these.
182 ;
183 I +$G(^DGCR(399,IBIFN,"I2")),+$G(^DGCR(399,IBIFN,"I3")),$$TXMT^IBCEF4(IBIFN) D
184 . ; for MRA request claims, make sure the MRA secondary claim is forced to print
185 . I $$REQMRA^IBEFUNC(IBIFN) D Q
186 .. I '$P($G(^DGCR(399,IBIFN,"TX")),U,9) S IBER=IBER_"IB146;"
187 .. Q
188 . ;
189 . I $$COBN^IBCEF(IBIFN)=1 Q ; primary payer sequence claims are OK
190 . ;
191 . ; But claims with a payer sequence of 2 or 3 need to print locally
192 . S IBER=IBER_"IB147;"
193 . Q
194 ;
195 D ^IBCBB1
196 Q
197 ;
198EDIT(IBIFN) ; Run edits from within the billing edit screens
199 N IBVIEW,IBDISP,IBNOFIX,DIR,X,Y
200 S (IBNOFIX,IBVIEW,IBDISP)=1
201 D EDITS^IBCB2
202 W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
203 Q
204 ;
205TOB(IBND0) ;
206 ; IBND0 = the 0-node of the bill (file 399)
207 Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26))
208 ;
209ERR(Z) ; update IBER variable from the above insurance checks
210 ; Z is the IB error code# for the primary insurance error
211 N IBERRNO
212 S IBERRNO="IB"_(Z+IBISEQ-1)
213 I IBER[IBERRNO Q
214 S IBER=IBER_IBERRNO_";"
215 Q
216 ;
Note: See TracBrowser for help on using the repository browser.