IBCEF74A ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006
;;2.0;INTEGRATED BILLING;**320,343,349,395,400,432,516,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EN(IBIFN,IBQUIT,IBID) ; Display billing provider and service provider IDs as part
; of the ?ID display/help in the billing screens.
; Called from DISPID^IBCEF74.
NEW IBX,Z,ZI,ZN,SEQ,PSIN,DATA,QUALNM,IDNUM,FACNAME,IBZ,ORGNPI,BPZ,BPNAME,BPNPI,BPTAX,SFNPI,SFTAX
;
;D ALLIDS^IBCEF75(IBIFN,.IBID)
;
; Re-sort array by insurance sequence (P/S/T)
K IBX
F Z="BILLING PRV","LAB/FAC" F ZI="C","O" S ZN=0 F S ZN=$O(IBID(Z,IBIFN,ZI,ZN)) Q:'ZN D
. S SEQ=$P($G(IBID(Z,IBIFN,ZI,ZN)),U,1) Q:SEQ=""
. S IBX(Z,SEQ,ZI,ZN)=""
. Q
;
; Display billing provider information - IB*2*400
S BPZ=$$B^IBCEF79(IBIFN)
D GETBP^IBCEF79(IBIFN,"",+BPZ,"?ID",.IBZ)
S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN)
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !!,"Billing Provider Name and ID Information"
S BPNAME=$G(IBZ("?ID","NAME"))
I BPNAME="" S BPNAME="***MISSING***"
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !,"Billing Provider: ",BPNAME
;
S BPNPI=$P(ORGNPI,U,3)
I BPNPI="" S BPNPI="***MISSING***"
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !?5,"Billing Provider NPI: ",BPNPI
;
S BPTAX=$$NOPUNCT^IBCEF($P($G(^IBE(350.9,1,1)),U,5),1)
I BPTAX="" S BPTAX="***MISSING***"
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !?5,"Billing Provider Tax ID (VistA Record PRV): ",BPTAX
;
; Display billing provider secondary ID's (current ins only)
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !?5,"Billing Provider Secondary IDs (VistA Record CI1A):"
S Z="BILLING PRV"
D SECID(Z,.IBQUIT)
I IBQUIT G EX
;
; Now display the lab or facility primary and secondary IDs
; This is the service facility information
; IB*2*400 - check to make sure there is a service facility
;
I $P(BPZ,U,3)="" G LPRV ; no service facility information to display
;
; Service facility name, similar code as found in SUB-2
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !!,"Service Facility Name and ID Information"
;
; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
; function $$SENDSF^IBCEF79 will always return '1'. Refer to
; that function and INSFLGS^IBCEF79 for more information.
;
; Display note if ins co flag to suppress lab/fac data is set (only applies in switchback mode)
;I '$$SENDSF^IBCEF79(IBIFN) D I IBQUIT G EX
;. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
;. W !!,"Note: Service Facility Data not sent for Current Insurance"
;. W !," 'Send VA Lab/Facility IDs or Facility Data for VAMC?' is set to NO",!
;. Q
;
S FACNAME=$$GETFAC^IBCEP8(+$P(BPZ,U,4),$P(BPZ,U,3),0)
I FACNAME="" S FACNAME="***MISSING***"
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !?5,"Facility: ",FACNAME
;
S SFNPI=$P(ORGNPI,U,1)
I SFNPI="" S SFNPI="***MISSING***"
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !?5,"Lab or Facility NPI: ",SFNPI
;
S SFTAX=$$NOPUNCT^IBCEF($$EIN^IBCEP8A(IBIFN),1)
I SFTAX="" S SFTAX="***MISSING***"
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !?5,"Lab or Facility Tax ID (VistA Record SUB): ",SFTAX
;
; lab/fac secondary IDs
I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
W !?5,"Lab or Facility Secondary IDs (VistA Records SUB1,SUB2,OP3,OP6,OP7):"
S Z="LAB/FAC"
D SECID(Z,.IBQUIT)
I IBQUIT G EX
;
LPRV ;Service Line Providers
I '$D(IBID("L-PROV")) G EX ; No Line Level Providers
N IBSLC,IBN,CO,IBCODE,IBTYP,IBPRTYP,Z0
S IBSLC=0
W !!,"Service Line Providers"
F S IBSLC=$O(IBID("L-PROV",IBIFN,IBSLC)) Q:'IBSLC D I IBQUIT Q
. I ($Y+6)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT Q
. W !!?5,"Service Line: ",IBSLC
. ;JWS;IB*2.0*592; 6 - Assistant Surgeon
. F IBPRTYP=4,3,1,2,5,6,9 I $D(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP)) D ; Process providers in order: Attending, Rendering, Referring, Operating, Supervising, Assistant Surgeon and Other Operating if they exist
.. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT Q
.. W !?5,$$EXTERNAL^DILFD(399.0404,.01,"",IBPRTYP),": ",$$EXTERNAL^DILFD(399.0404,.02,"",$P(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP),U,1))
.. W !?8,"NPI:",?40,$S($P(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP,0),U,4)]"":$P(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP,0),U,4),1:"***MISSING***")
.. K IBTYP
.. F CO="C","O" D
... F IBN=1,2 D
.... F Z0=1:1 Q:'$D(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0))!IBQUIT D
..... S IBCODE=$P(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0),U,9)
..... Q:$D(IBTYP(IBCODE)) ; 1st of each type transmits
..... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
..... S IBTYP(IBCODE)=""
..... W !,?8,"(",IBID("L-PROV",IBIFN,IBSLC,CO,IBN),") ",$$EXTERNAL^DILFD(36,4.01,"",IBCODE),?40,$P(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0),U,4)
;
EX ;
Q
;
QUAL(Z,FORMTYPE) ; turn the qualifier code into a qualifier description
NEW QUAL,IEN
S QUAL=""
I $G(Z)="" G QUALX
I Z="1C" D G QUALX ; qualifier for Medicare Part ?
. I $G(FORMTYPE)=2 S QUAL="MEDICARE PART B" ; 1500
. I $G(FORMTYPE)=3 S QUAL="MEDICARE PART A" ; ub
. Q
I Z=34 S Z="SY" ; qualifier for SSN
S IEN=+$O(^IBE(355.97,"C",Z,"")) I 'IEN G QUALX
S QUAL=$P($G(^IBE(355.97,IEN,0)),U,1)
QUALX ;
Q QUAL
;
SECID(Z,IBQUIT) ; Display secondary ID and qualifier information
; Z is the type of IDs passed in; either BILLING PRV or LAB/FAC
; IBQUIT is returned if passed by reference
NEW SEQ,ZI,ZN,PSIN,DATA,QUALNM,IDNUM,NODATA
S IBQUIT=0,NODATA=1
F SEQ="P","S","T" D Q:IBQUIT
. ;
. ; current ins only for billing provider secondary IDs
. I Z="BILLING PRV",SEQ'=$$COB^IBCEF(IBIFN) Q
. S ZI=""
. F S ZI=$O(IBX(Z,SEQ,ZI)) Q:ZI="" D Q:IBQUIT
.. S ZN=0
.. F S ZN=$O(IBX(Z,SEQ,ZI,ZN)) Q:'ZN D Q:IBQUIT
... S PSIN=0 ; start at 0 to skip primary IDs
... ;*432/TAZ - Changed Q:PSIN="" to Q:'PSIN to prevent "CONTACTS" node from printing as secondary ID
... F S PSIN=$O(IBID(Z,IBIFN,ZI,ZN,PSIN)) Q:'PSIN D Q:IBQUIT
.... S DATA=$G(IBID(Z,IBIFN,ZI,ZN,PSIN))
.... S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN))
.... S IDNUM=$P(DATA,U,2)
.... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
.... S NODATA=0
.... W !?8,"(",SEQ,") ",QUALNM,?40,IDNUM
.... I Z="LAB/FAC",$D(^DGCR(399,IBIFN,"I2")),SEQ=$$COB^IBCEF(IBIFN) W ?54,"<<<Current Ins"
.... I Z="BILLING PRV",PSIN=1 W ?54,"<<<System Generated ID"
.... Q
... Q
.. Q
. Q
I NODATA,'IBQUIT W !?8,"(-) None Found"
SECIDX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF74A 6724 printed Oct 16, 2024@18:10:57 Page 2
IBCEF74A ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006
+1 ;;2.0;INTEGRATED BILLING;**320,343,349,395,400,432,516,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN(IBIFN,IBQUIT,IBID) ; Display billing provider and service provider IDs as part
+1 ; of the ?ID display/help in the billing screens.
+2 ; Called from DISPID^IBCEF74.
+3 NEW IBX,Z,ZI,ZN,SEQ,PSIN,DATA,QUALNM,IDNUM,FACNAME,IBZ,ORGNPI,BPZ,BPNAME,BPNPI,BPTAX,SFNPI,SFTAX
+4 ;
+5 ;D ALLIDS^IBCEF75(IBIFN,.IBID)
+6 ;
+7 ; Re-sort array by insurance sequence (P/S/T)
+8 KILL IBX
+9 FOR Z="BILLING PRV","LAB/FAC"
FOR ZI="C","O"
SET ZN=0
FOR
SET ZN=$ORDER(IBID(Z,IBIFN,ZI,ZN))
if 'ZN
QUIT
Begin DoDot:1
+10 SET SEQ=$PIECE($GET(IBID(Z,IBIFN,ZI,ZN)),U,1)
if SEQ=""
QUIT
+11 SET IBX(Z,SEQ,ZI,ZN)=""
+12 QUIT
End DoDot:1
+13 ;
+14 ; Display billing provider information - IB*2*400
+15 SET BPZ=$$B^IBCEF79(IBIFN)
+16 DO GETBP^IBCEF79(IBIFN,"",+BPZ,"?ID",.IBZ)
+17 SET ORGNPI=$$ORGNPI^IBCEF73A(IBIFN)
+18 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+19 WRITE !!,"Billing Provider Name and ID Information"
+20 SET BPNAME=$GET(IBZ("?ID","NAME"))
+21 IF BPNAME=""
SET BPNAME="***MISSING***"
+22 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+23 WRITE !,"Billing Provider: ",BPNAME
+24 ;
+25 SET BPNPI=$PIECE(ORGNPI,U,3)
+26 IF BPNPI=""
SET BPNPI="***MISSING***"
+27 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+28 WRITE !?5,"Billing Provider NPI: ",BPNPI
+29 ;
+30 SET BPTAX=$$NOPUNCT^IBCEF($PIECE($GET(^IBE(350.9,1,1)),U,5),1)
+31 IF BPTAX=""
SET BPTAX="***MISSING***"
+32 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+33 WRITE !?5,"Billing Provider Tax ID (VistA Record PRV): ",BPTAX
+34 ;
+35 ; Display billing provider secondary ID's (current ins only)
+36 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+37 WRITE !?5,"Billing Provider Secondary IDs (VistA Record CI1A):"
+38 SET Z="BILLING PRV"
+39 DO SECID(Z,.IBQUIT)
+40 IF IBQUIT
GOTO EX
+41 ;
+42 ; Now display the lab or facility primary and secondary IDs
+43 ; This is the service facility information
+44 ; IB*2*400 - check to make sure there is a service facility
+45 ;
+46 ; no service facility information to display
IF $PIECE(BPZ,U,3)=""
GOTO LPRV
+47 ;
+48 ; Service facility name, similar code as found in SUB-2
+49 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+50 WRITE !!,"Service Facility Name and ID Information"
+51 ;
+52 ; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
+53 ; function $$SENDSF^IBCEF79 will always return '1'. Refer to
+54 ; that function and INSFLGS^IBCEF79 for more information.
+55 ;
+56 ; Display note if ins co flag to suppress lab/fac data is set (only applies in switchback mode)
+57 ;I '$$SENDSF^IBCEF79(IBIFN) D I IBQUIT G EX
+58 ;. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
+59 ;. W !!,"Note: Service Facility Data not sent for Current Insurance"
+60 ;. W !," 'Send VA Lab/Facility IDs or Facility Data for VAMC?' is set to NO",!
+61 ;. Q
+62 ;
+63 SET FACNAME=$$GETFAC^IBCEP8(+$PIECE(BPZ,U,4),$PIECE(BPZ,U,3),0)
+64 IF FACNAME=""
SET FACNAME="***MISSING***"
+65 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+66 WRITE !?5,"Facility: ",FACNAME
+67 ;
+68 SET SFNPI=$PIECE(ORGNPI,U,1)
+69 IF SFNPI=""
SET SFNPI="***MISSING***"
+70 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+71 WRITE !?5,"Lab or Facility NPI: ",SFNPI
+72 ;
+73 SET SFTAX=$$NOPUNCT^IBCEF($$EIN^IBCEP8A(IBIFN),1)
+74 IF SFTAX=""
SET SFTAX="***MISSING***"
+75 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+76 WRITE !?5,"Lab or Facility Tax ID (VistA Record SUB): ",SFTAX
+77 ;
+78 ; lab/fac secondary IDs
+79 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
GOTO EX
+80 WRITE !?5,"Lab or Facility Secondary IDs (VistA Records SUB1,SUB2,OP3,OP6,OP7):"
+81 SET Z="LAB/FAC"
+82 DO SECID(Z,.IBQUIT)
+83 IF IBQUIT
GOTO EX
+84 ;
LPRV ;Service Line Providers
+1 ; No Line Level Providers
IF '$DATA(IBID("L-PROV"))
GOTO EX
+2 NEW IBSLC,IBN,CO,IBCODE,IBTYP,IBPRTYP,Z0
+3 SET IBSLC=0
+4 WRITE !!,"Service Line Providers"
+5 FOR
SET IBSLC=$ORDER(IBID("L-PROV",IBIFN,IBSLC))
if 'IBSLC
QUIT
Begin DoDot:1
+6 IF ($Y+6)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
QUIT
+7 WRITE !!?5,"Service Line: ",IBSLC
+8 ;JWS;IB*2.0*592; 6 - Assistant Surgeon
+9 ; Process providers in order: Attending, Rendering, Referring, Operating, Supervising, Assistant Surgeon and Other Operating if they exist
FOR IBPRTYP=4,3,1,2,5,6,9
IF $DATA(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP))
Begin DoDot:2
+10 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
IF IBQUIT
QUIT
+11 WRITE !?5,$$EXTERNAL^DILFD(399.0404,.01,"",IBPRTYP),": ",$$EXTERNAL^DILFD(399.0404,.02,"",$PIECE(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP),U,1))
+12 WRITE !?8,"NPI:",?40,$SELECT($PIECE(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP,0),U,4)]"":$PIECE(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP,0),U,4),1:"***MISSING***")
+13 KILL IBTYP
+14 FOR CO="C","O"
Begin DoDot:3
+15 FOR IBN=1,2
Begin DoDot:4
+16 FOR Z0=1:1
if '$DATA(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0))!IBQUIT
QUIT
Begin DoDot:5
+17 SET IBCODE=$PIECE(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0),U,9)
+18 ; 1st of each type transmits
if $DATA(IBTYP(IBCODE))
QUIT
+19 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
if IBQUIT
QUIT
+20 SET IBTYP(IBCODE)=""
+21 WRITE !,?8,"(",IBID("L-PROV",IBIFN,IBSLC,CO,IBN),") ",$$EXTERNAL^DILFD(36,4.01,"",IBCODE),?40,$PIECE(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0),U,4)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
IF IBQUIT
QUIT
+22 ;
EX ;
+1 QUIT
+2 ;
QUAL(Z,FORMTYPE) ; turn the qualifier code into a qualifier description
+1 NEW QUAL,IEN
+2 SET QUAL=""
+3 IF $GET(Z)=""
GOTO QUALX
+4 ; qualifier for Medicare Part ?
IF Z="1C"
Begin DoDot:1
+5 ; 1500
IF $GET(FORMTYPE)=2
SET QUAL="MEDICARE PART B"
+6 ; ub
IF $GET(FORMTYPE)=3
SET QUAL="MEDICARE PART A"
+7 QUIT
End DoDot:1
GOTO QUALX
+8 ; qualifier for SSN
IF Z=34
SET Z="SY"
+9 SET IEN=+$ORDER(^IBE(355.97,"C",Z,""))
IF 'IEN
GOTO QUALX
+10 SET QUAL=$PIECE($GET(^IBE(355.97,IEN,0)),U,1)
QUALX ;
+1 QUIT QUAL
+2 ;
SECID(Z,IBQUIT) ; Display secondary ID and qualifier information
+1 ; Z is the type of IDs passed in; either BILLING PRV or LAB/FAC
+2 ; IBQUIT is returned if passed by reference
+3 NEW SEQ,ZI,ZN,PSIN,DATA,QUALNM,IDNUM,NODATA
+4 SET IBQUIT=0
SET NODATA=1
+5 FOR SEQ="P","S","T"
Begin DoDot:1
+6 ;
+7 ; current ins only for billing provider secondary IDs
+8 IF Z="BILLING PRV"
IF SEQ'=$$COB^IBCEF(IBIFN)
QUIT
+9 SET ZI=""
+10 FOR
SET ZI=$ORDER(IBX(Z,SEQ,ZI))
if ZI=""
QUIT
Begin DoDot:2
+11 SET ZN=0
+12 FOR
SET ZN=$ORDER(IBX(Z,SEQ,ZI,ZN))
if 'ZN
QUIT
Begin DoDot:3
+13 ; start at 0 to skip primary IDs
SET PSIN=0
+14 ;*432/TAZ - Changed Q:PSIN="" to Q:'PSIN to prevent "CONTACTS" node from printing as secondary ID
+15 FOR
SET PSIN=$ORDER(IBID(Z,IBIFN,ZI,ZN,PSIN))
if 'PSIN
QUIT
Begin DoDot:4
+16 SET DATA=$GET(IBID(Z,IBIFN,ZI,ZN,PSIN))
+17 SET QUALNM=$$QUAL($PIECE(DATA,U,1),$$FT^IBCEF(IBIFN))
+18 SET IDNUM=$PIECE(DATA,U,2)
+19 IF ($Y+5)>IOSL
SET IBQUIT=$$NOMORE^IBCEF74()
if IBQUIT
QUIT
+20 SET NODATA=0
+21 WRITE !?8,"(",SEQ,") ",QUALNM,?40,IDNUM
+22 IF Z="LAB/FAC"
IF $DATA(^DGCR(399,IBIFN,"I2"))
IF SEQ=$$COB^IBCEF(IBIFN)
WRITE ?54,"<<<Current Ins"
+23 IF Z="BILLING PRV"
IF PSIN=1
WRITE ?54,"<<<System Generated ID"
+24 QUIT
End DoDot:4
if IBQUIT
QUIT
+25 QUIT
End DoDot:3
if IBQUIT
QUIT
+26 QUIT
End DoDot:2
if IBQUIT
QUIT
+27 QUIT
End DoDot:1
if IBQUIT
QUIT
+28 IF NODATA
IF 'IBQUIT
WRITE !?8,"(-) None Found"
SECIDX ;
+1 QUIT
+2 ;
