- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m
r613 r623 1 IBCBB ;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 ; 12 GVAR ;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 ; 24 EN ;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 ; 198 EDIT(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 ; 205 TOB(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 ; 209 ERR(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 ; 1 IBCBB ;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**;21-MAR-94;Build 9 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 ; 12 GVAR ;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 ; 24 EN ;Entry to check for errors 25 N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBERRNO 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 ;I $$ISPROS^IBCEF1(IBIFN) D 32 ;. D WARN^IBCBB11("Bill has prosthetics item(s) and will only print locally") 33 ;. I $$NEEDMRA^IBEFUNC(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,"098") 34 ; 35 ;patient in patient file 36 I DFN="" S IBER=IBER_"IB057;" 37 I DFN]"",'$D(^DPT(DFN)) S IBER=IBER_"IB057;" 38 ; 39 ;Event date in correct format 40 I IBEVDT="" S IBER=IBER_"IB049;" 41 I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) S IBER=IBER_"IB049;" 42 ; 43 ;Rate Type 44 I IBAT="" S IBER=IBER_"IB059;" 45 I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;" 46 I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT="" 47 ;I IBAT]"",$D(^DGCR(399.3,IBAT,0)) S IBARTP=$P(^PRCA(430.2,$P(^DGCR(399.3,IBAT,0),"^",6),0),"^",6) 48 I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3) 49 ;Check that AR category expects same debtor as defined in who's responsible. 50 I $D(IBARTP),IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N")) S IBER=IBER_"IB058;" 51 ; 52 ;Who's Responsible 53 I IBWHO=""!($L(IBWHO)>1)!("iop"'[IBWHO) S IBER=IBER_"IB065;" 54 S IBMRA=$S($$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)):$$TXMT^IBCEF4(IBIFN)>0,1:0) 55 ; MCR will not reimburse is only valid if there is subsequent insurance 56 ; that will reimburse 57 I IBWHO="i" D 58 . I IBMRA D Q 59 .. N Z,IBZ 60 .. S IBZ=0 61 .. 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 62 .. I 'IBZ S IBER=IBER_"IB054;" D WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse") 63 .. 64 . I $$COB^IBCEF(IBIFN)="S",$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1,$D(^DGCR(399,IBIFN,"I3")) Q 65 . I $S('IBNDMP:1,1:$P(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1)) S IBER=IBER_"IB054;" 66 I IBWHO="o",'$P(IBNDM,"^",11) S IBER=IBER_"IB053;" 67 ; 68 ; All insurance subscribers must have a birth date on file 69 ; - 11/10/04 - IB*2.0*288 70 ; - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too 71 ; IB error codes 72 ; IB221 - Primary insurance subscriber missing date of birth 73 ; IB222 - Secondary insurance subscriber missing date of birth 74 ; IB223 - Tertiary insurance subscriber missing date of birth 75 ; IB261 - Primary insurance subscriber is missing INSURED'S SEX 76 ; IB262 - Secondary insurance subscriber is missing INSURED'S SEX 77 ; IB263 - Tertiary insurance subscriber is missing INSURED'S SEX 78 ; 79 F IBISEQ=1:1:3 D 80 . I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q ; no insurance here 81 . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) 82 . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ) 83 . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) 84 . I '$P(IDDATA,U,1) D ; birth date missing 85 .. S IBERRNO=220+IBISEQ 86 .. S IBER=IBER_"IB"_IBERRNO_";" 87 . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ; sex missing 88 .. S IBERRNO=260+IBISEQ 89 .. S IBER=IBER_"IB"_IBERRNO_";" 90 . Q 91 ; 92 D ^IBCBB1 93 Q 94 ; 95 EDIT(IBIFN) ; Run edits from within the billing edit screens 96 N IBVIEW,IBDISP,IBNOFIX,DIR,X,Y 97 S (IBNOFIX,IBVIEW,IBDISP)=1 98 D EDITS^IBCB2 99 W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR 100 Q 101 ; 102 TOB(IBND0) ; 103 ; IBND0 = the 0-node of the bill (file 399) 104 Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26)) 105 ;
Note:
See TracChangeset
for help on using the changeset viewer.
