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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF83 8541 printed Oct 16, 2024@18:11:05 Page 2
IBCEF83 ;ALB/BI - GET PROVIDER FUNCTIONS ;26-OCT-2010
+1 ;;2.0;INTEGRATED BILLING;**432,488**;21-MAR-94;Build 184
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
GETPRV(IBIEN,CPST,IBPRTYP,IBITEM) ; MAIN ENTRY POINT.
+1 ; INPUTS: IBIEN - INTERNAL BILLING/CLAIM NUMBER.
+2 ;
+3 ; CPST - INSURANCE LEVEL: C = CURRENT(DEFAULT),
+4 ; P = PRIMARY,
+5 ; S = SECONDARY,
+6 ; T = TERTIARY.
+7 ;
+8 ; IBPRTYPE - PROVIDER TYPE: 1 = REFERRING,
+9 ; 2 = OPERATING,
+10 ; 3 = RENDERING,
+11 ; 4 = ATTENDING,
+12 ; 5 = SUPERVISING,
+13 ; 9 = OTHER OPERATING.
+14 ;
+15 ; IBITEM - ITEM REQUESTED: A0 = PROVIDER VARIABLE POINTER
+16 ; A1 = PROVIDER FULL NAME
+17 ; A2 = PROVIDER LAST NAME
+18 ; A3 = PROVIDER FIRST NAME
+19 ; A4 = PROVIDER MIDDLE NAME
+20 ; A5 = PROVIDER SUFFIX
+21 ; A6 = PROVIDER CREDENTIALS
+22 ; A7 = PROVIDER CURRENT COB ID
+23 ; A8 =
+24 ; A9 =
+25 ;
+26 ; B1 = PROVIDER QUALIFIER
+27 ; B2 = PROVIDER ID
+28 ; B3 = PROVIDER NPI
+29 ;
+30 ; C1 = REVENUE CODE LINE COUNT (SLC)
+31 ;
+32 ; RETURN: SPECIFIC REQUESTED DATA ELEMENT.
+33 ;
+34 NEW CPSTDATA,IBDATA,ACTION
+35 IF $DATA(IBIEN)=0
QUIT ""
+36 IF '$GET(IBXFORM)
NEW IBXPROV
+37 IF $DATA(IBXPROV("CPST",IBIEN))=0
Begin DoDot:1
+38 KILL IBXPROV
+39 DO ALLIDS^IBCEFP(IBIEN,.IBXPROV)
+40 DO CPSTINDX
End DoDot:1
+41 IF (($GET(IBPRTYP)="")!($GET(IBITEM)=""))
QUIT ""
+42 IF $GET(CPST)=""
SET CPST="C"
+43 SET CPSTDATA=$GET(IBXPROV("CPST",IBIEN,CPST))
+44 IF CPSTDATA=""
QUIT ""
+45 MERGE IBDATA=IBXPROV("PROVINF",IBIEN,$PIECE(CPSTDATA,U,1),$PIECE(CPSTDATA,U,2),IBPRTYP)
+46 ;I ((IBPRTYP=3)!(IBPRTYP=4)),$$MCRONBIL^IBEFUNC(IBIEN) D MCRONBIL
+47 IF $DATA(IBDATA)=0
QUIT ""
+48 SET ACTION="IBX"_IBITEM
+49 IF $TEXT(@ACTION)=""
QUIT ""
+50 QUIT $$@ACTION
+51 ;
CPSTINDX ; CREATE THE CPST INDEX FOR PROCESSING
+1 NEW IBMODE,IBN
+2 IF $DATA(IBXPROV("PROVINF","C",1))
SET IBXPROV("CPST",IBIEN,"C")="C"_U_"1"
+3 SET IBMODE=""
FOR
SET IBMODE=$ORDER(IBXPROV("PROVINF",IBIEN,IBMODE))
if IBMODE=""
QUIT
Begin DoDot:1
+4 SET IBN=""
FOR
SET IBN=$ORDER(IBXPROV("PROVINF",IBIEN,IBMODE,IBN))
if IBN=""
QUIT
Begin DoDot:2
+5 IF $GET(IBXPROV("PROVINF",IBIEN,IBMODE,IBN))=""
QUIT
+6 IF IBXPROV("PROVINF",IBIEN,IBMODE,IBN)="P"
Begin DoDot:3
+7 SET IBXPROV("CPST",IBIEN,"P")=IBMODE_U_IBN
+8 IF $DATA(IBXPROV("CPST",IBIEN,"C"))=0
SET IBXPROV("CPST",IBIEN,"C")=IBMODE_U_IBN
End DoDot:3
+9 IF IBXPROV("PROVINF",IBIEN,IBMODE,IBN)="S"
Begin DoDot:3
+10 SET IBXPROV("CPST",IBIEN,"S")=IBMODE_U_IBN
+11 IF $DATA(IBXPROV("CPST",IBIEN,"C"))=0
SET IBXPROV("CPST",IBIEN,"C")=IBMODE_U_IBN
End DoDot:3
+12 IF IBXPROV("PROVINF",IBIEN,IBMODE,IBN)="T"
Begin DoDot:3
+13 SET IBXPROV("CPST",IBIEN,"T")=IBMODE_U_IBN
+14 IF $DATA(IBXPROV("CPST",IBIEN,"C"))=0
SET IBXPROV("CPST",IBIEN,"C")=IBMODE_U_IBN
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
IBXA0() ; PROVIDER VARIABLE POINTER
+1 QUIT $PIECE(IBDATA,U,1)
+2 ;
IBXA1() ; PROVIDER FULL NAME
+1 NEW X
SET X=""
+2 IF X=""
IF $$IBXA2'=""
Begin DoDot:1
+3 SET X=$$IBXA2
+4 if $$IBXA3'=""
SET X=X_","_$$IBXA3
+5 if $$IBXA4'=""
SET X=X_" "_$$IBXA4
+6 if $$IBXA5'=""
SET X=X_" "_$$IBXA5
End DoDot:1
+7 IF X=""
SET X=$$EXPAND^IBTRE(399.0222,.02,$$IBXA0)
+8 QUIT X
+9 ;
IBXA2() ; PROVIDER LAST NAME
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA("NAME")),U,1)
+3 QUIT X
+4 ;
IBXA3() ; PROVIDER FIRST NAME
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA("NAME")),U,2)
+3 QUIT X
+4 ;
IBXA4() ; PROVIDER MIDDLE NAME
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA("NAME")),U,3)
+3 QUIT X
+4 ;
IBXA5() ; PROVIDER SUFFIX
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA("NAME")),U,5)
+3 QUIT X
+4 ;
IBXA6() ; PROVIDER CREDENTIALS
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA("NAME")),U,4)
+3 IF X=""
SET X=$$CRED^IBCEU($$IBXA0)
+4 QUIT X
+5 ;
IBXA7() ; PROVIDER CURRENT COB ID
+1 NEW X
SET X=""
+2 IF X=""
SET X=$PIECE($GET(IBDATA("COBID")),U,1)
+3 QUIT X
+4 ;
IBXB1() ; PROVIDER QUALIFIER
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA(1)),U,3)
+3 QUIT X
+4 ;
IBXB2() ; PROVIDER ID
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA(1)),U,4)
+3 QUIT X
+4 ;
IBXB3() ; PROVIDER NPI
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBDATA(0)),U,4)
+3 QUIT X
+4 ;
IBXC1() ; CLAIM LINE COUNT
+1 NEW X
SET X=""
+2 SET X=$PIECE($GET(IBXPROV("SLC")),U,1)
+3 QUIT X
+4 ;
CMSBOX24(IBIEN,IBXIJ,IBXDATA) ; PROVIDER QUALIFIER or PROVIDER ID and PROVIDER NPI FOR CMS-1500 BOX J
+1 ;
+2 ; IBIEN = CLAIM/BILL INTERNAL NUMBER
+3 ; IBXIJ = "I" for COLUMN I or "J" for COLUMN J
+4 ; IBXDATA = RETURN DATA ARRAY
+5 ;
+6 KILL IBXDATA
+7 IF $GET(IBIEN)=""
QUIT
+8 IF $GET(IBXIJ)=""
QUIT
+9 IF '$GET(IBXFORM)
NEW IBXFORM
SET IBXFORM=99
+10 NEW CLINE,X,IBREND,CPLNK,IBXDCNT
+11 SET X=$$GETPRV(IBIEN)
+12 IF $DATA(IBXPROV("CMBX24IX"))=0
DO CMBX24IX
+13 SET IBXDCNT=0
+14 SET CLINE=0
FOR
SET CLINE=$ORDER(IBXSAVE("BOX24",CLINE))
if +CLINE=0
QUIT
Begin DoDot:1
+15 ;S CPLNK=$G(IBXSAVE("BOX24",CLINE,"CPLNK")) Q:CPLNK="" ;WCJ;IB*488;this is just plain wrong. It does not need to grab CPLNK.
+16 ;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)
+17 ; WCJ;IB*488;used CLINE instead of CPLNK
SET IBREND=$PIECE($GET(IBXPROV("L-PROV",IBIEN,CLINE,"C",1,3)),U,1)
+18 IF IBREND'=""
SET IBREND=$GET(IBXPROV("CMBX24IX",IBREND))
+19 IF IBREND=""
SET IBREND=$GET(IBXPROV("CMBX24IX","CLAIM"))
+20 if IBXIJ="I"
SET IBXDCNT=IBXDCNT+1
SET IBXDATA(IBXDCNT)=$PIECE(IBREND,U,2)
+21 if IBXIJ="I"
SET IBXDCNT=IBXDCNT+1
SET IBXDATA(IBXDCNT)=""
+22 if IBXIJ="J"
SET IBXDCNT=IBXDCNT+1
SET IBXDATA(IBXDCNT)=$PIECE(IBREND,U,3)
+23 if IBXIJ="J"
SET IBXDCNT=IBXDCNT+1
SET IBXDATA(IBXDCNT)=$PIECE(IBREND,U,1)
End DoDot:1
+24 IF IBXFORM=99
KILL IBXPROV
+25 QUIT
+26 ;
CMBX24IX ; PROVIDER INDEX FOR CMS-1500 BOX I and J.
+1 NEW SLC,IBXPTR
+2 SET SLC=0
FOR
SET SLC=$ORDER(IBXPROV("L-PROV",IBIEN,SLC))
if +SLC=0
QUIT
Begin DoDot:1
+3 SET IBXPTR=$PIECE($GET(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3)),U,1)
+4 if IBXPTR=""
QUIT
+5 SET IBXPROV("CMBX24IX",IBXPTR)=""
+6 ; PROVIDER NPI
SET IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$PIECE($GET(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3,0)),U,4)_U
+7 ; PROVIDER QUALIFIER
SET IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$PIECE($GET(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3,1)),U,3)_U
+8 ; PROVIDER ID
SET IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$PIECE($GET(IBXPROV("L-PROV",IBIEN,SLC,"C",1,3,1)),U,4)
End DoDot:1
+9 SET IBXPTR=$PIECE($GET(IBXPROV("PROVINF",IBIEN,"C",1,3)),U,1)
+10 if IBXPTR=""
QUIT
+11 SET IBXPROV("CMBX24IX",IBXPTR)=""
+12 ; PROVIDER NPI
SET IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$PIECE($GET(IBXPROV("PROVINF",IBIEN,"C",1,3,0)),U,4)_U
+13 ; PROVIDER QUALIFIER
SET IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$PIECE($GET(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,3)_U
+14 ; PROVIDER ID
SET IBXPROV("CMBX24IX",IBXPTR)=IBXPROV("CMBX24IX",IBXPTR)_$PIECE($GET(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,4)
+15 SET IBXPROV("CMBX24IX","CLAIM")=""
+16 ; PROVIDER NPI
SET IBXPROV("CMBX24IX","CLAIM")=IBXPROV("CMBX24IX","CLAIM")_$PIECE($GET(IBXPROV("PROVINF",IBIEN,"C",1,3,0)),U,4)_U
+17 ; PROVIDER QUALIFIER
SET IBXPROV("CMBX24IX","CLAIM")=IBXPROV("CMBX24IX","CLAIM")_$PIECE($GET(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,3)_U
+18 ; PROVIDER ID
SET IBXPROV("CMBX24IX","CLAIM")=IBXPROV("CMBX24IX","CLAIM")_$PIECE($GET(IBXPROV("PROVINF",IBIEN,"C",1,3,1)),U,4)
+19 QUIT
+20 ;
MCRONBIL ; DEFAULT NAME and COB ID.
+1 SET $PIECE(IBDATA,U,1)=""
+2 SET $PIECE(IBDATA("NAME"),U,1)="DEPT VETERANS AFFAIRS"
+3 SET $PIECE(IBDATA("NAME"),U,2)=""
+4 SET $PIECE(IBDATA("NAME"),U,3)=""
+5 SET $PIECE(IBDATA("NAME"),U,4)=""
+6 SET $PIECE(IBDATA("NAME"),U,5)=""
+7 SET $PIECE(IBDATA("COBID"),U,1)="VAD000"
+8 QUIT
+9 ;
UB047879(IBXIEN,X) ; LOAD X ARRAY WITH THE DATA FOR UB FIELD 78 AND 79.
+1 NEW Y
+2 KILL X
SET X(1)=""
SET X(2)=""
+3 FOR Y=9,1,3
if X(2)'=""
QUIT
Begin DoDot:1
+4 IF X(1)'=""
SET X(2)=$$GETPRV(IBXIEN,,Y,"A1")
if X(2)=""
QUIT
Begin DoDot:2
+5 IF X(1)'=""
SET X(2)=X(2)_"^"_$$GETPRV(IBXIEN,,Y,"B1")
+6 IF X(1)'=""
SET X(2)=X(2)_"^"_$$GETPRV(IBXIEN,,Y,"B2")
+7 IF X(1)'=""
SET X(2)=X(2)_"^"_$$GETPRV(IBXIEN,,Y,"B3")
End DoDot:2
+8 if X(1)'=""
QUIT
+9 SET X(1)=$$GETPRV(IBXIEN,,Y,"A1")
if X(1)=""
QUIT
+10 SET X(1)=X(1)_"^"_$$GETPRV(IBXIEN,,Y,"B1")
+11 SET X(1)=X(1)_"^"_$$GETPRV(IBXIEN,,Y,"B2")
+12 SET X(1)=X(1)_"^"_$$GETPRV(IBXIEN,,Y,"B3")
End DoDot:1
+13 QUIT
+14 ;
PRQUAL(IBXIEN) ;Get provider qualifier. Add with *488*
+1 NEW IBPQ
+2 SET IBPQ=$$GETPRV(IBXIEN,,1,"A1")
+3 IF IBPQ'=""
SET IBPQ="DN"
+4 IF IBPQ=""
Begin DoDot:1
+5 SET IBPQ=$$GETPRV(IBXIEN,,5,"A1")
+6 IF IBPQ'=""
SET IBPQ="DQ"
End DoDot:1
+7 QUIT IBPQ
+8 ;
PROVNM(IBXIEN) ;Get Ref provider if not avail check for Sup provider. Add with *488*
+1 NEW IBPR
+2 SET IBPR=$$GETPRV(IBXIEN,,1,"A1")
+3 IF IBPR=""
SET IBPR=$$GETPRV(IBXIEN,,5,"A1")
+4 QUIT IBPR
