- 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 Feb 18, 2025@23:38:55 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 ;