IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89
;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361,371,377,400,432,461,547,592,623**;21-MAR-94;Build 70
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRBB
;
;IBNDn = IBND(n) = ^ib(399,n)
;RETURNS:
;IBER=fields with errors separated by semi-colons
;PRCASV("OKAY")=1 if iber="" and $D(prcasv("array")) compete
;
GVAR ;set up variables for mccr
Q:'$D(IBIFN) F I=0,"M","U","U1","S","MP","TX","UF3","UF31","U2" S @("IBND"_I)=$G(^DGCR(399,IBIFN,I))
S IBBNO=$P(IBND0,"^"),DFN=$P(IBND0,"^",2),IBEVDT=$P(IBND0,"^",3)
S IBLOC=$P(IBND0,"^",4),IBCL=$P(IBND0,"^",5),IBTF=$P(IBND0,"^",6)
S IBAT=$P(IBND0,"^",7),IBWHO=$P(IBND0,"^",11),IBST=$P(IBND0,"^",13),IBFT=$P(IBND0,"^",19)
S IBFDT=$P(IBNDU,"^",1),IBTDT=$P(IBNDU,"^",2)
S IBTC=$P(IBNDU1,"^",1),IBFY=$P(IBNDU1,"^",9),IBFYC=$P(IBNDU1,"^",10)
S IBEU=$P(IBNDS,"^",2),IBRU=$P(IBNDS,"^",5),IBAU=$P(IBNDS,"^",8)
S IBTOB=$$TOB(IBND0),IBTOB12=$E(IBTOB,1,2)
K ^TMP($J,"BILL-WARN")
Q
;
EN ;Entry to check for errors
N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBFOR,IBC,IBDX,IBDX1
I $D(IBFL) N IBFL
K ^TMP($J)
W !
S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q
;
;patient in patient file
I DFN="" S IBER=IBER_"IB057;"
I DFN]"",'$D(^DPT(DFN)) S IBER=IBER_"IB057;"
;IB*2.0*623;check date fields for validity;begin
I $$DTCK($$GET1^DIQ(2,DFN_",",.03,"I")) S IBER=IBER_"IB368;"
I $$DTCK($$GET1^DIQ(2,DFN_",",.351,"I")) S IBER=IBER_"IB369;"
S IBDX=0 F S IBDX=$O(^DPT(DFN,.312,IBDX)) Q:'IBDX D
. S IBDX1=$$GET1^DIQ(2.312,IBDX_","_DFN_",",3.01,"I")
. I $$DTCK(IBDX1) S IBER=IBER_"IB366;"
. Q
I $$DTCK($$GET1^DIQ(399,IBIFN_",",151,"I")) S IBER=IBER_"IB370;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",152,"I")) S IBER=IBER_"IB371;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",166,"I")) S IBER=IBER_"IB372;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",167,"I")) S IBER=IBER_"IB373;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",246,"I")) S IBER=IBER_"IB374;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",245,"I")) S IBER=IBER_"IB375;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",247,"I")) S IBER=IBER_"IB376;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",263,"I")) S IBER=IBER_"IB377;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",264,"I")) S IBER=IBER_"IB378;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",282,"I")) S IBER=IBER_"IB379;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",283,"I")) S IBER=IBER_"IB380;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",262,"I")) S IBER=IBER_"IB381;"
I $$DTCK($$GET1^DIQ(399,IBIFN_",",237,"I")) S IBER=IBER_"IB382;"
;
;end;IB*2.0*623
;
;Event date in correct format
I IBEVDT="" S IBER=IBER_"IB049;"
I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) S IBER=IBER_"IB049;"
;JWS;IB*2.0*623;add check for event date
I IBER'["IB049",$$DTCK(IBEVDT) S IBER=IBER_"IB049;"
;
;Rate Type
I IBAT="" S IBER=IBER_"IB059;"
I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;"
I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT=""
I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3)
;Check that AR category expects same debtor as defined in who's responsible.
I $D(IBARTP),IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N")) S IBER=IBER_"IB058;"
;
;Who's Responsible
I IBWHO=""!($L(IBWHO)>1)!("iop"'[IBWHO) S IBER=IBER_"IB065;"
S IBMRA=$S($$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)):$$TXMT^IBCEF4(IBIFN)>0,1:0)
; MCR will not reimburse is only valid if there is subsequent insurance
; that will reimburse
I IBWHO="i" D
. ;JWS;IB*2.0*592;US1109; If Dental and Plan Coverage Limitation is NO skip; IA# 3820
. I $$FT^IBCEF(IBIFN)=7 D
.. N INSONBIL,LOOP
.. ;JWS;IB*2.0*592;; only want to check insurance on the bill at this point
.. F LOOP="I1","I2","I3" I $D(^DGCR(399,IBIFN,LOOP)) K INSONBIL S INSONBIL(+^(LOOP))="" I '$$PTCOV^IBCNSU3(DFN,$P($G(^DGCR(399,IBIFN,0)),"^",3),"DENTAL",,.INSONBIL),IBER'["IB362" S IBER=IBER_"IB362;"
. I IBMRA D Q
.. ;JWS;IB*2.0*592;Do not allow to bill Dental to Medicare WNR
.. I $$FT^IBCEF(IBIFN)=7,'$F(IBER,"IB359;") S IBER=IBER_"IB359;"
.. N Z,IBZ
.. S IBZ=0
.. 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
.. I 'IBZ S IBER=IBER_"IB054;" D WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse")
. I $$COB^IBCEF(IBIFN)="S",$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1,$D(^DGCR(399,IBIFN,"I3")) Q
. I $S('IBNDMP:1,1:$P(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1)) S IBER=IBER_"IB054;"
I IBWHO="o",'$P(IBNDM,"^",11) S IBER=IBER_"IB053;"
;
; Outpatient Statement dates can not span the ICD-10 activation date
I IBCL>2,$$ICD10S^IBCU4(IBFDT,IBTDT) S IBER=IBER_"IB354;"
;
; All bill ICD codes must match Code Version on Statement To Date IB356
D ICD10V^IBCBB0(IBIFN)
;
; Billing Provider check - IB*2*400
D BP^IBCBB0(IBIFN)
;
; Pay-to Provider check - IB*2*400
D PAYTO^IBCBB0(IBIFN)
;
; All insurance subscribers must have a birth date on file
; - 11/10/04 - IB*2.0*288
; - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too
; IB error codes
; IB221 - Primary insurance subscriber missing date of birth
; IB222 - Secondary insurance subscriber missing date of birth
; IB223 - Tertiary insurance subscriber missing date of birth
; IB261 - Primary insurance subscriber is missing INSURED'S SEX
; IB262 - Secondary insurance subscriber is missing INSURED'S SEX
; IB263 - Tertiary insurance subscriber is missing INSURED'S SEX
;
F IBISEQ=1:1:3 D
. I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q ; no insurance here
. K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
. S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ)
. K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
. ;
. I '$P(IDDATA,U,1) D ERR(221) ; birth date missing
. ;IB*2.0*623;JWS;date validation
. I $$DTCK($P(IDDATA,U)) S IBER=IBER_"IB367;"
. ;
. I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ERR(261) ; sex missing
. ;
. ; IB*2*371 - esg - check for other missing insurance pieces
. ; check insured's name, primary ID#, pt. relationship to insured,
. ; and subscriber address data
. N INNAME,SUBID,PTREL,SFA,CAS,LN,FN
. ;
. ; IB273 - Primary Insurance name of insured missing
. ; IB274 - Secondary Insurance name of insured missing
. ; IB275 - Tertiary Insurance name of insured missing
. S INNAME=$$POLICY^IBCEF(IBIFN,17,IBISEQ)
. S LN=$P(INNAME,",",1),FN=$P(INNAME,",",2) ; last name,first name
. S LN=$$NOPUNCT^IBCEF(LN,1)
. S FN=$$NOPUNCT^IBCEF(FN,1)
. ; ib*2.0*547 - subscriber only needs last name
. ;I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid
. I LN="" D ERR(273) ; name of insured missing or invalid
. S LN=$$NAME^IBCEFG1(INNAME) ; additional name checks
. S FN=$P(LN,U,2)
. S LN=$P(LN,U,1)
. ;I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid
. I LN="" D ERR(273) ; name of insured missing or invalid
. ;
. ; IB276 - Primary Insurance subscriber ID missing
. ; IB277 - Secondary Insurance subscriber ID missing
. ; IB278 - Tertiary Insurance subscriber ID missing
. S SUBID=$$NOPUNCT^IBCEF($$POLICY^IBCEF(IBIFN,2,IBISEQ),1)
. I SUBID="" D ERR(276) ; subscriber ID# missing
. ;
. ; IB279 - Primary Insurance missing pt relationship
. ; IB280 - Secondary Insurance missing pt relationship
. ; IB281 - Tertiary Insurance missing pt relationship
. S PTREL=$$POLICY^IBCEF(IBIFN,16,IBISEQ)
. I PTREL="" D ERR(279) ; missing patient relationship to insured
. ;
. ; subscriber address section
. S SFA=$$INSADDR^IBCEF(IBIFN,IBISEQ) ; full address all pieces
. S CAS=$$NOPUNCT^IBCEF($P(SFA,U,2,5),1) ; string city,st,zip,addr1
. ;
. ; IB282 - Primary Insurance address line 1 missing
. ; IB283 - Secondary Insurance address line 1 missing
. ; IB284 - Tertiary Insurance address line 1 missing
. I $$NOPUNCT^IBCEF($P(SFA,U,5),1)="" D ; address line 1 is blank
.. ; pat=subscriber and current insurance - address is required
.. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(282) Q
.. ; if any part of the address is there, then all fields are required
.. I CAS'="" D ERR(282) Q
.. Q
. ;
. ; IB285 - Primary Insurance city missing
. ; IB286 - Secondary Insurance city missing
. ; IB287 - Tertiary Insurance city missing
. I $$NOPUNCT^IBCEF($P(SFA,U,2),1)="" D ; city is blank
.. ; pat=subscriber and current insurance - address is required
.. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(285) Q
.. ; if any part of the address is there, then all fields are required
.. I CAS'="" D ERR(285) Q
.. Q
. ;
. ; IB288 - Primary Insurance state missing
. ; IB289 - Secondary Insurance state missing
. ; IB290 - Tertiary Insurance state missing
. I $$NOPUNCT^IBCEF($P(SFA,U,3),1)="" D ; state is blank
.. ; pat=subscriber and current insurance - address is required
.. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(288) Q
.. ; if any part of the address is there, then all fields are required
.. I CAS'="" D ERR(288) Q
.. Q
. ;
. ; IB291 - Primary Insurance zipcode missing
. ; IB292 - Secondary Insurance zipcode missing
. ; IB293 - Tertiary Insurance zipcode missing
. I $$NOPUNCT^IBCEF($P(SFA,U,4),1)="" D ; zipcode is blank
.. ; pat=subscriber and current insurance - address is required
.. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(291) Q
.. ; if any part of the address is there, then all fields are required
.. I CAS'="" D ERR(291) Q
.. Q
. ;
. Q
;
; esg - IB*2*371 - check patient address fields
K ^UTILITY("VAPA",$J)
;
S IBFOR=0 ; foreign address flag
S IBC=+$$PTADDR^IBCEF(IBIFN,25) ; country code ien
I IBC D
. N CODE
. S CODE=$$GET1^DIQ(779.004,IBC,.01) ; .01 code field file 779.004
. I CODE'="",CODE'="USA" S IBFOR=1 ; foreign country exists
. Q
;
I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,1),1)="" S IBER=IBER_"IB269;"
I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,4),1)="" S IBER=IBER_"IB270;"
I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,5),1)="",'IBFOR S IBER=IBER_"IB271;"
I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,11),1)="",'IBFOR S IBER=IBER_"IB272;"
K ^UTILITY("VAPA",$J)
;
D PAYERADD^IBCBB0(IBIFN) ; check the payer addresses
D ^IBCBB1
Q
; The remaining code below is being removed with Patch IB*2.0*432.
;
; esg - 9/20/07 - IB patch 371 - prevent EDI transmission for 3 payer
; claims for all but the first payer. To be removed when Emdeon
; and FSC are able to deal with these.
;
I +$G(^DGCR(399,IBIFN,"I2")),+$G(^DGCR(399,IBIFN,"I3")),$$TXMT^IBCEF4(IBIFN) D
. ; for MRA request claims, make sure the MRA secondary claim is forced to print
. I $$REQMRA^IBEFUNC(IBIFN) D Q
.. I '$P($G(^DGCR(399,IBIFN,"TX")),U,9) S IBER=IBER_"IB146;"
.. Q
. ;
. I $$COBN^IBCEF(IBIFN)=1 Q ; primary payer sequence claims are OK
. ;
. ; But claims with a payer sequence of 2 or 3 need to print locally
. S IBER=IBER_"IB147;"
. Q
;
Q
;
EDIT(IBIFN) ; Run edits from within the billing edit screens
N IBVIEW,IBDISP,IBNOFIX,DIR,X,Y
S (IBNOFIX,IBVIEW,IBDISP)=1
D EDITS^IBCB2
W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
Q
;
TOB(IBND0) ;
; IBND0 = the 0-node of the bill (file 399)
Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26))
;
ERR(Z) ; update IBER variable from the above insurance checks
; Z is the IB error code# for the primary insurance error
N IBERRNO
S IBERRNO="IB"_(Z+IBISEQ-1)
I IBER[IBERRNO Q
S IBER=IBER_IBERRNO_";"
Q
;
DTCK(DATE) ; IB*2.0*623 - check for valid date
I DATE="" Q 0
S X=DATE D H^%DTC
I %Y=-1 Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCBB 12039 printed Sep 23, 2025@19:44:58 Page 2
IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89
+1 ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361,371,377,400,432,461,547,592,623**;21-MAR-94;Build 70
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRBB
+5 ;
+6 ;IBNDn = IBND(n) = ^ib(399,n)
+7 ;RETURNS:
+8 ;IBER=fields with errors separated by semi-colons
+9 ;PRCASV("OKAY")=1 if iber="" and $D(prcasv("array")) compete
+10 ;
GVAR ;set up variables for mccr
+1 if '$DATA(IBIFN)
QUIT
FOR I=0,"M","U","U1","S","MP","TX","UF3","UF31","U2"
SET @("IBND"_I)=$GET(^DGCR(399,IBIFN,I))
+2 SET IBBNO=$PIECE(IBND0,"^")
SET DFN=$PIECE(IBND0,"^",2)
SET IBEVDT=$PIECE(IBND0,"^",3)
+3 SET IBLOC=$PIECE(IBND0,"^",4)
SET IBCL=$PIECE(IBND0,"^",5)
SET IBTF=$PIECE(IBND0,"^",6)
+4 SET IBAT=$PIECE(IBND0,"^",7)
SET IBWHO=$PIECE(IBND0,"^",11)
SET IBST=$PIECE(IBND0,"^",13)
SET IBFT=$PIECE(IBND0,"^",19)
+5 SET IBFDT=$PIECE(IBNDU,"^",1)
SET IBTDT=$PIECE(IBNDU,"^",2)
+6 SET IBTC=$PIECE(IBNDU1,"^",1)
SET IBFY=$PIECE(IBNDU1,"^",9)
SET IBFYC=$PIECE(IBNDU1,"^",10)
+7 SET IBEU=$PIECE(IBNDS,"^",2)
SET IBRU=$PIECE(IBNDS,"^",5)
SET IBAU=$PIECE(IBNDS,"^",8)
+8 SET IBTOB=$$TOB(IBND0)
SET IBTOB12=$EXTRACT(IBTOB,1,2)
+9 KILL ^TMP($JOB,"BILL-WARN")
+10 QUIT
+11 ;
EN ;Entry to check for errors
+1 NEW IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBFOR,IBC,IBDX,IBDX1
+2 IF $DATA(IBFL)
NEW IBFL
+3 KILL ^TMP($JOB)
+4 WRITE !
+5 SET IBER=""
DO GVAR
IF '$DATA(IBND0)
SET IBER=-1
QUIT
+6 ;
+7 ;patient in patient file
+8 IF DFN=""
SET IBER=IBER_"IB057;"
+9 IF DFN]""
IF '$DATA(^DPT(DFN))
SET IBER=IBER_"IB057;"
+10 ;IB*2.0*623;check date fields for validity;begin
+11 IF $$DTCK($$GET1^DIQ(2,DFN_",",.03,"I"))
SET IBER=IBER_"IB368;"
+12 IF $$DTCK($$GET1^DIQ(2,DFN_",",.351,"I"))
SET IBER=IBER_"IB369;"
+13 SET IBDX=0
FOR
SET IBDX=$ORDER(^DPT(DFN,.312,IBDX))
if 'IBDX
QUIT
Begin DoDot:1
+14 SET IBDX1=$$GET1^DIQ(2.312,IBDX_","_DFN_",",3.01,"I")
+15 IF $$DTCK(IBDX1)
SET IBER=IBER_"IB366;"
+16 QUIT
End DoDot:1
+17 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",151,"I"))
SET IBER=IBER_"IB370;"
+18 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",152,"I"))
SET IBER=IBER_"IB371;"
+19 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",166,"I"))
SET IBER=IBER_"IB372;"
+20 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",167,"I"))
SET IBER=IBER_"IB373;"
+21 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",246,"I"))
SET IBER=IBER_"IB374;"
+22 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",245,"I"))
SET IBER=IBER_"IB375;"
+23 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",247,"I"))
SET IBER=IBER_"IB376;"
+24 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",263,"I"))
SET IBER=IBER_"IB377;"
+25 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",264,"I"))
SET IBER=IBER_"IB378;"
+26 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",282,"I"))
SET IBER=IBER_"IB379;"
+27 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",283,"I"))
SET IBER=IBER_"IB380;"
+28 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",262,"I"))
SET IBER=IBER_"IB381;"
+29 IF $$DTCK($$GET1^DIQ(399,IBIFN_",",237,"I"))
SET IBER=IBER_"IB382;"
+30 ;
+31 ;end;IB*2.0*623
+32 ;
+33 ;Event date in correct format
+34 IF IBEVDT=""
SET IBER=IBER_"IB049;"
+35 IF IBEVDT]""
IF IBEVDT'?7N&(IBEVDT'?7N1".".N)
SET IBER=IBER_"IB049;"
+36 ;JWS;IB*2.0*623;add check for event date
+37 IF IBER'["IB049"
IF $$DTCK(IBEVDT)
SET IBER=IBER_"IB049;"
+38 ;
+39 ;Rate Type
+40 IF IBAT=""
SET IBER=IBER_"IB059;"
+41 IF IBAT]""
IF '$DATA(^DGCR(399.3,IBAT,0))
SET IBER=IBER_"IB059;"
+42 IF IBAT]""
IF $DATA(^DGCR(399.3,IBAT,0))
IF '$PIECE(^(0),"^",6)
SET IBER=IBER_"IB059;"
SET IBAT=""
+43 IF IBAT]""
IF $PIECE($GET(^DGCR(399.3,IBAT,0)),"^",6)
SET IBARTP=$PIECE($$CATN^PRCAFN($PIECE(^DGCR(399.3,IBAT,0),"^",6)),"^",3)
+44 ;Check that AR category expects same debtor as defined in who's responsible.
+45 IF $DATA(IBARTP)
IF IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N"))
SET IBER=IBER_"IB058;"
+46 ;
+47 ;Who's Responsible
+48 IF IBWHO=""!($LENGTH(IBWHO)>1)!("iop"'[IBWHO)
SET IBER=IBER_"IB065;"
+49 SET IBMRA=$SELECT($$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 IF IBWHO="i"
Begin DoDot:1
+53 ;JWS;IB*2.0*592;US1109; If Dental and Plan Coverage Limitation is NO skip; IA# 3820
+54 IF $$FT^IBCEF(IBIFN)=7
Begin DoDot:2
+55 NEW INSONBIL,LOOP
+56 ;JWS;IB*2.0*592;; only want to check insurance on the bill at this point
+57 FOR LOOP="I1","I2","I3"
IF $DATA(^DGCR(399,IBIFN,LOOP))
KILL INSONBIL
SET INSONBIL(+^(LOOP))=""
IF '$$PTCOV^IBCNSU3(DFN,$PIECE($GET(^DGCR(399,IBIFN,0)),"^",3),"DENTAL",,.INSONBIL)
IF IBER'["IB362"
SET IBER=IBER_"IB362;"
End DoDot:2
+58 IF IBMRA
Begin DoDot:2
+59 ;JWS;IB*2.0*592;Do not allow to bill Dental to Medicare WNR
+60 IF $$FT^IBCEF(IBIFN)=7
IF '$FIND(IBER,"IB359;")
SET IBER=IBER_"IB359;"
+61 NEW Z,IBZ
+62 SET IBZ=0
+63 FOR Z=$$COBN^IBCEF(IBIFN):1:3
IF $DATA(^DGCR(399,IBIFN,"I"_(Z+1)))
IF $PIECE($GET(^DIC(36,+$GET(^DGCR(399,IBIFN,"I"_(Z+1))),0)),U,2)'="N"
SET IBZ=1
QUIT
+64 IF 'IBZ
SET IBER=IBER_"IB054;"
DO WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse")
End DoDot:2
QUIT
+65 IF $$COB^IBCEF(IBIFN)="S"
IF $$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1
IF $DATA(^DGCR(399,IBIFN,"I3"))
QUIT
+66 IF $SELECT('IBNDMP:1,1:$PIECE(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1))
SET IBER=IBER_"IB054;"
End DoDot:1
+67 IF IBWHO="o"
IF '$PIECE(IBNDM,"^",11)
SET IBER=IBER_"IB053;"
+68 ;
+69 ; Outpatient Statement dates can not span the ICD-10 activation date
+70 IF IBCL>2
IF $$ICD10S^IBCU4(IBFDT,IBTDT)
SET IBER=IBER_"IB354;"
+71 ;
+72 ; All bill ICD codes must match Code Version on Statement To Date IB356
+73 DO ICD10V^IBCBB0(IBIFN)
+74 ;
+75 ; Billing Provider check - IB*2*400
+76 DO BP^IBCBB0(IBIFN)
+77 ;
+78 ; Pay-to Provider check - IB*2*400
+79 DO PAYTO^IBCBB0(IBIFN)
+80 ;
+81 ; All insurance subscribers must have a birth date on file
+82 ; - 11/10/04 - IB*2.0*288
+83 ; - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too
+84 ; IB error codes
+85 ; IB221 - Primary insurance subscriber missing date of birth
+86 ; IB222 - Secondary insurance subscriber missing date of birth
+87 ; IB223 - Tertiary insurance subscriber missing date of birth
+88 ; IB261 - Primary insurance subscriber is missing INSURED'S SEX
+89 ; IB262 - Secondary insurance subscriber is missing INSURED'S SEX
+90 ; IB263 - Tertiary insurance subscriber is missing INSURED'S SEX
+91 ;
+92 FOR IBISEQ=1:1:3
Begin DoDot:1
+93 ; no insurance here
IF '$PIECE($GET(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1)
QUIT
+94 KILL ^UTILITY("VADM",$JOB),^UTILITY("VAPA",$JOB)
+95 SET IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ)
+96 KILL ^UTILITY("VADM",$JOB),^UTILITY("VAPA",$JOB)
+97 ;
+98 ; birth date missing
IF '$PIECE(IDDATA,U,1)
DO ERR(221)
+99 ;IB*2.0*623;JWS;date validation
+100 IF $$DTCK($PIECE(IDDATA,U))
SET IBER=IBER_"IB367;"
+101 ;
+102 ; sex missing
IF "^M^F^"'[(U_$PIECE(IDDATA,U,2)_U)
DO ERR(261)
+103 ;
+104 ; IB*2*371 - esg - check for other missing insurance pieces
+105 ; check insured's name, primary ID#, pt. relationship to insured,
+106 ; and subscriber address data
+107 NEW INNAME,SUBID,PTREL,SFA,CAS,LN,FN
+108 ;
+109 ; IB273 - Primary Insurance name of insured missing
+110 ; IB274 - Secondary Insurance name of insured missing
+111 ; IB275 - Tertiary Insurance name of insured missing
+112 SET INNAME=$$POLICY^IBCEF(IBIFN,17,IBISEQ)
+113 ; last name,first name
SET LN=$PIECE(INNAME,",",1)
SET FN=$PIECE(INNAME,",",2)
+114 SET LN=$$NOPUNCT^IBCEF(LN,1)
+115 SET FN=$$NOPUNCT^IBCEF(FN,1)
+116 ; ib*2.0*547 - subscriber only needs last name
+117 ;I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid
+118 ; name of insured missing or invalid
IF LN=""
DO ERR(273)
+119 ; additional name checks
SET LN=$$NAME^IBCEFG1(INNAME)
+120 SET FN=$PIECE(LN,U,2)
+121 SET LN=$PIECE(LN,U,1)
+122 ;I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid
+123 ; name of insured missing or invalid
IF LN=""
DO ERR(273)
+124 ;
+125 ; IB276 - Primary Insurance subscriber ID missing
+126 ; IB277 - Secondary Insurance subscriber ID missing
+127 ; IB278 - Tertiary Insurance subscriber ID missing
+128 SET SUBID=$$NOPUNCT^IBCEF($$POLICY^IBCEF(IBIFN,2,IBISEQ),1)
+129 ; subscriber ID# missing
IF SUBID=""
DO ERR(276)
+130 ;
+131 ; IB279 - Primary Insurance missing pt relationship
+132 ; IB280 - Secondary Insurance missing pt relationship
+133 ; IB281 - Tertiary Insurance missing pt relationship
+134 SET PTREL=$$POLICY^IBCEF(IBIFN,16,IBISEQ)
+135 ; missing patient relationship to insured
IF PTREL=""
DO ERR(279)
+136 ;
+137 ; subscriber address section
+138 ; full address all pieces
SET SFA=$$INSADDR^IBCEF(IBIFN,IBISEQ)
+139 ; string city,st,zip,addr1
SET CAS=$$NOPUNCT^IBCEF($PIECE(SFA,U,2,5),1)
+140 ;
+141 ; IB282 - Primary Insurance address line 1 missing
+142 ; IB283 - Secondary Insurance address line 1 missing
+143 ; IB284 - Tertiary Insurance address line 1 missing
+144 ; address line 1 is blank
IF $$NOPUNCT^IBCEF($PIECE(SFA,U,5),1)=""
Begin DoDot:2
+145 ; pat=subscriber and current insurance - address is required
+146 IF +PTREL=1
IF IBISEQ=$$COBN^IBCEF(IBIFN)
DO ERR(282)
QUIT
+147 ; if any part of the address is there, then all fields are required
+148 IF CAS'=""
DO ERR(282)
QUIT
+149 QUIT
End DoDot:2
+150 ;
+151 ; IB285 - Primary Insurance city missing
+152 ; IB286 - Secondary Insurance city missing
+153 ; IB287 - Tertiary Insurance city missing
+154 ; city is blank
IF $$NOPUNCT^IBCEF($PIECE(SFA,U,2),1)=""
Begin DoDot:2
+155 ; pat=subscriber and current insurance - address is required
+156 IF +PTREL=1
IF IBISEQ=$$COBN^IBCEF(IBIFN)
DO ERR(285)
QUIT
+157 ; if any part of the address is there, then all fields are required
+158 IF CAS'=""
DO ERR(285)
QUIT
+159 QUIT
End DoDot:2
+160 ;
+161 ; IB288 - Primary Insurance state missing
+162 ; IB289 - Secondary Insurance state missing
+163 ; IB290 - Tertiary Insurance state missing
+164 ; state is blank
IF $$NOPUNCT^IBCEF($PIECE(SFA,U,3),1)=""
Begin DoDot:2
+165 ; pat=subscriber and current insurance - address is required
+166 IF +PTREL=1
IF IBISEQ=$$COBN^IBCEF(IBIFN)
DO ERR(288)
QUIT
+167 ; if any part of the address is there, then all fields are required
+168 IF CAS'=""
DO ERR(288)
QUIT
+169 QUIT
End DoDot:2
+170 ;
+171 ; IB291 - Primary Insurance zipcode missing
+172 ; IB292 - Secondary Insurance zipcode missing
+173 ; IB293 - Tertiary Insurance zipcode missing
+174 ; zipcode is blank
IF $$NOPUNCT^IBCEF($PIECE(SFA,U,4),1)=""
Begin DoDot:2
+175 ; pat=subscriber and current insurance - address is required
+176 IF +PTREL=1
IF IBISEQ=$$COBN^IBCEF(IBIFN)
DO ERR(291)
QUIT
+177 ; if any part of the address is there, then all fields are required
+178 IF CAS'=""
DO ERR(291)
QUIT
+179 QUIT
End DoDot:2
+180 ;
+181 QUIT
End DoDot:1
+182 ;
+183 ; esg - IB*2*371 - check patient address fields
+184 KILL ^UTILITY("VAPA",$JOB)
+185 ;
+186 ; foreign address flag
SET IBFOR=0
+187 ; country code ien
SET IBC=+$$PTADDR^IBCEF(IBIFN,25)
+188 IF IBC
Begin DoDot:1
+189 NEW CODE
+190 ; .01 code field file 779.004
SET CODE=$$GET1^DIQ(779.004,IBC,.01)
+191 ; foreign country exists
IF CODE'=""
IF CODE'="USA"
SET IBFOR=1
+192 QUIT
End DoDot:1
+193 ;
+194 IF $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,1),1)=""
SET IBER=IBER_"IB269;"
+195 IF $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,4),1)=""
SET IBER=IBER_"IB270;"
+196 IF $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,5),1)=""
IF 'IBFOR
SET IBER=IBER_"IB271;"
+197 IF $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,11),1)=""
IF 'IBFOR
SET IBER=IBER_"IB272;"
+198 KILL ^UTILITY("VAPA",$JOB)
+199 ;
+200 ; check the payer addresses
DO PAYERADD^IBCBB0(IBIFN)
+201 DO ^IBCBB1
+202 QUIT
+203 ; The remaining code below is being removed with Patch IB*2.0*432.
+204 ;
+205 ; esg - 9/20/07 - IB patch 371 - prevent EDI transmission for 3 payer
+206 ; claims for all but the first payer. To be removed when Emdeon
+207 ; and FSC are able to deal with these.
+208 ;
+209 IF +$GET(^DGCR(399,IBIFN,"I2"))
IF +$GET(^DGCR(399,IBIFN,"I3"))
IF $$TXMT^IBCEF4(IBIFN)
Begin DoDot:1
+210 ; for MRA request claims, make sure the MRA secondary claim is forced to print
+211 IF $$REQMRA^IBEFUNC(IBIFN)
Begin DoDot:2
+212 IF '$PIECE($GET(^DGCR(399,IBIFN,"TX")),U,9)
SET IBER=IBER_"IB146;"
+213 QUIT
End DoDot:2
QUIT
+214 ;
+215 ; primary payer sequence claims are OK
IF $$COBN^IBCEF(IBIFN)=1
QUIT
+216 ;
+217 ; But claims with a payer sequence of 2 or 3 need to print locally
+218 SET IBER=IBER_"IB147;"
+219 QUIT
End DoDot:1
+220 ;
+221 QUIT
+222 ;
EDIT(IBIFN) ; Run edits from within the billing edit screens
+1 NEW IBVIEW,IBDISP,IBNOFIX,DIR,X,Y
+2 SET (IBNOFIX,IBVIEW,IBDISP)=1
+3 DO EDITS^IBCB2
+4 WRITE !
SET DIR("A")="Press RETURN to continue"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 QUIT
+6 ;
TOB(IBND0) ;
+1 ; IBND0 = the 0-node of the bill (file 399)
+2 QUIT ($PIECE(IBND0,U,24)_$PIECE($GET(^DGCR(399.1,+$PIECE(IBND0,U,25),0)),U,2)_$PIECE(IBND0,U,26))
+3 ;
ERR(Z) ; update IBER variable from the above insurance checks
+1 ; Z is the IB error code# for the primary insurance error
+2 NEW IBERRNO
+3 SET IBERRNO="IB"_(Z+IBISEQ-1)
+4 IF IBER[IBERRNO
QUIT
+5 SET IBER=IBER_IBERRNO_";"
+6 QUIT
+7 ;
DTCK(DATE) ; IB*2.0*623 - check for valid date
+1 IF DATE=""
QUIT 0
+2 SET X=DATE
DO H^%DTC
+3 IF %Y=-1
QUIT 1
+4 QUIT 0
+5 ;
