Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEU

IBCEU.m

Go to the documentation of this file.
  1. IBCEU ;ALB/TMP - EDI UTILITIES ;02-OCT-96
  1. ;;2.0;INTEGRATED BILLING;**51,137,207,232,349,432,592,608**;21-MAR-94;Build 90
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ; DBIA SUPPORTED REF: GET^XUA4A72 = 1625
  1. ; DBIA SUPPORTED REF: $$ESBLOCK^XUSESIG1 = 1557
  1. Q
  1. ;
  1. TESTPT(DFN) ; Determine if pt is test pt
  1. ; Returns 1 if a test pt, 0 if not
  1. Q $E($P($G(^DPT(+DFN,0)),U,9),1,5)="00000"
  1. ;
  1. MAINPRV(IBIFN) ; Returns name^id^ien^type code of 'main' prov on bill IBIFN
  1. N IBPRV,IBCOB,IBQ,Z
  1. D GETPRV(IBIFN,"3,4",.IBPRV)
  1. S IBQ="",IBCOB=$$COBN^IBCEF(IBIFN)
  1. F Z=3,4 I $G(IBPRV(Z,1))'="" D Q
  1. . S IBQ=IBPRV(Z,1),$P(IBQ,U,4)=Z
  1. . I $G(IBPRV(Z,1,IBCOB))'="" S $P(IBQ,U,2)=IBPRV(Z,1,IBCOB)
  1. Q IBQ
  1. ;
  1. PRVOK(VAL,IBIFN) ; Check bill form & prov function agree
  1. ; VAL = internal value of prov function
  1. ;
  1. N OK,IBBT
  1. S OK=0
  1. Q:VAL="" OK
  1. Q:'IBIFN OK
  1. ; JWS;IB*2.0*592 US1108 - add Dental form (7) check
  1. S IBBT=$$FT^IBCEF(IBIFN) ; 2 If CMS-1500, 3 If UB-04, 7 if J430D Dental
  1. I IBBT=2!(IBBT=7) D
  1. . I VAL=1 S OK=1 Q ; CMS-1500, REFERRING
  1. . I VAL=3 S OK=1 Q ; CMS-1500, RENDERING
  1. . I VAL=5 S OK=1 Q ; CMS-1500, SUPERVISING
  1. . I IBBT=7,VAL=6 S OK=1 Q ;J430D, ASSISTANT SURGEON
  1. ; JWS;IB*2.0*592 US1108 - end
  1. I IBBT=7,$G(IBDR20)=103,'$$FILTERP^IBCSC10H(IBIFN,VAL) S OK=0
  1. I 'OK,IBBT=3 D
  1. . I VAL=1 S OK=1 Q ; UB-04, REFERRING
  1. . I VAL=2 S OK=1 Q ; UB-04, OPERATING
  1. . I VAL=3 S OK=1 Q ; UB-04, RENDERING
  1. . I VAL=4 S OK=1 Q ; UB-04, ATTENDING
  1. . I VAL=9 S OK=1 Q ; UB-04, OTHER
  1. ;
  1. Q OK
  1. ;
  1. PRVOK1(VAL,IBIFN) ; Check for both attending and rendering on bill
  1. N OK
  1. S OK=1
  1. Q:$$FT^IBCEF(IBIFN)=3 1 ; both are allowed on UB
  1. I $S("34"'[VAL:0,1:$D(^DGCR(399,IBIFN,"PRV","B",$S(VAL=3:4,1:3)))) D EN^DDIOL($S(VAL=3:"ATTENDING",1:"RENDERING")_" ALREADY EXISTS - CAN'T HAVE BOTH ON ONE BILL") S OK=0
  1. Q OK
  1. ;
  1. SPEC(IBPRV,IBDT) ; Returns spec code for vp ien IBPRV from file 355.9
  1. ; (for new person entries, as of date in IBDT)
  1. ; DBIA 1625
  1. N IBSPEC
  1. S:'$G(IBDT) IBDT=DT
  1. I IBPRV'["IBA(355.93" S IBSPEC=$S(IBPRV:$P($$GET^XUA4A72(+IBPRV,IBDT),U,8),1:"") ; VA
  1. I IBPRV["IBA(355.93" S IBSPEC=$P($G(^IBA(355.93,+IBPRV,0)),U,4) ; Non-VA
  1. Q IBSPEC
  1. ;
  1. CRED(IBPRV,IBIFN,IBPIEN,IBTYP) ; Returns prov credentials
  1. ; IBPRV = vp of provider for file 200 or 355.93
  1. ; IBIFN = bill ien in file 399 (optional)
  1. ; IBPIEN = prov ien - file 399.0222 (optional)
  1. ; DEM;432 - prov ien can be from file 399.0404
  1. ; as well (optional).
  1. ; IBTYP = the prov type
  1. ;
  1. N IBCRED
  1. S IBCRED=""
  1. ;
  1. ; DEM;432 - Provider can come from either file 399.0222, or
  1. ; file 399.0404. Variable IBLNPRV is the flag
  1. ; that indicates we want prov ien from file 399.0404.
  1. ;
  1. I '$G(IBLNPRV),$G(IBIFN),'$D(^DGCR(399,IBIFN,"PRV",0)) G CREDQ
  1. ;
  1. ; DEM;432 - Next line if for line level provider. Variable IBPROCP,
  1. ; if it exist, is the procedure ien. File 399.0404 is a
  1. ; multiple of the Procedure File 399.0304.
  1. ;
  1. I $G(IBLNPRV),$G(IBIFN),$G(IBPROCP),'$D(^DGCR(399,IBIFN,"CP",IBPROCP,"LNPRV",0)) G CREDQ
  1. I '$G(IBLNPRV),$G(IBIFN),($G(IBPIEN)!$G(IBTYP)) D
  1. . I '$G(IBPIEN) S IBPIEN=+$O(^DGCR(399,IBIFN,"PRV","B",IBTYP,0))
  1. . S IBCRED=$P($G(^DGCR(399,IBIFN,"PRV",IBPIEN,0)),U,3)
  1. ;
  1. I $G(IBLNPRV),$G(IBIFN),$G(IBPROCP),($G(IBPIEN)!$G(IBTYP)) D ; DEM;432 - Line Provider File 399.0404.
  1. . I '$G(IBPIEN) S IBPIEN=+$O(^DGCR(399,IBIFN,"CP",IBPROCP,"B",IBTYP,0))
  1. . S IBCRED=$P($G(^DGCR(399,IBIFN,"CP",IBPROCP,"LNPRV",IBPIEN,0)),U,3)
  1. ;
  1. CREDQ ;
  1. I $G(IBPRV),IBCRED="" D
  1. . I IBPRV'["IBA(355.93" S IBCRED=$P($$ESBLOCK^XUSESIG1(+IBPRV),U,2)
  1. . I IBPRV["IBA(355.93" S IBCRED=$P($G(^IBA(355.93,+IBPRV,0)),U,3)
  1. Q IBCRED
  1. ;
  1. GETPRV(IBIFN,IBTYP,IBPRV) ; Returns prov(s) of type(s) IBTYP for
  1. ; bill ien IBIFN.
  1. ; IBTYP = prov types needed, separated by ',' or ALL
  1. ;
  1. ; OUTPUT:
  1. ; IBPRV array: IBPRV(type)= 1 if prov is from old prov flds
  1. ; IBPRV(type,ct)=name^current COB id^vp provider ien^cred
  1. ; IBPRV(type,ct,seq)=COB seq specific id
  1. ; IBPRV(type)=default nm^def id
  1. ; IBPRV(type,"NOTOPT")= defined if a required prov type
  1. ;
  1. N IB,IBCT,IBD,IBY,IBZ,IBMRAND,IBID,IBWNR,IBPNM,Z ;,IBZFID
  1. ;S IBZFID=""
  1. D F^IBCEF("N-CURRENT INS POLICY TYPE","IBZ",,IBIFN)
  1. ;I IBZ="CI" D F^IBCEF("N-FEDERAL TAX ID","IBZFID",,IBIFN) S IBZFID=$TR(IBZFID,"-")
  1. S IBPRV=U_$G(IBZ),IBY=0
  1. S IBMRAND=$$MCRONBIL^IBEFUNC(IBIFN)
  1. ;WCJ;IB*2.0*432;Remove Default
  1. I IBMRAND D
  1. . ; F Z=1:1:3,5,6,7,8,9 S:Z=3&($$FT^IBCEF(IBIFN)=3) Z=4 S IBPRV(Z)=$S(Z=3!(Z=4):"DEPT VETERANS AFFAIRS",1:"")_"^VAD000"
  1. . F Z=1:1:9 S IBPRV(Z)="^VAD000"
  1. . I '$$INPAT^IBCEF(IBIFN,1),$$FT^IBCEF(IBIFN)=3 S IBPRV(4,1)="^SLF000"
  1. ;WCJ;IB*2.0*432;End changes
  1. ;
  1. ; For backwards compatability (before the claim level provider mulitple)
  1. I '$D(^DGCR(399,+IBIFN,"PRV",0)) D G GETQ
  1. . N IBALL
  1. . S IBALL=(IBTYP="ALL")
  1. . I IBTYP[4!IBALL S:$P($G(^DGCR(399,+IBIFN,"U1")),U,13)'="" IBPRV(4,1)=$P(^("U1"),U,13),IBPRV(4)=1 Q:IBTYP=4
  1. . I IBTYP[3!IBALL S:$P($G(^DGCR(399,+IBIFN,"UF2")),U)'="" IBPRV(3,1)=$P(^("UF2"),U),IBPRV(3)=1 Q:IBTYP=3
  1. . I IBTYP[9!IBALL S:$P($G(^DGCR(399,+IBIFN,"U1")),U,14)'="" IBPRV(9,1)=$P(^("U1"),U,14),IBPRV(9)=1
  1. ;
  1. S IBID=4+$$COBN^IBCEF(IBIFN),IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
  1. F IBZ=1:1:$S(IBTYP="ALL":99,1:$L(IBTYP,",")) S (IBCT,IB)=0,IBY=$S(IBTYP'="ALL":$P(IBTYP,",",IBZ),1:$O(^DGCR(399,+IBIFN,"PRV","B",IBY))) Q:IBY="" F S IB=$O(^DGCR(399,+IBIFN,"PRV","B",IBY,IB)) Q:'IB D
  1. . S IBCT=IBCT+1
  1. . S IBD=$G(^DGCR(399,+IBIFN,"PRV",IB,0))
  1. . Q:'$P(IBD,U,2)
  1. . S IBPNM=$$EXPAND^IBTRE(399.0222,.02,$P(IBD,U,2))
  1. . I IBWNR Q:'$D(IBPRV(IBY)) S $P(IBD,U,IBID)=$P(IBPRV(IBY),U,2)
  1. . S IBPRV(IBY,IBCT)=IBPNM_U_$S($P(IBD,U,IBID)'="":$P(IBD,U,IBID),$P($G(IBPRV(IBY)),U,2)'="":$P(IBPRV(IBY),U,2),1:$P($$DEFID^IBCEF74(IBIFN,IB),U,IBID-4))_U_$P(IBD,U,2)
  1. . S $P(IBPRV(IBY,IBCT),U,4)=$$CRED($P(IBPRV(IBY,IBCT),U,3),IBIFN,$S($P(IBD,U,3)'=""!'$P(IBPRV(IBY,IBCT),U,3):IB,1:""))
  1. . F Z=1:1:3 D
  1. .. ;I IBZFID'="",'$$INPAT^IBCEF(IBIFN,1),$P(IBPRV(IBY,IBCT),U,2)="SLF000" S IBZFID=""
  1. .. ;I $S(Z=1:1,1:$D(^DGCR(399,IBIFN,"I"_Z))) S IBPRV(IBY,IBCT,Z)=$S($G(IBZFID)'="":IBZFID,$P(IBD,U,Z+4)'="":$P(IBD,U,Z+4),1:"")
  1. .. I $S(Z=1:1,1:$D(^DGCR(399,IBIFN,"I"_Z))) S IBPRV(IBY,IBCT,Z)=$S($P(IBD,U,Z+4)'="":$P(IBD,U,Z+4),1:$P($$DEFID^IBCEF74(IBIFN,IB),U,Z))
  1. GETQ D NEEDPRV(IBIFN,IBTYP,.IBPRV)
  1. Q
  1. ;
  1. NEEDPRV(IBIFN,IBTYP,IBPRV) ; Check for needed prov
  1. ; If needed, not entered, insert defaults for MCR only
  1. N IB0,IBINP,IBFT,IBMRAND,IBTOB
  1. S IB0=$G(^DGCR(399,+IBIFN,0))
  1. S IBFT=($$FT^IBCEF(IBIFN)=3),IBINP=$$INPAT^IBCEF(IBIFN,1),IBTOB=$$TOB^IBCBB(IB0)
  1. ; Only allow defaults for MCR
  1. S IBMRAND=$$WNRBILL^IBEFUNC(IBIFN) ;$$MCRONBIL^IBEFUNC(IBIFN)
  1. ;
  1. I IBTYP="ALL"!((IBTYP_",")["1,") D
  1. . ; DEM;432 - UB-04 or CMS-1500 SITUATIONAL
  1. . S IBPRV(1,"SITUATIONAL")=1
  1. . Q
  1. ;
  1. I IBTYP="ALL"!((IBTYP_",")["2,") D:IBFT
  1. . ; only for bill type inpt - 11X, outpt - 83X
  1. . S IBPRV(2,"SITUATIONAL")=1 ; DEM;432 - Default to "SITUATIONAL". If conditions below are met, then IBPRV(2,"SITUATIONAL") is KILLED and IBRPV is SET according to conditions.
  1. . Q:$S(IBINP:$E(IBTOB,1,2)'="11",1:$E(IBTOB,1,2)'="83")
  1. . ; UB-04 bill includes HCPCS procs - operating phys situational
  1. . N Z
  1. . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z I $P($G(^(Z,0)),U)["ICP" D Q
  1. .. K IBPRV(2,"SITUATIONAL") ; DEM;432 - We have met one of the condtions, so KILL IBPRV(2,"SITUATIONAL").
  1. .. I IBINP S IBPRV(2,"SITUATIONAL")=1 Q ; DEM;432 - If UB-04 (inpatient), then operating provider situational.
  1. .. I 'IBINP S IBPRV(2,"NOTOPT")=1 ; DEM;432 - If UB-04 (outpatient), then operating provider required.
  1. .. Q:'IBMRAND
  1. .. I '$O(IBPRV(2,0)) S IBPRV(2,"REQ")=1,IBPRV(2,1)=$G(IBPRV(2))
  1. ;
  1. I IBTYP="ALL"!((IBTYP_",")["3,") D
  1. . ; if a CMS-1500 bill, rendering is required
  1. . ; JWS;IB*2.0*592 US1108 - exclude dental form
  1. . ;I 'IBFT,$$FT^IBCEF(IBIFN)'=7 S IBPRV(3,"NOTOPT")=1 ;CHANGED THIS LINE TO THE FOLLOWING IN IB*2.0*608 - vd (US3214)
  1. . I 'IBFT,$$FT^IBCEF(IBIFN)'=7 S IBPRV(3,"SITUATIONAL")=1 ;FOR CMS-1500 RENDERING IS NO LONGER REQUIRED
  1. . ; DEM;432 - if UB-04, rendering is situational.
  1. . ; JWS;IB*2.0*592 US1108 - dental form check
  1. . I IBFT!($$FT^IBCEF(IBIFN)=7) S IBPRV(3,"SITUATIONAL")=1 Q
  1. . Q:'IBMRAND
  1. . I '$O(IBPRV(3,0)) S IBPRV(3,1)=$G(IBPRV(3)),IBPRV(3,"REQ")=1
  1. ;
  1. I IBTYP="ALL"!((IBTYP_",")["4,") D:IBFT
  1. . ; if a UB-04, attending required
  1. . S IBPRV(4,"NOTOPT")=1
  1. . Q:'IBMRAND
  1. . I '$O(IBPRV(4,0)) S IBPRV(4,1)=$G(IBPRV(4)),IBPRV(4,"REQ")=1
  1. Q
  1. ;
  1. CKPROV(IBIFN,IBTYP,IBVAL) ; Checks if prov of type IBTYP in 'PRV' node
  1. ; of bill IBIFN
  1. ; If IBVAL = 1, skips the check for an existing provider, just looks
  1. ; for existence of the function itself
  1. N OK,IBFT,Z,R
  1. S OK=0,IBFT=$$FT^IBCEF(IBIFN)
  1. S Z=+$O(^DGCR(399,IBIFN,"PRV","B",+IBTYP,0))
  1. I $G(^DGCR(399,IBIFN,"PRV",Z,0))'="" D
  1. . ; Only outpt UB-04 can have SLF000 as prov ID with no name
  1. . I IBFT=3,'$$INPAT^IBCEF(IBIFN,1),$P(^DGCR(399,IBIFN,"PRV",Z,0),U,2)="",$P(^(0),U,5)="SLF000" S OK=1 Q
  1. . I '$G(IBVAL) Q:$P(^DGCR(399,IBIFN,"PRV",Z,0),U,2)=""
  1. . S OK=1
  1. Q OK
  1. ;
  1. XFER(IBQ) ; Transfer DILIST
  1. ; IBQ = # of entries already found
  1. N Z,IBZ
  1. S (Z,IBZ)=0
  1. F S Z=$O(^TMP("DILIST",$J,1,Z)) Q:'Z S IBZ=IBZ+1,^TMP("IBLIST",$J,1,IBZ+IBQ)=^TMP("DILIST",$J,1,Z),^TMP("IBLIST",$J,2,IBZ+IBQ)=^TMP("DILIST",$J,2,Z) M ^TMP("IBLIST",$J,"ID",IBZ+IBQ)=^TMP("DILIST",$J,"ID",Z)
  1. ;
  1. I $D(^TMP("DILIST",$J,0)) S ^TMP("IBLIST",$J,0)=^TMP("DILIST",$J,0)
  1. S $P(^TMP("IBLIST",$J,0),U)=IBQ+IBZ
  1. Q
  1. ;
  1. DATE(X) ; Convert date X in YYYYMMDD or YYMMDD to FM format
  1. ; FP = flag to indicate if past or future dates are expected
  1. N %DT,Y
  1. I $L(X)=8,$E(X,1,4)<2100,$E(X,5,6)<13,$E(X,7,8)<32 S X=$E(X,1,4)-1700_$E(X,5,8) G DTQ
  1. I $L(X)=6,$E(X,3,4)<13,$E(X,5,6)<32 S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2),%DT="N" D ^%DT I Y>0 S X=Y
  1. DTQ Q X
  1. ;
  1. BCLASS(IBIFN) ; Returns actual bill classif. code from ptr fld
  1. ; .25 in file 399 for bill ien IBIFN
  1. Q $P($G(^DGCR(399.1,+$P($G(^DGCR(399,IBIFN,0)),U,25),0)),U,2)
  1. ;
  1. ADMHR(IBIFN,IBDTTM) ; Extract admit hr from admit dt/tm
  1. ; Default 00 if no time and bill is 11X or 18X
  1. N TM
  1. S TM=$P(IBDTTM,".",2)
  1. I TM="","18"[$$BCLASS(IBIFN),$P($G(^DGCR(399,IBIFN,0)),U,24)=1 S TM="00"
  1. I TM'="",TM'="00" S TM=$E(TM_"0000",1,4)
  1. Q TM
  1. ;
  1. OLAB(IBIFN) ; Returns 1 if bill IBIFN is outside lab
  1. N IBL,IBLAB
  1. S IBL=0
  1. S IBLAB=$P($G(^DGCR(399,IBIFN,"U2")),U,11)
  1. I IBLAB,"24"[IBLAB S IBL=1
  1. Q IBL
  1. ;
  1. PSRV(IBIFN) ; Returns 1 if bill IBIFN has any purch services
  1. N IBZ,IBXDATA,IBXSAVE,Z
  1. S IBZ=0
  1. D F^IBCEF("N-HCFA 1500 PROCEDURES",,,IBIFN)
  1. S Z=0 F S Z=$O(IBXSAVE("BOX24",Z)) Q:'Z I $P(IBXSAVE("BOX24",Z),U,11) S IBZ=1 Q
  1. Q IBZ
  1. ;
  1. SEQBILL(IBIFN) ; Returns the ien's of all bills in COB sequence for bill IBIFN
  1. ; Return value is "^" delimited: primary ien^secondary ien^tertiary ien
  1. N IBSEQ,Z
  1. S IBSEQ=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
  1. S Z=$$COBN^IBCEF(IBIFN)
  1. I $P(IBSEQ,U,Z)="" S $P(IBSEQ,U,Z)=IBIFN
  1. Q IBSEQ
  1. ;
  1. ;IB*2.0*432/TAZ Added to take into account the line level providers.
  1. GETPRV1(IBIFN,IBTYP,IBPRV) ; Returns prov(s) of type(s) IBTYP for
  1. ; bill ien IBIFN for TPJI display
  1. ; IBTYP = prov types needed, separated by ',' or ALL
  1. ;
  1. ; OUTPUT:
  1. ; IBPRV array: IBPRV(level,type,ct)=name^current COB id^vp provider ien^cred
  1. ;
  1. N IB,IBCT,IBD,IBY,IBZ,IBMRAND,IBID,IBWNR,IBPNM,Z,IBPRTYP
  1. D F^IBCEF("N-CURRENT INS POLICY TYPE","IBZ",,IBIFN)
  1. S IBPRV=U_$G(IBZ),IBY=0
  1. D ALLIDS^IBCEFP(IBIFN,.IBXSAVE)
  1. S IBCT=0
  1. F S IBCT=$O(IBXSAVE("PROVINF",IBIFN,"C",IBCT)) Q:'IBCT D
  1. . S IBPRTYP=""
  1. . F S IBPRTYP=$O(IBXSAVE("PROVINF",IBIFN,"C",IBCT,IBPRTYP)) Q:'IBPRTYP D
  1. .. I IBTYP'="ALL",IBTYP'[IBPRTYP Q ;Screen out unwanted providers
  1. .. N IBPRIEN,OBPRNM,IBCOBID
  1. .. S IBPRIEN=$P(IBXSAVE("PROVINF",IBIFN,"C",IBCT,IBPRTYP),U)
  1. .. S $P(IBPRV(1,IBCT,IBPRTYP),U,1)=$$EXPAND^IBTRE(399.0222,.02,IBPRIEN)
  1. .. S $P(IBPRV(1,IBCT,IBPRTYP),U,2)=IBXSAVE("PROVINF",IBIFN,"C",IBCT,IBPRTYP,"COBID")
  1. .. S $P(IBPRV(1,IBCT,IBPRTYP),U,3)=IBPRIEN
  1. .. S $P(IBPRV(1,IBCT,IBPRTYP),U,4)=$P(IBXSAVE("PROVINF",IBIFN,"C",IBCT,IBPRTYP,"NAME"),U,4)
  1. S IBCT=0
  1. F S IBCT=$O(IBXSAVE("L-PROV",IBIFN,IBCT)) Q:'IBCT D
  1. . S IBPRTYP=""
  1. . F S IBPRTYP=$O(IBXSAVE("L-PROV",IBIFN,IBCT,"C",1,IBPRTYP)) Q:'IBPRTYP D
  1. .. I IBTYP'="ALL",IBTYP'[IBPRTYP Q ;Screen out unwanted providers
  1. .. N IBPRIEN
  1. .. S IBPRIEN=$P(IBXSAVE("L-PROV",IBIFN,IBCT,"C",1,IBPRTYP),U)
  1. .. S IBPRV(2,IBCT,IBPRTYP)=$$EXPAND^IBTRE(399.0222,.02,IBPRIEN)
  1. .. S $P(IBPRV(2,IBCT,IBPRTYP),U,2)=IBXSAVE("L-PROV",IBIFN,IBCT,"C",1,IBPRTYP,"COBID")
  1. .. S $P(IBPRV(2,IBCT,IBPRTYP),U,3)=IBPRIEN
  1. .. S $P(IBPRV(2,IBCT,IBPRTYP),U,4)=$P(IBXSAVE("L-PROV",IBIFN,IBCT,"C",1,IBPRTYP,"NAME"),U,4)
  1. Q
  1. ;/IB*2.0*592
  1. RTYPOK(VAL,IBIFN) ;sceen for field 399,285 Attachment Report Type - Check for a valid Report Type depending on Claim Type
  1. ; VAL = internal value of report type file#353.3
  1. ; IBIFN = file 399 ien
  1. ;
  1. N OK,IBBT
  1. S OK=0
  1. Q:VAL="" OK
  1. Q:'IBIFN OK
  1. S IBBT=$$FT^IBCEF(IBIFN) ;2 if CMS-1500, 3 if UB-04, 7 if J430D Dental
  1. I IBBT'=7 S:VAL'="P6" OK=1 Q OK ;not a Dental Claim, periodontal charts not applicable
  1. ; following for Dental claims
  1. I "^B4^DA^DG^EB^OZ^P6^RB^RR^"[(U_VAL_U) S OK=1
  1. Q OK
  1. ; IB*2.0*592 end
  1. ;