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

IBCEFP1.m

Go to the documentation of this file.
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