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.
  1. IBCEFP1 ;ALB/GEF - OUTPUT FORMATTER PROVIDER UTILITIES ;28-OCT-10
  1. ;;2.0;INTEGRATED BILLING;**432**;21-MAR-94;Build 192
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. 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
  1. ; IBIFN = Claim ien
  1. ;
  1. N IBNM,IBNMC,IBGLB,IBFN,IBDT
  1. S IBGLB=$P(IBDATA,";",2),IBFN=$TR($P(IBGLB,"(",2),",","")
  1. S IBNMC=$$GET1^DIQ(IBFN,+IBDATA,.01)
  1. I $G(IBCRED)="" S IBCRED=$$CRED^IBCEU(IBDATA) ;Degree
  1. S IBDT=$S($G(IBIFN):$P($G(^DGCR(399,+IBIFN,"U")),U),1:DT) ; use statement from date
  1. I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT"
  1. I IBNMC["," D G NAMEQ
  1. . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC)
  1. . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
  1. D STDNAME^XLFNAME(.IBNMC,"C")
  1. S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
  1. ; 1= facility/group
  1. 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
  1. ;
  1. ; add specialty code
  1. NAMEQ ;
  1. I $G(IBSPEC)="" S IBSPEC=$$SPEC^IBCEU(IBDATA,IBDT)
  1. I +IBSPEC S IBSPEC=$$GET1^DIQ(42.4,IBSPEC,.01,"")
  1. S $P(IBNM,U,6)=IBSPEC
  1. Q IBNM
  1. ;
  1. TAXON(IBDATA,IBTAX) ; RETURNS taxonomy code from NEW PERSON or non/other VA BP
  1. I $G(IBTAX) S IBTAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
  1. I $G(IBTAX)="" S IBTAX=$P($$GETTAX^IBCEF73A(IBDATA),U)
  1. Q IBTAX
  1. ;
  1. NPI(IBDATA) ; look for NPI in #200 or #355.93
  1. Q $$GETNPI^IBCEF73A(IBDATA)
  1. ;
  1. CLEANUP(IBXSAVE) ; Clean up
  1. K IBXSAVE("PROVINF")
  1. K IBXSAVE("L-PROV")
  1. K IBXSAVE("LAB/FAC")
  1. K IBXSAVE("BILLING PRV")
  1. K IBXSAVE("ID")
  1. K IBXSAVE("SLPRV")
  1. K IBXSAVE("SLC")
  1. Q
  1. ;
  1. ;COBID Input
  1. ; IBIFN - IEN of Bill/Claim File
  1. ; IBTYP - Provider Type
  1. ; IBMRAND - $$MCRONBIL^IBEFUNC(IBIFN)
  1. ; IBD - Provider zero node from array.
  1. COBID(IBIFN,IBTYP,IBMRAND,IBD) ;Get COB ID
  1. N IBPROV,IBZ,IBY,IBID,IBWNR,COBID
  1. S COBID=""
  1. I $G(IBMRAND)="" S IBMRAND=$$MCRONBIL^IBEFUNC(IBIFN)
  1. D F^IBCEF("N-CURRENT INS POLICY TYPE","IBZ",,IBIFN)
  1. S IBPRV=U_$G(IBZ),IBY=0
  1. I IBMRAND D
  1. . S IBPRV(IBTYP)=$S(IBTYP=3!(IBTYP=4):"DEPT VETERANS AFFAIRS",1:"")_"^VAD000"
  1. . I '$$INPAT^IBCEF(IBIFN,1),$$FT^IBCEF(IBIFN)=3 S IBPRV(4,1)="^SLF000"
  1. S IBID=4+$$COBN^IBCEF(IBIFN),IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
  1. I '$P(IBD,U,2) G COBIDX
  1. I IBWNR G:'$D(IBPRV(IBTYP)) COBIDX S $P(IBD,U,IBID)=$P(IBPRV(IBTYP),U,2)
  1. I $P(IBD,U,IBID)'="" S COBID=$P(IBD,U,IBID) G COBIDX
  1. I $P($G(IBPRV(IBY)),U,2)'="" S COBID=$P(IBPRV(IBY),U,2) G COBIDX
  1. S COBID=$P($$DEFID(IBIFN,$P(IBD,U,2)),U,IBID-4)
  1. COBIDX ;
  1. Q COBID
  1. ;
  1. DEFID(IBIFN,IBPRV) ;
  1. ; IBIFN = ien of bill
  1. ; IBPRV = ien of entry subfile 399.0222
  1. ; Function returns default ids: prim id def^sec id def^tert id def
  1. ; SSN cannot be the default ID
  1. I $G(IBIFN)="" Q ""
  1. N Z,Z1,ID,IBZ,IBINS,IBINS4,IBUB
  1. S IBZ=""
  1. S IBUB=($$FT^IBCEF(IBIFN)=3)
  1. S Z=IBPRV,ID=$P(Z,U,5,7)
  1. F Z1=1:1:3 I $P(ID,U,Z1)="" D
  1. . Q:'$G(^DGCR(399,IBIFN,"I"_Z1))
  1. . S $P(ID,U,Z1)=$$GETID^IBCEP2(IBIFN,2,$P(Z,U,2),Z1)
  1. . ; Set default if null
  1. . I $P(ID,U,Z1)="" S $P(ID,U,Z1)="VAD000"
  1. Q ID