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