IBCSC102 ;ALB/MJB - MCCR SCREEN 10 (UB-04 BILL SPECIFIC INFO) ;27 MAY 88 10:20
;;2.0;INTEGRATED BILLING;**432,447,461,547,759**;21-MAR-94;Build 24
;;Per VA Directive 6402, this routine should not be modified.
;
; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
; routines and created a new billing screen 8 routine IBCSC8.
;
EN S IBCUBFT=$$FT^IBCU3(IBIFN) I IBCUBFT=2 K IBCUBFT G ^IBCSC10H ;CMS-1500
;
N FIRSTPRV,I,IB,IBINP,IBX,PRV,PRVS,Z
S IBINP=$$INPAT^IBCEF(IBIFN)
D ^IBCSCU
;
;WCJ;IB*2.0*547
;S IBSR=10,IBSR1=2,IBV1="0000000" S:IBINP $E(IBV1,2)=1 S:IBV IBV1="1111111"
;WCJ;IB*2.0*759
;S IBSR=10,IBSR1=2,IBV1="00000000" S:IBINP $E(IBV1,2)=1 S:IBV IBV1="11111111"
S IBSR=10,IBSR1=2,IBV1="00000000" ; all sections editable on screen
S:IBINP $E(IBV1,2)=1 ; starting exceptions
S:'+$$BBB^IBCSC10(IBIFN) $E(IBV1,6)=1 ;WCJ;IB759; make undeditable if not set up for payer
S:IBV IBV1="11111111" ; uneditable if view only
;
;WCJ;IB*2.0*547
;F I="U","U1",0,"UF3","UF31","UF32","U2","TX","U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
F I="M2","U","U1",0,"UF3","UF31","UF32","U2","TX","U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
N IBZ,IBPRV,IBREQ,IBMRASEC,TEXT,BPZ,TXMT,IBZCNT
D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
K IB("PRV")
S IBZ=0 F S IBZ=$O(IBPRV(IBZ)) Q:'IBZ I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ)
;
D H^IBCSCU
;
; Section 1
S Z=1,IBW=1 X IBWW W " Bill Remarks",!?5,"- FL-80",?22,": "
S TEXT=$P($G(^DGCR(399,IBIFN,"UF2")),U,3) ; field# 402
I TEXT="" W IBUN ; unspecified [not required]
I TEXT'="" D
. N IBZ,Z
. D REMARK^IBCEF77(IBIFN,.IBZ)
. S Z=0 F S Z=$O(IBZ(Z)) Q:'Z D
.. W ?24,$G(IBZ(Z))
.. I Z>4 W ?48,$G(IBVI)," <--- This Line Will Not Print ",$G(IBVO)
.. I $O(IBZ(Z)) W !
.. Q
. Q
;
S IBZCNT=0,IBZ(IBZCNT)=""
I $P(IB("UF3"),U,4)]"" S IBZ(IBZCNT)="P: "_$P(IB("UF3"),U,4),IBZCNT=IBZCNT+1
I $P(IB("UF3"),U,5)]"" S IBZ(IBZCNT)="S: "_$P(IB("UF3"),U,5),IBZCNT=IBZCNT+1
I $P(IB("UF3"),U,6)]"" S IBZ(IBZCNT)="T: "_$P(IB("UF3"),U,6)
;S IBZ(0)="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":" Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"")
I IBZ(0)="",$$IBMICN^IBCBB13(IBIFN) S IBZ(0)="UNSPECIFIED [REQUIRED]"
S:IBZ(0)="" IBZ(0)=IBUN
W !?4,"ICN/DCN(s) : ",IBZ(0)
F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT)) W !?24,IBZ(IBZCNT)
K IBZ
S IBZCNT=0,IBZ(IBZCNT)=""
I $P(IB("U"),U,13)]"" S IBZ(IBZCNT)="P: "_$P(IB("U"),U,13),IBZCNT=IBZCNT+1
I $P(IB("U2"),U,8)'="" S IBZ(IBZCNT)="S: "_$P(IB("U2"),U,8),IBZCNT=IBZCNT+1
I $P(IB("U2"),U,9)'="" S IBZ(IBZCNT)="T: "_$P(IB("U2"),U,9),IBZCNT=IBZCNT+1
I $P(IB("UF32"),U,1)'="" S IBZ(IBZCNT)="P: "_$P(IB("UF32"),U,1),IBZCNT=IBZCNT+1
I $P(IB("UF32"),U,2)'="" S IBZ(IBZCNT)="S: "_$P(IB("UF32"),U,2),IBZCNT=IBZCNT+1
I $P(IB("UF32"),U,3)'="" S IBZ(IBZCNT)="T: "_$P(IB("UF32"),U,3)
S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"P: "_$P(IB("U"),U,13),1:"")
S:IBZ(0)="" IBZ(0)=IBUN
W !,?3," Auth/Referral : ",IBZ(0)
F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT)) W !?24,IBZ(IBZCNT)
K IBZ S IBZ=""
;
; IB*2*400 - Admitting diagnosis only for inpatients
I IBINP W !,?3," Admitting Dx : " S IBX=$$ICD9^IBACSV(+IB("U2"),$$BDATE^IBACSV(IBIFN)) W $S(IBX'="":$P(IBX,U)_" - "_$P(IBX,U,3),1:IBU)
;
; IB*2*400 - esg - display PPS (DRG) info for inpatient, UB claims
I IBINP D
. N PPS,PPSDISP
. S PPS=+$P(IB("U1"),U,15)
. I 'PPS S PPSDISP=IBUN
. I PPS S PPSDISP=$$FO^IBCNEUT1(PPS,4,"R",0)_" - "_$$DRGTD^IBACSV(PPS,$$BDATE^IBACSV(IBIFN))
. W !?4,"PPS (DRG)",?22,": ",$E(PPSDISP,1,56)
. Q
;
I 'IBINP W !,?3," Admission Source : " S IBX=$$EXTERNAL^DILFD(399,159,,$P(IB("U"),U,9)) W $S(IBX'="":IBX,1:IBU) ; Outpatient only
;
; Section 2
S Z=2,IBW=1 X IBWW
S PRVS=$TR($P(IB("U3"),U,8,10),U) W " Pt Reason f/Visit : " I PRVS="" W IBU_$S(IBINP:" [NOT USED]",1:"")
I PRVS'="" S FIRSTPRV=1 F I=8:1:10 D
.S PRV=$$ICD9^IBACSV($P(IB("U3"),U,I),$$BDATE^IBACSV(IBIFN)) I PRV'="" W:'FIRSTPRV !,?24 W $P(PRV,U,1)_" - "_$E($P(PRV,U,3),1,45) S FIRSTPRV=0
.Q
;
; Section 3
S Z=3,IBW=1 X IBWW
W " Providers : ",$S('$O(IB("PRV",0)):IBU,1:"")
I $D(IB("PRV")) D
. N Z,IBT,IBQ,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
. S IBZ=0
. D DEFSEC^IBCEF74(IBIFN,.IBARR)
. ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
. S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
. S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
. F S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ D
.. N A,A1
.. S IBQ=""
.. W !,?5,"- "
.. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
.. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,15-$L(A1))_A1
.. W $E(A_$J("",15),1,15),": "
.. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q
.. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",20),1,20) W:$G(IB("PRV",IBZ)) "(OLD PROV DATA) "_$P(IB("PRV",IBZ,1),U)
.. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",20),1,20)
.. W " Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"")
.. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" "
.. I $L(IBQ) W !,?30,$E(IBQ,1,49)
K IB("PRV")
;
; Section 4
S Z=4,IBW=1 X IBWW
W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10))
W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
I IBZ'="" D
. ; PRXM/KJH - Add Taxonomy code to display for patch 343.
. W ?53,"Taxonomy: "
. S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
. S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
. Q
;
; Section 5
S Z=5,IBW=1 X IBWW
W " Billing Provider : "
K IBZ
S BPZ=+$$B^IBCEF79(IBIFN)
D GETBP^IBCEF79(IBIFN,"",BPZ,"UB SCREEN 8",.IBZ)
S TXMT=$$TXMT^IBCEF4(IBIFN) ; transmittable? variable also used in next section
I TXMT S IBZ=$G(IBZ("UB SCREEN 8","NAME")) ; this is the BP name used in the PRV segment
I 'TXMT S IBZ=$$GETFAC^IBCEP8(BPZ,0,0) ; this is the BP name printed in FL-1
W $S(IBZ'="":IBZ,1:IBU) ; billing provider name
W !?3," Taxonomy Code : "
S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
;
; WCJ;IB*2.0*547
; Adding ALT PRIMARY IDS and moving sections down to make room
; Section 6
S Z=6,IBW=1 X IBWW
W " Alt Prim Payer ID : "
K IBZ
S IBZCNT=0
I $P(IB("M2"),U,2)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="P: "_$P(IB("M2"),U,2)
I $P(IB("M2"),U,4)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="S: "_$P(IB("M2"),U,4)
I $P(IB("M2"),U,6)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="T: "_$P(IB("M2"),U,6)
I 'IBZCNT W ?23,IBUN
I IBZCNT F IBZ1=1:1:IBZCNT W ?23,IBZ(IBZ1) W:(IBZ1'=IBZCNT) !
K IBZ
;
; Section 7
S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
S Z=7,IBW=1 X IBWW W " ",$S('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt?: ")
S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ))
I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0
W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'TXMT:"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
;
; Section 8
S Z=8,IBW=1 X IBWW
W " Provider ID Maint : (Edit Provider ID information)"
;
G ^IBCSCP
Q Q
;IBCSC102
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC102 7737 printed Oct 16, 2024@18:20:45 Page 2
IBCSC102 ;ALB/MJB - MCCR SCREEN 10 (UB-04 BILL SPECIFIC INFO) ;27 MAY 88 10:20
+1 ;;2.0;INTEGRATED BILLING;**432,447,461,547,759**;21-MAR-94;Build 24
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
+5 ; routines and created a new billing screen 8 routine IBCSC8.
+6 ;
EN ;CMS-1500
SET IBCUBFT=$$FT^IBCU3(IBIFN)
IF IBCUBFT=2
KILL IBCUBFT
GOTO ^IBCSC10H
+1 ;
+2 NEW FIRSTPRV,I,IB,IBINP,IBX,PRV,PRVS,Z
+3 SET IBINP=$$INPAT^IBCEF(IBIFN)
+4 DO ^IBCSCU
+5 ;
+6 ;WCJ;IB*2.0*547
+7 ;S IBSR=10,IBSR1=2,IBV1="0000000" S:IBINP $E(IBV1,2)=1 S:IBV IBV1="1111111"
+8 ;WCJ;IB*2.0*759
+9 ;S IBSR=10,IBSR1=2,IBV1="00000000" S:IBINP $E(IBV1,2)=1 S:IBV IBV1="11111111"
+10 ; all sections editable on screen
SET IBSR=10
SET IBSR1=2
SET IBV1="00000000"
+11 ; starting exceptions
if IBINP
SET $EXTRACT(IBV1,2)=1
+12 ;WCJ;IB759; make undeditable if not set up for payer
if '+$$BBB^IBCSC10(IBIFN)
SET $EXTRACT(IBV1,6)=1
+13 ; uneditable if view only
if IBV
SET IBV1="11111111"
+14 ;
+15 ;WCJ;IB*2.0*547
+16 ;F I="U","U1",0,"UF3","UF31","UF32","U2","TX","U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
+17 FOR I="M2","U","U1",0,"UF3","UF31","UF32","U2","TX","U3"
SET IB(I)=$GET(^DGCR(399,IBIFN,I))
+18 NEW IBZ,IBPRV,IBREQ,IBMRASEC,TEXT,BPZ,TXMT,IBZCNT
+19 DO GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
+20 KILL IB("PRV")
+21 SET IBZ=0
FOR
SET IBZ=$ORDER(IBPRV(IBZ))
if 'IBZ
QUIT
IF $ORDER(IBPRV(IBZ,0))!$DATA(IBPRV(IBZ,"NOTOPT"))
MERGE IB("PRV",IBZ)=IBPRV(IBZ)
+22 ;
+23 DO H^IBCSCU
+24 ;
+25 ; Section 1
+26 SET Z=1
SET IBW=1
XECUTE IBWW
WRITE " Bill Remarks",!?5,"- FL-80",?22,": "
+27 ; field# 402
SET TEXT=$PIECE($GET(^DGCR(399,IBIFN,"UF2")),U,3)
+28 ; unspecified [not required]
IF TEXT=""
WRITE IBUN
+29 IF TEXT'=""
Begin DoDot:1
+30 NEW IBZ,Z
+31 DO REMARK^IBCEF77(IBIFN,.IBZ)
+32 SET Z=0
FOR
SET Z=$ORDER(IBZ(Z))
if 'Z
QUIT
Begin DoDot:2
+33 WRITE ?24,$GET(IBZ(Z))
+34 IF Z>4
WRITE ?48,$GET(IBVI)," <--- This Line Will Not Print ",$GET(IBVO)
+35 IF $ORDER(IBZ(Z))
WRITE !
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
+38 ;
+39 SET IBZCNT=0
SET IBZ(IBZCNT)=""
+40 IF $PIECE(IB("UF3"),U,4)]""
SET IBZ(IBZCNT)="P: "_$PIECE(IB("UF3"),U,4)
SET IBZCNT=IBZCNT+1
+41 IF $PIECE(IB("UF3"),U,5)]""
SET IBZ(IBZCNT)="S: "_$PIECE(IB("UF3"),U,5)
SET IBZCNT=IBZCNT+1
+42 IF $PIECE(IB("UF3"),U,6)]""
SET IBZ(IBZCNT)="T: "_$PIECE(IB("UF3"),U,6)
+43 ;S IBZ(0)="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":" Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"")
+44 IF IBZ(0)=""
IF $$IBMICN^IBCBB13(IBIFN)
SET IBZ(0)="UNSPECIFIED [REQUIRED]"
+45 if IBZ(0)=""
SET IBZ(0)=IBUN
+46 WRITE !?4,"ICN/DCN(s) : ",IBZ(0)
+47 FOR IBZCNT=1:1
if '$DATA(IBZ(IBZCNT))
QUIT
WRITE !?24,IBZ(IBZCNT)
+48 KILL IBZ
+49 SET IBZCNT=0
SET IBZ(IBZCNT)=""
+50 IF $PIECE(IB("U"),U,13)]""
SET IBZ(IBZCNT)="P: "_$PIECE(IB("U"),U,13)
SET IBZCNT=IBZCNT+1
+51 IF $PIECE(IB("U2"),U,8)'=""
SET IBZ(IBZCNT)="S: "_$PIECE(IB("U2"),U,8)
SET IBZCNT=IBZCNT+1
+52 IF $PIECE(IB("U2"),U,9)'=""
SET IBZ(IBZCNT)="T: "_$PIECE(IB("U2"),U,9)
SET IBZCNT=IBZCNT+1
+53 IF $PIECE(IB("UF32"),U,1)'=""
SET IBZ(IBZCNT)="P: "_$PIECE(IB("UF32"),U,1)
SET IBZCNT=IBZCNT+1
+54 IF $PIECE(IB("UF32"),U,2)'=""
SET IBZ(IBZCNT)="S: "_$PIECE(IB("UF32"),U,2)
SET IBZCNT=IBZCNT+1
+55 IF $PIECE(IB("UF32"),U,3)'=""
SET IBZ(IBZCNT)="T: "_$PIECE(IB("UF32"),U,3)
+56 SET IBZ=""
SET IBZ=$SELECT($PIECE(IB("U"),U,13)]"":"P: "_$PIECE(IB("U"),U,13),1:"")
+57 if IBZ(0)=""
SET IBZ(0)=IBUN
+58 WRITE !,?3," Auth/Referral : ",IBZ(0)
+59 FOR IBZCNT=1:1
if '$DATA(IBZ(IBZCNT))
QUIT
WRITE !?24,IBZ(IBZCNT)
+60 KILL IBZ
SET IBZ=""
+61 ;
+62 ; IB*2*400 - Admitting diagnosis only for inpatients
+63 IF IBINP
WRITE !,?3," Admitting Dx : "
SET IBX=$$ICD9^IBACSV(+IB("U2"),$$BDATE^IBACSV(IBIFN))
WRITE $SELECT(IBX'="":$PIECE(IBX,U)_" - "_$PIECE(IBX,U,3),1:IBU)
+64 ;
+65 ; IB*2*400 - esg - display PPS (DRG) info for inpatient, UB claims
+66 IF IBINP
Begin DoDot:1
+67 NEW PPS,PPSDISP
+68 SET PPS=+$PIECE(IB("U1"),U,15)
+69 IF 'PPS
SET PPSDISP=IBUN
+70 IF PPS
SET PPSDISP=$$FO^IBCNEUT1(PPS,4,"R",0)_" - "_$$DRGTD^IBACSV(PPS,$$BDATE^IBACSV(IBIFN))
+71 WRITE !?4,"PPS (DRG)",?22,": ",$EXTRACT(PPSDISP,1,56)
+72 QUIT
End DoDot:1
+73 ;
+74 ; Outpatient only
IF 'IBINP
WRITE !,?3," Admission Source : "
SET IBX=$$EXTERNAL^DILFD(399,159,,$PIECE(IB("U"),U,9))
WRITE $SELECT(IBX'="":IBX,1:IBU)
+75 ;
+76 ; Section 2
+77 SET Z=2
SET IBW=1
XECUTE IBWW
+78 SET PRVS=$TRANSLATE($PIECE(IB("U3"),U,8,10),U)
WRITE " Pt Reason f/Visit : "
IF PRVS=""
WRITE IBU_$SELECT(IBINP:" [NOT USED]",1:"")
+79 IF PRVS'=""
SET FIRSTPRV=1
FOR I=8:1:10
Begin DoDot:1
+80 SET PRV=$$ICD9^IBACSV($PIECE(IB("U3"),U,I),$$BDATE^IBACSV(IBIFN))
IF PRV'=""
if 'FIRSTPRV
WRITE !,?24
WRITE $PIECE(PRV,U,1)_" - "_$EXTRACT($PIECE(PRV,U,3),1,45)
SET FIRSTPRV=0
+81 QUIT
End DoDot:1
+82 ;
+83 ; Section 3
+84 SET Z=3
SET IBW=1
XECUTE IBWW
+85 WRITE " Providers : ",$SELECT('$ORDER(IB("PRV",0)):IBU,1:"")
+86 IF $DATA(IB("PRV"))
Begin DoDot:1
+87 NEW Z,IBT,IBQ,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
+88 SET IBZ=0
+89 DO DEFSEC^IBCEF74(IBIFN,.IBARR)
+90 ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
+91 SET IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
+92 SET IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
+93 FOR
SET IBZ=$ORDER(IB("PRV",IBZ))
if 'IBZ
QUIT
Begin DoDot:2
+94 NEW A,A1
+95 SET IBQ=""
+96 WRITE !,?5,"- "
+97 SET A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
+98 IF $PIECE($GET(IB("PRV",IBZ,1)),U,4)'=""
SET A1=" ("_$EXTRACT($PIECE(IB("PRV",IBZ,1),U,4),1,3)_")"
SET A=$EXTRACT(A,1,15-$LENGTH(A1))_A1
+99 WRITE $EXTRACT(A_$JUSTIFY("",15),1,15),": "
+100 IF '$PIECE($GET(IB("PRV",IBZ,1)),U,3)
IF $PIECE($GET(IB("PRV",IBZ,1)),U)=""
WRITE IBU
QUIT
+101 IF $PIECE($GET(IB("PRV",IBZ,1)),U)'=""
if '$GET(IB("PRV",IBZ))
WRITE $EXTRACT($PIECE(IB("PRV",IBZ,1),U)_$JUSTIFY("",20),1,20)
if $GET(IB("PRV",IBZ))
WRITE "(OLD PROV DATA) "_$PIECE(IB("PRV",IBZ,1),U)
+102 IF $PIECE($GET(IB("PRV",IBZ,1)),U)=""
IF $PIECE($GET(IB("PRV",IBZ)),U)'=""
WRITE $EXTRACT($PIECE(IB("PRV",IBZ),U)_$JUSTIFY("",20),1,20)
+103 WRITE " Taxonomy: ",$SELECT($PIECE(IBTAX,U,IBZ)'="":$PIECE(IBTAX,U,IBZ),1:IBU),$SELECT($PIECE(IBSPEC,U,IBZ)'="":" ("_$PIECE(IBSPEC,U,IBZ)_")",1:"")
+104 FOR A=1:1:3
IF $GET(IBARR(IBZ,A))'=""
SET IBQ=IBQ_"["_$EXTRACT("PST",A)_"]"_IBARR(IBZ,A)_" "
+105 IF $LENGTH(IBQ)
WRITE !,?30,$EXTRACT(IBQ,1,49)
End DoDot:2
End DoDot:1
+106 KILL IB("PRV")
+107 ;
+108 ; Section 4
+109 SET Z=4
SET IBW=1
XECUTE IBWW
+110 WRITE " Other Facility (VA/non): "
SET IBZ=$$EXPAND^IBTRE(399,232,+$PIECE(IB("U2"),U,10))
+111 WRITE $SELECT(IBZ'="":$EXTRACT(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
+112 IF IBZ'=""
Begin DoDot:1
+113 ; PRXM/KJH - Add Taxonomy code to display for patch 343.
+114 WRITE ?53,"Taxonomy: "
+115 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,3),"X12 CODE")
WRITE $SELECT(IBZ'="":IBZ,1:IBU)
+116 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,3),"SPECIALTY CODE")
WRITE $SELECT(IBZ'="":" ("_IBZ_")",1:"")
+117 QUIT
End DoDot:1
+118 ;
+119 ; Section 5
+120 SET Z=5
SET IBW=1
XECUTE IBWW
+121 WRITE " Billing Provider : "
+122 KILL IBZ
+123 SET BPZ=+$$B^IBCEF79(IBIFN)
+124 DO GETBP^IBCEF79(IBIFN,"",BPZ,"UB SCREEN 8",.IBZ)
+125 ; transmittable? variable also used in next section
SET TXMT=$$TXMT^IBCEF4(IBIFN)
+126 ; this is the BP name used in the PRV segment
IF TXMT
SET IBZ=$GET(IBZ("UB SCREEN 8","NAME"))
+127 ; this is the BP name printed in FL-1
IF 'TXMT
SET IBZ=$$GETFAC^IBCEP8(BPZ,0,0)
+128 ; billing provider name
WRITE $SELECT(IBZ'="":IBZ,1:IBU)
+129 WRITE !?3," Taxonomy Code : "
+130 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,11),"X12 CODE")
WRITE $SELECT(IBZ'="":IBZ,1:IBU)
+131 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,11),"SPECIALTY CODE")
WRITE $SELECT(IBZ'="":" ("_IBZ_")",1:"")
+132 ;
+133 ; WCJ;IB*2.0*547
+134 ; Adding ALT PRIMARY IDS and moving sections down to make room
+135 ; Section 6
+136 SET Z=6
SET IBW=1
XECUTE IBWW
+137 WRITE " Alt Prim Payer ID : "
+138 KILL IBZ
+139 SET IBZCNT=0
+140 IF $PIECE(IB("M2"),U,2)]""
SET IBZCNT=IBZCNT+1
SET IBZ(IBZCNT)="P: "_$PIECE(IB("M2"),U,2)
+141 IF $PIECE(IB("M2"),U,4)]""
SET IBZCNT=IBZCNT+1
SET IBZ(IBZCNT)="S: "_$PIECE(IB("M2"),U,4)
+142 IF $PIECE(IB("M2"),U,6)]""
SET IBZCNT=IBZCNT+1
SET IBZ(IBZCNT)="T: "_$PIECE(IB("M2"),U,6)
+143 IF 'IBZCNT
WRITE ?23,IBUN
+144 IF IBZCNT
FOR IBZ1=1:1:IBZCNT
WRITE ?23,IBZ(IBZ1)
if (IBZ1'=IBZCNT)
WRITE !
+145 KILL IBZ
+146 ;
+147 ; Section 7
+148 SET IBREQ=+$$REQMRA^IBEFUNC(IBIFN)
if IBREQ
SET IBREQ=1
+149 SET IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
+150 SET Z=7
SET IBW=1
XECUTE IBWW
WRITE " ",$SELECT('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt?: ")
+151 SET IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$PIECE(IB("TX"),U,8+IBREQ))
+152 IF IBMRASEC
IF '$PIECE(IB("TX"),U,8)
IF $PIECE(IB("TX"),U,9)
SET IBZ="FORCED TO PRINT BY MRA PRIMARY"
SET $PIECE(IB("TX"),U,8)=0
+153 WRITE $SELECT(IBZ'=""&($PIECE(IB("TX"),U,8+IBREQ)'=""):IBZ,'TXMT:"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
+154 ;
+155 ; Section 8
+156 SET Z=8
SET IBW=1
XECUTE IBWW
+157 WRITE " Provider ID Maint : (Edit Provider ID information)"
+158 ;
+159 GOTO ^IBCSCP
Q QUIT
+1 ;IBCSC102
