IBCEFP1 ;ALB/GEF - OUTPUT FORMATTER PROVIDER UTILITIES ;28-OCT-10
;;2.0;INTEGRATED BILLING;**432**;21-MAR-94;Build 192
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
NAME(IBDATA,IBIFN,IBCRED,IBSPEC) ; Parse person's nm into 6 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX^SPECIALITY
; IBDATA = IEN;GLOBAL REFERENCE of Variable Pointer
; IBIFN = Claim ien
;
N IBNM,IBNMC,IBGLB,IBFN,IBDT
S IBGLB=$P(IBDATA,";",2),IBFN=$TR($P(IBGLB,"(",2),",","")
S IBNMC=$$GET1^DIQ(IBFN,+IBDATA,.01)
I $G(IBCRED)="" S IBCRED=$$CRED^IBCEU(IBDATA) ;Degree
S IBDT=$S($G(IBIFN):$P($G(^DGCR(399,+IBIFN,"U")),U),1:DT) ; use statement from date
I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT"
I IBNMC["," D G NAMEQ
. S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC)
. S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
D STDNAME^XLFNAME(.IBNMC,"C")
S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
; 1= facility/group
I IBFN=355.93,$P($G(^IBA(355.93,+IBDATA,0)),U,2)=1 S IBNM=IBNMC_U_U_U_IBCRED_U ; group performing provider
;
; add specialty code
NAMEQ ;
I $G(IBSPEC)="" S IBSPEC=$$SPEC^IBCEU(IBDATA,IBDT)
I +IBSPEC S IBSPEC=$$GET1^DIQ(42.4,IBSPEC,.01,"")
S $P(IBNM,U,6)=IBSPEC
Q IBNM
;
TAXON(IBDATA,IBTAX) ; RETURNS taxonomy code from NEW PERSON or non/other VA BP
I $G(IBTAX) S IBTAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
I $G(IBTAX)="" S IBTAX=$P($$GETTAX^IBCEF73A(IBDATA),U)
Q IBTAX
;
NPI(IBDATA) ; look for NPI in #200 or #355.93
Q $$GETNPI^IBCEF73A(IBDATA)
;
CLEANUP(IBXSAVE) ; Clean up
K IBXSAVE("PROVINF")
K IBXSAVE("L-PROV")
K IBXSAVE("LAB/FAC")
K IBXSAVE("BILLING PRV")
K IBXSAVE("ID")
K IBXSAVE("SLPRV")
K IBXSAVE("SLC")
Q
;
;COBID Input
; IBIFN - IEN of Bill/Claim File
; IBTYP - Provider Type
; IBMRAND - $$MCRONBIL^IBEFUNC(IBIFN)
; IBD - Provider zero node from array.
COBID(IBIFN,IBTYP,IBMRAND,IBD) ;Get COB ID
N IBPROV,IBZ,IBY,IBID,IBWNR,COBID
S COBID=""
I $G(IBMRAND)="" S IBMRAND=$$MCRONBIL^IBEFUNC(IBIFN)
D F^IBCEF("N-CURRENT INS POLICY TYPE","IBZ",,IBIFN)
S IBPRV=U_$G(IBZ),IBY=0
I IBMRAND D
. S IBPRV(IBTYP)=$S(IBTYP=3!(IBTYP=4):"DEPT VETERANS AFFAIRS",1:"")_"^VAD000"
. I '$$INPAT^IBCEF(IBIFN,1),$$FT^IBCEF(IBIFN)=3 S IBPRV(4,1)="^SLF000"
S IBID=4+$$COBN^IBCEF(IBIFN),IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
I '$P(IBD,U,2) G COBIDX
I IBWNR G:'$D(IBPRV(IBTYP)) COBIDX S $P(IBD,U,IBID)=$P(IBPRV(IBTYP),U,2)
I $P(IBD,U,IBID)'="" S COBID=$P(IBD,U,IBID) G COBIDX
I $P($G(IBPRV(IBY)),U,2)'="" S COBID=$P(IBPRV(IBY),U,2) G COBIDX
S COBID=$P($$DEFID(IBIFN,$P(IBD,U,2)),U,IBID-4)
COBIDX ;
Q COBID
;
DEFID(IBIFN,IBPRV) ;
; IBIFN = ien of bill
; IBPRV = ien of entry subfile 399.0222
; Function returns default ids: prim id def^sec id def^tert id def
; SSN cannot be the default ID
I $G(IBIFN)="" Q ""
N Z,Z1,ID,IBZ,IBINS,IBINS4,IBUB
S IBZ=""
S IBUB=($$FT^IBCEF(IBIFN)=3)
S Z=IBPRV,ID=$P(Z,U,5,7)
F Z1=1:1:3 I $P(ID,U,Z1)="" D
. Q:'$G(^DGCR(399,IBIFN,"I"_Z1))
. S $P(ID,U,Z1)=$$GETID^IBCEP2(IBIFN,2,$P(Z,U,2),Z1)
. ; Set default if null
. I $P(ID,U,Z1)="" S $P(ID,U,Z1)="VAD000"
Q ID
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFP1 3268 printed Apr 09, 2024@21:16:16 Page 2
IBCEFP1 ;ALB/GEF - OUTPUT FORMATTER PROVIDER UTILITIES ;28-OCT-10
+1 ;;2.0;INTEGRATED BILLING;**432**;21-MAR-94;Build 192
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
NAME(IBDATA,IBIFN,IBCRED,IBSPEC) ; Parse person's nm into 6 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX^SPECIALITY
+1 ; IBDATA = IEN;GLOBAL REFERENCE of Variable Pointer
+2 ; IBIFN = Claim ien
+3 ;
+4 NEW IBNM,IBNMC,IBGLB,IBFN,IBDT
+5 SET IBGLB=$PIECE(IBDATA,";",2)
SET IBFN=$TRANSLATE($PIECE(IBGLB,"(",2),",","")
+6 SET IBNMC=$$GET1^DIQ(IBFN,+IBDATA,.01)
+7 ;Degree
IF $GET(IBCRED)=""
SET IBCRED=$$CRED^IBCEU(IBDATA)
+8 ; use statement from date
SET IBDT=$SELECT($GET(IBIFN):$PIECE($GET(^DGCR(399,+IBIFN,"U")),U),1:DT)
+9 IF IBNMC="DEPT VETERANS AFFAIRS"
SET IBNMC="VETERANS AFFAIRS,DEPT"
+10 IF IBNMC[","
Begin DoDot:1
+11 SET IBNMC=$TRANSLATE(IBNMC,".")
DO NAMECOMP^XLFNAME(.IBNMC)
+12 SET IBNM=$GET(IBNMC("FAMILY"))_U_$GET(IBNMC("GIVEN"))_U_$GET(IBNMC("MIDDLE"))_U_IBCRED_U_$GET(IBNMC("SUFFIX"))
End DoDot:1
GOTO NAMEQ
+13 DO STDNAME^XLFNAME(.IBNMC,"C")
+14 SET IBNM=$GET(IBNMC("FAMILY"))_U_$GET(IBNMC("GIVEN"))_U_$GET(IBNMC("MIDDLE"))_U_IBCRED_U_$GET(IBNMC("SUFFIX"))
+15 ; 1= facility/group
+16 ; group performing provider
IF IBFN=355.93
IF $PIECE($GET(^IBA(355.93,+IBDATA,0)),U,2)=1
SET IBNM=IBNMC_U_U_U_IBCRED_U
+17 ;
+18 ; add specialty code
NAMEQ ;
+1 IF $GET(IBSPEC)=""
SET IBSPEC=$$SPEC^IBCEU(IBDATA,IBDT)
+2 IF +IBSPEC
SET IBSPEC=$$GET1^DIQ(42.4,IBSPEC,.01,"")
+3 SET $PIECE(IBNM,U,6)=IBSPEC
+4 QUIT IBNM
+5 ;
TAXON(IBDATA,IBTAX) ; RETURNS taxonomy code from NEW PERSON or non/other VA BP
+1 IF $GET(IBTAX)
SET IBTAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
+2 IF $GET(IBTAX)=""
SET IBTAX=$PIECE($$GETTAX^IBCEF73A(IBDATA),U)
+3 QUIT IBTAX
+4 ;
NPI(IBDATA) ; look for NPI in #200 or #355.93
+1 QUIT $$GETNPI^IBCEF73A(IBDATA)
+2 ;
CLEANUP(IBXSAVE) ; Clean up
+1 KILL IBXSAVE("PROVINF")
+2 KILL IBXSAVE("L-PROV")
+3 KILL IBXSAVE("LAB/FAC")
+4 KILL IBXSAVE("BILLING PRV")
+5 KILL IBXSAVE("ID")
+6 KILL IBXSAVE("SLPRV")
+7 KILL IBXSAVE("SLC")
+8 QUIT
+9 ;
+10 ;COBID Input
+11 ; IBIFN - IEN of Bill/Claim File
+12 ; IBTYP - Provider Type
+13 ; IBMRAND - $$MCRONBIL^IBEFUNC(IBIFN)
+14 ; IBD - Provider zero node from array.
COBID(IBIFN,IBTYP,IBMRAND,IBD) ;Get COB ID
+1 NEW IBPROV,IBZ,IBY,IBID,IBWNR,COBID
+2 SET COBID=""
+3 IF $GET(IBMRAND)=""
SET IBMRAND=$$MCRONBIL^IBEFUNC(IBIFN)
+4 DO F^IBCEF("N-CURRENT INS POLICY TYPE","IBZ",,IBIFN)
+5 SET IBPRV=U_$GET(IBZ)
SET IBY=0
+6 IF IBMRAND
Begin DoDot:1
+7 SET IBPRV(IBTYP)=$SELECT(IBTYP=3!(IBTYP=4):"DEPT VETERANS AFFAIRS",1:"")_"^VAD000"
+8 IF '$$INPAT^IBCEF(IBIFN,1)
IF $$FT^IBCEF(IBIFN)=3
SET IBPRV(4,1)="^SLF000"
End DoDot:1
+9 SET IBID=4+$$COBN^IBCEF(IBIFN)
SET IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
+10 IF '$PIECE(IBD,U,2)
GOTO COBIDX
+11 IF IBWNR
if '$DATA(IBPRV(IBTYP))
GOTO COBIDX
SET $PIECE(IBD,U,IBID)=$PIECE(IBPRV(IBTYP),U,2)
+12 IF $PIECE(IBD,U,IBID)'=""
SET COBID=$PIECE(IBD,U,IBID)
GOTO COBIDX
+13 IF $PIECE($GET(IBPRV(IBY)),U,2)'=""
SET COBID=$PIECE(IBPRV(IBY),U,2)
GOTO COBIDX
+14 SET COBID=$PIECE($$DEFID(IBIFN,$PIECE(IBD,U,2)),U,IBID-4)
COBIDX ;
+1 QUIT COBID
+2 ;
DEFID(IBIFN,IBPRV) ;
+1 ; IBIFN = ien of bill
+2 ; IBPRV = ien of entry subfile 399.0222
+3 ; Function returns default ids: prim id def^sec id def^tert id def
+4 ; SSN cannot be the default ID
+5 IF $GET(IBIFN)=""
QUIT ""
+6 NEW Z,Z1,ID,IBZ,IBINS,IBINS4,IBUB
+7 SET IBZ=""
+8 SET IBUB=($$FT^IBCEF(IBIFN)=3)
+9 SET Z=IBPRV
SET ID=$PIECE(Z,U,5,7)
+10 FOR Z1=1:1:3
IF $PIECE(ID,U,Z1)=""
Begin DoDot:1
+11 if '$GET(^DGCR(399,IBIFN,"I"_Z1))
QUIT
+12 SET $PIECE(ID,U,Z1)=$$GETID^IBCEP2(IBIFN,2,$PIECE(Z,U,2),Z1)
+13 ; Set default if null
+14 IF $PIECE(ID,U,Z1)=""
SET $PIECE(ID,U,Z1)="VAD000"
End DoDot:1
+15 QUIT ID
