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**;21-MAR-94;Build 23
 ;;Per VHA Directive 2004-038, 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
 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;"
 ;
 ;Event date in correct format
 I IBEVDT="" S IBER=IBER_"IB049;"
 I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) 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
 . I IBMRA D  Q
 .. 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;"
 ;
 ; 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
 . ;
 . 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)
 . I LN=""!(FN="") 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
 . ;
 . ;          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
 ;
 ; 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
 ;
 D ^IBCBB1
 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
 ;