- 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 Feb 18, 2025@23:36:49 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