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

IBCEF83.m

Go to the documentation of this file.
  1. IBCEF83 ;ALB/BI - GET PROVIDER FUNCTIONS ;26-OCT-2010
  1. ;;2.0;INTEGRATED BILLING;**432,488**;21-MAR-94;Build 184
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. ;
  1. GETPRV(IBIEN,CPST,IBPRTYP,IBITEM) ; MAIN ENTRY POINT.
  1. ; INPUTS: IBIEN - INTERNAL BILLING/CLAIM NUMBER.
  1. ;
  1. ; CPST - INSURANCE LEVEL: C = CURRENT(DEFAULT),
  1. ; P = PRIMARY,
  1. ; S = SECONDARY,
  1. ; T = TERTIARY.
  1. ;
  1. ; IBPRTYPE - PROVIDER TYPE: 1 = REFERRING,
  1. ; 2 = OPERATING,
  1. ; 3 = RENDERING,
  1. ; 4 = ATTENDING,
  1. ; 5 = SUPERVISING,
  1. ; 9 = OTHER OPERATING.
  1. ;
  1. ; IBITEM - ITEM REQUESTED: A0 = PROVIDER VARIABLE POINTER
  1. ; A1 = PROVIDER FULL NAME
  1. ; A2 = PROVIDER LAST NAME
  1. ; A3 = PROVIDER FIRST NAME
  1. ; A4 = PROVIDER MIDDLE NAME
  1. ; A5 = PROVIDER SUFFIX
  1. ; A6 = PROVIDER CREDENTIALS
  1. ; A7 = PROVIDER CURRENT COB ID
  1. ; A8 =
  1. ; A9 =
  1. ;
  1. ; B1 = PROVIDER QUALIFIER
  1. ; B2 = PROVIDER ID
  1. ; B3 = PROVIDER NPI
  1. ;
  1. ; C1 = REVENUE CODE LINE COUNT (SLC)
  1. ;
  1. ; RETURN: SPECIFIC REQUESTED DATA ELEMENT.
  1. ;
  1. N CPSTDATA,IBDATA,ACTION
  1. I $D(IBIEN)=0 Q ""
  1. I '$G(IBXFORM) N IBXPROV
  1. I $D(IBXPROV("CPST",IBIEN))=0 D
  1. . K IBXPROV
  1. . D ALLIDS^IBCEFP(IBIEN,.IBXPROV)
  1. . D CPSTINDX
  1. I (($G(IBPRTYP)="")!($G(IBITEM)="")) Q ""
  1. I $G(CPST)="" S CPST="C"
  1. S CPSTDATA=$G(IBXPROV("CPST",IBIEN,CPST))
  1. I CPSTDATA="" Q ""
  1. M IBDATA=IBXPROV("PROVINF",IBIEN,$P(CPSTDATA,U,1),$P(CPSTDATA,U,2),IBPRTYP)
  1. ;I ((IBPRTYP=3)!(IBPRTYP=4)),$$MCRONBIL^IBEFUNC(IBIEN) D MCRONBIL
  1. I $D(IBDATA)=0 Q ""
  1. S ACTION="IBX"_IBITEM
  1. I $T(@ACTION)="" Q ""
  1. Q $$@ACTION
  1. ;
  1. CPSTINDX ; CREATE THE CPST INDEX FOR PROCESSING
  1. N IBMODE,IBN
  1. I $D(IBXPROV("PROVINF","C",1)) S IBXPROV("CPST",IBIEN,"C")="C"_U_"1"
  1. S IBMODE="" F S IBMODE=$O(IBXPROV("PROVINF",IBIEN,IBMODE)) Q:IBMODE="" D
  1. . S IBN="" F S IBN=$O(IBXPROV("PROVINF",IBIEN,IBMODE,IBN)) Q:IBN="" D
  1. .. I $G(IBXPROV("PROVINF",IBIEN,IBMODE,IBN))="" Q
  1. .. I IBXPROV("PROVINF",IBIEN,IBMODE,IBN)="P" D
  1. ... S IBXPROV("CPST",IBIEN,"P")=IBMODE_U_IBN
  1. ... I $D(IBXPROV("CPST",IBIEN,"C"))=0 S IBXPROV("CPST",IBIEN,"C")=IBMODE_U_IBN
  1. .. I IBXPROV("PROVINF",IBIEN,IBMODE,IBN)="S" D
  1. ... S IBXPROV("CPST",IBIEN,"S")=IBMODE_U_IBN
  1. ... I $D(IBXPROV("CPST",IBIEN,"C"))=0 S IBXPROV("CPST",IBIEN,"C")=IBMODE_U_IBN
  1. .. I IBXPROV("PROVINF",IBIEN,IBMODE,IBN)="T" D
  1. ... S IBXPROV("CPST",IBIEN,"T")=IBMODE_U_IBN
  1. ... I $D(IBXPROV("CPST",IBIEN,"C"))=0 S IBXPROV("CPST",IBIEN,"C")=IBMODE_U_IBN
  1. Q
  1. ;
  1. IBXA0() ; PROVIDER VARIABLE POINTER
  1. Q $P(IBDATA,U,1)
  1. ;
  1. IBXA1() ; PROVIDER FULL NAME
  1. N X S X=""
  1. I X="",$$IBXA2'="" D
  1. . S X=$$IBXA2
  1. . S:$$IBXA3'="" X=X_","_$$IBXA3
  1. . S:$$IBXA4'="" X=X_" "_$$IBXA4
  1. . S:$$IBXA5'="" X=X_" "_$$IBXA5
  1. I X="" S X=$$EXPAND^IBTRE(399.0222,.02,$$IBXA0)
  1. Q X
  1. ;
  1. IBXA2() ; PROVIDER LAST NAME
  1. N X S X=""
  1. S X=$P($G(IBDATA("NAME")),U,1)
  1. Q X
  1. ;
  1. IBXA3() ; PROVIDER FIRST NAME
  1. N X S X=""
  1. S X=$P($G(IBDATA("NAME")),U,2)
  1. Q X
  1. ;
  1. IBXA4() ; PROVIDER MIDDLE NAME
  1. N X S X=""
  1. S X=$P($G(IBDATA("NAME")),U,3)
  1. Q X
  1. ;
  1. IBXA5() ; PROVIDER SUFFIX
  1. N X S X=""
  1. S X=$P($G(IBDATA("NAME")),U,5)
  1. Q X
  1. ;
  1. IBXA6() ; PROVIDER CREDENTIALS
  1. N X S X=""
  1. S X=$P($G(IBDATA("NAME")),U,4)
  1. I X="" S X=$$CRED^IBCEU($$IBXA0)
  1. Q X
  1. ;
  1. IBXA7() ; PROVIDER CURRENT COB ID
  1. N X S X=""
  1. I X="" S X=$P($G(IBDATA("COBID")),U,1)
  1. Q X
  1. ;
  1. IBXB1() ; PROVIDER QUALIFIER
  1. N X S X=""
  1. S X=$P($G(IBDATA(1)),U,3)
  1. Q X
  1. ;
  1. IBXB2() ; PROVIDER ID
  1. N X S X=""
  1. S X=$P($G(IBDATA(1)),U,4)
  1. Q X
  1. ;
  1. IBXB3() ; PROVIDER NPI
  1. N X S X=""
  1. S X=$P($G(IBDATA(0)),U,4)
  1. Q X
  1. ;
  1. IBXC1() ; CLAIM LINE COUNT
  1. N X S X=""
  1. S X=$P($G(IBXPROV("SLC")),U,1)
  1. Q X
  1. ;
  1. CMSBOX24(IBIEN,IBXIJ,IBXDATA) ; PROVIDER QUALIFIER or PROVIDER ID and PROVIDER NPI FOR CMS-1500 BOX J
  1. ;
  1. ; IBIEN = CLAIM/BILL INTERNAL NUMBER
  1. ; IBXIJ = "I" for COLUMN I or "J" for COLUMN J
  1. ; IBXDATA = RETURN DATA ARRAY
  1. ;
  1. K IBXDATA
  1. I $G(IBIEN)="" Q
  1. I $G(IBXIJ)="" Q
  1. I '$G(IBXFORM) N IBXFORM S IBXFORM=99
  1. N CLINE,X,IBREND,CPLNK,IBXDCNT
  1. S X=$$GETPRV(IBIEN)
  1. I $D(IBXPROV("CMBX24IX"))=0 D CMBX24IX
  1. S IBXDCNT=0
  1. S CLINE=0 F S CLINE=$O(IBXSAVE("BOX24",CLINE)) Q:+CLINE=0 D
  1. . ;S CPLNK=$G(IBXSAVE("BOX24",CLINE,"CPLNK")) Q:CPLNK="" ;WCJ;IB*488;this is just plain wrong. It does not need to grab CPLNK.
  1. . ;S IBREND=$P($G(IBXPROV("L-PROV",IBIEN,CPLNK,"C",1,3)),U,1) ;WCJ;IB*488;IBXPROV array is subscipted by the SLC (Service Line Counter)
  1. . S IBREND=$P($G(IBXPROV("L-PROV",IBIEN,CLINE,"C",1,3)),U,1) ; WCJ;IB*488;used CLINE instead of CPLNK
  1. . I IBREND'="" S IBREND=$G(IBXPROV("CMBX24IX",IBREND))
  1. . I IBREND="" S IBREND=$G(IBXPROV("CMBX24IX","CLAIM"))
  1. . S:IBXIJ="I" IBXDCNT=IBXDCNT+1,IBXDATA(IBXDCNT)=$P(IBREND,U,2)
  1. . S:IBXIJ="I" IBXDCNT=IBXDCNT+1,IBXDATA(IBXDCNT)=""
  1. . S:IBXIJ="J" IBXDCNT=IBXDCNT+1,IBXDATA(IBXDCNT)=$P(IBREND,U,3)
  1. . S:IBXIJ="J" IBXDCNT=IBXDCNT+1,IBXDATA(IBXDCNT)=$P(IBREND,U,1)
  1. I IBXFORM=99 K IBXPROV
  1. Q
  1. ;
  1. CMBX24IX ; PROVIDER INDEX FOR CMS-1500 BOX I and J.
  1. N SLC,IBXPTR
  1. S SLC=0 F S SLC=$O(IBXPROV("L-PROV",IBIEN,SLC)) Q:+SLC=0 D
  1. . S IBXPTR=$P($G(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3)),U,1)
  1. . Q:IBXPTR=""
  1. . S IBXPROV("CMBX24IX",IBXPTR)=""
  1. . S IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$P($G(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3,0)),U,4)_U ; PROVIDER NPI
  1. . S IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$P($G(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3,1)),U,3)_U ; PROVIDER QUALIFIER
  1. . S IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$P($G(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3,1)),U,4) ; PROVIDER ID
  1. S IBXPTR=$P($G(IBXPROV("PROVINF",IBIEN,"C",1,3)),U,1)
  1. Q:IBXPTR=""
  1. S IBXPROV("CMBX24IX",IBXPTR)=""
  1. S IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$P($G(IBXPROV("PROVINF",IBIEN,"C",1,3,0)),U,4)_U ; PROVIDER NPI
  1. S IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$P($G(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,3)_U ; PROVIDER QUALIFIER
  1. S IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$P($G(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,4) ; PROVIDER ID
  1. S IBXPROV("CMBX24IX","CLAIM")=""
  1. S IBXPROV("CMBX24IX","CLAIM")=IBXPROV("CMBX24IX","CLAIM")_$P($G(IBXPROV("PROVINF",IBIEN,"C",1,3,0)),U,4)_U ; PROVIDER NPI
  1. S IBXPROV("CMBX24IX","CLAIM")=IBXPROV("CMBX24IX","CLAIM")_$P($G(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,3)_U ; PROVIDER QUALIFIER
  1. S IBXPROV("CMBX24IX","CLAIM")=IBXPROV("CMBX24IX","CLAIM")_$P($G(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,4) ; PROVIDER ID
  1. Q
  1. ;
  1. MCRONBIL ; DEFAULT NAME and COB ID.
  1. S $P(IBDATA,U,1)=""
  1. S $P(IBDATA("NAME"),U,1)="DEPT VETERANS AFFAIRS"
  1. S $P(IBDATA("NAME"),U,2)=""
  1. S $P(IBDATA("NAME"),U,3)=""
  1. S $P(IBDATA("NAME"),U,4)=""
  1. S $P(IBDATA("NAME"),U,5)=""
  1. S $P(IBDATA("COBID"),U,1)="VAD000"
  1. Q
  1. ;
  1. UB047879(IBXIEN,X) ; LOAD X ARRAY WITH THE DATA FOR UB FIELD 78 AND 79.
  1. N Y
  1. K X S X(1)="",X(2)=""
  1. F Y=9,1,3 Q:X(2)'="" D
  1. . I X(1)'="" S X(2)=$$GETPRV(IBXIEN,,Y,"A1") Q:X(2)="" D
  1. .. I X(1)'="" S X(2)=X(2)_"^"_$$GETPRV(IBXIEN,,Y,"B1")
  1. .. I X(1)'="" S X(2)=X(2)_"^"_$$GETPRV(IBXIEN,,Y,"B2")
  1. .. I X(1)'="" S X(2)=X(2)_"^"_$$GETPRV(IBXIEN,,Y,"B3")
  1. . Q:X(1)'=""
  1. . S X(1)=$$GETPRV(IBXIEN,,Y,"A1") Q:X(1)=""
  1. . S X(1)=X(1)_"^"_$$GETPRV(IBXIEN,,Y,"B1")
  1. . S X(1)=X(1)_"^"_$$GETPRV(IBXIEN,,Y,"B2")
  1. . S X(1)=X(1)_"^"_$$GETPRV(IBXIEN,,Y,"B3")
  1. Q
  1. ;
  1. PRQUAL(IBXIEN) ;Get provider qualifier. Add with *488*
  1. N IBPQ
  1. S IBPQ=$$GETPRV(IBXIEN,,1,"A1")
  1. I IBPQ'="" S IBPQ="DN"
  1. I IBPQ="" D
  1. .S IBPQ=$$GETPRV(IBXIEN,,5,"A1")
  1. .I IBPQ'="" S IBPQ="DQ"
  1. Q IBPQ
  1. ;
  1. PROVNM(IBXIEN) ;Get Ref provider if not avail check for Sup provider. Add with *488*
  1. N IBPR
  1. S IBPR=$$GETPRV(IBXIEN,,1,"A1")
  1. I IBPR="" S IBPR=$$GETPRV(IBXIEN,,5,"A1")
  1. Q IBPR