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