- 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 Jan 18, 2025@03:11:53 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