FBPCR2 ;AISC/DMK,GRR,TET-OUTPATIENT POTENTIAL COST RECOVERY SORT/PRINT ;7/1/2006
;;3.5;FEE BASIS;**4,48,55,69,76,98,122,133,163**;JAN 30, 1995;Build 21
;Per VA Directive 6402, this routine should not be modified.
;
EN ;entry point
S (FBCATC,FBINS,FBPSF)=0
SORT ;sort by date finalized, patient, vendor, treatment ien, service ien
S FBPVLIST="ATTENDING PROV NAME^ATTENDING PROV NPI^ATTENDING PROV TAXONOMY CODE^OPERATING PROV NAME^OPERATING PROV NPI^RENDERING PROV NAME" ; FB*3.5*122
S FBPVLIST=FBPVLIST_"^RENDERING PROV NPI^RENDERING PROV TAXONOMY CODE^SERVICING PROV NAME^SERVICING PROV NPI^REFERRING PROV NAME^REFERRING PROV NPI" ; FB*3.5*122
S FBLIPVL="^^LI-RENDERING-PROV-NAME^LI-RENDERING-PROV-NPI^LI-RENDERING-PROV-TAXONOMY" ; FB*3.5*122
S I=FBBDATE-.1 F S I=$O(^FBAAC("AK",I)) Q:'I!(I>FBEDATE) S J=0 F S J=$O(^FBAAC("AK",I,J)) Q:'J D
.S DFN=J D VET^FBPCR
.S K=0 F S K=$O(^FBAAC("AK",I,J,K)) Q:'K S L=0 F S L=$O(^FBAAC("AK",I,J,K,L)) Q:'L D SETTR S M=0 F S M=$O(^FBAAC("AK",I,J,K,L,M)) Q:'M D S (FBCATC,FBINS,FBPSF)=0
..D SET Q:'FBPSV&('$D(FBPSV(FBPSF))) I FBCATC!FBINS D SETTMP
KILL ;kill variables set in this routine
K A1,A2,A3,D,D2,DFN,FBAACPTC,FBBN,FBCATC,FBCP,FBDOB,FBDOS,FBDT,FBDT1,FBIN,FBINS,FBOB,FBP,FBPAT,FBPCR,FBPDX,FBPDXC,FBPID,FBPNAME,FBPSF,FBSC,FBTA,FBTYPE,FBVEN,FBVID,FBVNAME,FBVP,I,J,K,L,M,T,Y,FBMODLE
K FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ,FBDAT002,FBDAT003,FBDAT004,FBDAT005,FBPVLIST,FBLIPVL,FBPVL133 ; FB*3.5*122 ; FB*3.5*133
K FBADX1,FBADX2,FBADX3,FBAICD,FBAIEN,FBAREF,FBAREFA,FBARNPI,FBAUTH,FBAVND,FBAVNDA,FBAVNPI,FBAVTAX ; FB*3.5*163
Q
SET ;set variables - also entry point from FBPCR67
N FBPCR,FBX
S Y=$G(^FBAAC(J,1,K,1,L,1,M,0)) Q:'+$P(Y,U,9)!($G(^FBAAC(J,1,K,1,L,1,M,"FBREJ"))]"")
S FBY=$G(^FBAAC(J,1,K,1,L,1,M,2)),FBDAT003=$G(^FBAAC(J,1,K,1,L,1,M,3)) ; FB*3.5*122
S FBDAT004=$G(^FBAAC(J,1,K,1,L,1,M,4)),FBDAT005=$G(^FBAAC(J,1,K,1,L,1,M,5)) ; FB*3.5*133
S FBVNAME=$E($P($G(^FBAAV(K,0)),U),1,23),FBVID=$S(FBVNAME]"":$P(^(0),U,2)_"/"_$S($P($G(^(3)),U,2)]"":$P(^(3),U,2),1:"**********"),1:"")
S FBP=+$P(Y,U,9),FBSC=$P(Y,U,27),FBPDX=+$P(Y,U,23),FBPSF=+$P(Y,U,12)
S ^TMP($J,"FB",FBPSF)=$G(^FBAAC(J,1,K,1,L,4)) ; FB*3.5*122
S FBSC=$S(FBSC="Y":"YES",FBSC="N":"NO",1:"-")
S T=$P(Y,U,5),D2=$P(Y,U,6),FBDOS=D2,D2=$$DATX^FBAAUTL(D2),FBCP=$P(Y,U,18),FBCP=$S(FBCP=1:"(C&P)",1:"")
; FB*3.5*163 - baa start
;Q:FBCP]""!('FBPSV&('$D(FBPSV(FBPSF)))) S FBPCR=+$G(^FBAAC(J,1,K,1,L,0)),FBCATC=$$CATC^FBPCR(DFN,FBPCR,+$P(Y,U,18)),FBINS=$S(FBSC["N":$$INSURED^FBPCR4(DFN,FBPCR),1:0) Q:'FBCATC&'FBINS
Q:FBCP]""!('FBPSV&('$D(FBPSV(FBPSF))))
S FBPCR=+$G(^FBAAC(J,1,K,1,L,0)),FBCATC=$$CATC^FBPCR(DFN,FBPCR,+$P(Y,U,18)),FBINS=$$INSURED^FBPCR4(DFN,FBPCR)
Q:'FBCATC&'FBINS
; FB*3.5*163 - baa end
S FBAACPTC=$$CPT^FBAAUTL4($P(Y,U))
S FBOB=$P(Y,U,10)
I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U)
S FBTYPE=$P(Y,U,20),FBVP=$P(Y,U,21),FBIN=$P(Y,U,16),FBBN=$P(Y,U,8),FBBN=$S(FBBN']"":"",$D(^FBAA(161.7,FBBN,0)):$P(^(0),U),1:""),FBBN=$S(FBBN="":"",1:$E("00000",$L(FBBN)+1,5)_FBBN)
S FBVEN=FBVNAME_";"_FBVID,FBPAT=FBPNAME_";"_DFN
S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) ;suspend code
S TAMT=$FN($P(Y,U,4),"",2) ;suspend amount
S FBUNITS=$P(FBY,U,14) ;units paid
S FBCSID=$P(FBY,U,16) ;patient account number
S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
S FBADJLR=$P(FBX,U) ;adjustment codes
S FBADJLA=$P(FBX,U,2) ;adjustment amounts
S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") ;remit remarks
;output format
S A1=$J($P(Y,U,2),6,2),A2=$J($P(Y,U,3),6,2),A3=$J(A3,6,2),FBIN=$J(FBIN,7)
S FBDT1=$S(FBVP="VP":"#",1:"")_$S(FBTYPE="R":"*",1:" ")_FBDT
;FB*3.5*163 - Get data from fee basis authorization if available
S FBAUTH=$P(FBDAT003,U,9) ;FB*3.5*163
I FBAUTH D FBAUTH(FBAUTH,J) ;FB*3.5*163
Q
;
SETTMP ;sort data by primary service facility, patient, fee program, vendor, date
N FBBILL,FBINAU,FBSKIP ;FB*3.5*163
S FBSKIP=0,(FBBILL,FBINAU)="" ;FB*3.5*163
Q:$$FILTER^FBPCR4()=0
I $P(Y,U,9)'=FBPI Q
D CHKBILL^IBFBUTIL(FBIN) ;FB*3.5*163
I $G(FBSKIP),$G(FBNPB) Q ;Quit if running for not previously billed and bill IEN exists on File #360 FB*3.5*163
S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M)=FBDT1_U_FBAACPTC_FBCP_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_FBPI_U_FBCATC_U_FBINS
S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID
I FBBILL S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBBILL")=FBBILL ; FB*3.5*163 Bill Number
I FBINAU S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBINAU")=FBINAU ; FB*3.5*163 Insurance Auth
I $G(FBAUTH)'="" S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBAUTH")=FBADX1_U_FBADX2_U_FBADX3_U_FBAICD_U_FBAREF_U_$G(FBARNPI)_U_FBAVND_U_$G(FBAVNPI)_U_$G(FBAVTAX) ; FB*3.5*163
;I $TR($G(FBDAT002),U)'="" S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN)=FBDAT002 K FBDAT002 ; FB*3.5*122
;I $TR($G(FBDAT004),U)'="" S $P(^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN),U,20)=FBDAT004 K FBDAT004 ; FB*3.5*122
I $TR($G(FBDAT003),U)'="" S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBDAT003")=FBDAT003 K FBDAT003 ; FB*3.5*122
I $TR($G(FBDAT004),U)'="" S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBDAT004")=FBDAT004 K FBDAT004 ; FB*3.5*133
I $TR($G(FBDAT005),U)'="" S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBDAT005")=FBDAT005 K FBDAT005 ; FB*3.5*133
Q
SETTR S D=$S($D(^FBAAC(J,1,K,1,L,0)):$P(^(0),"^",1),1:""),A3=".00"
I D]"",$D(^FBAAC(J,3,"AB",D)) S FBTA=$O(^FBAAC(J,3,"AB",D,0)),A3=$S($P(^FBAAC(J,3,FBTA,0),"^",3)]"":$P(^(0),"^",3),1:.0001)
S FBDT=$$DATX^FBAAUTL(D)
;S FBDAT002=$G(^FBAAC(J,1,K,1,L,2)) ; FB*3.5*122
;S FBDAT004=$G(^FBAAC(J,1,K,1,L,4)) ; FB*3.5*122
Q
EN1 ;entry point to set variables, called by fbpcr67, anc
N FBVEN,FBPAT,FBDT1
D SETTR,SET
Q
PRINT ;write output
N FB5010PV,FBLIPVL,FBPVLIST,FBBILL,FBINAU
S FB5010PV=""
S FBPVLIST="ATTENDING PROV NAME^NPI^TAXONOMY CODE^OPERATING PROV NAME^NPI^RENDERING PROV NAME^NPI^TAXONOMY CODE"
S FBPVLIST=FBPVLIST_"^SERVICING PROV NAME^NPI^REFERRING PROV NAME^NPI"
S FBPVL133="ATTENDING PROV NAME^NPI^TAXONOMY CODE^OPERATING PROV NAME^NPI^RENDERING PROV NAME" ; FB*3.5*133
S FBPVL133=FBPVL133_"^NPI^TAXONOMY CODE^SERVICING PROV NAME^NPI^REFERRING PROV NAME^NPI" ; FB*3.5*133
S FBLIPVL="^^RENDERING PROV NAME (LI)^NPI^TAXONOMY CODE"
D HDR1 S FBVI=""
F S FBVI=$O(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI)) Q:FBVI']""!(FBOUT) D:FB5010PV]"" PRNT5010(2,FB5010PV) S FB5010PV=FBVI D SH Q:FBOUT D Q:FBOUT
.S FBDT=0 F S FBDT=$O(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT)) Q:'FBDT S M=0 F S M=$O(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M)) Q:'M D Q:FBOUT
..I ($Y+4)>IOSL D PAGE Q:FBOUT
..S FBDATA=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M),FBCATC=$P(FBDATA,U,13),FBINS=$P(FBDATA,U,14)
..S FBADJ=$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M,"FBADJ"))
..S FBBILL=$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M,"FBBILL")) ;FB*3.5*163
..S FBINAU=$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M,"FBINAU")) ;FB*3.5*163
..;S FBLOC=1_U_12_U_23_U_33_U_47_U_57_U_63_U_71
..W !
..;S I=1 W ?$P(FBLOC,U,I),$P(FBDATA,U,I)
..W ?1,$P(FBDATA,U,1) ;Service Date
..;S I=2 W ?$P(FBLOC,U,I),$P($P(FBDATA,U,I),",")
..W ?11,$P($P(FBDATA,U,2),",") ;CPT MOD
..;F I=3:1:8 W ?$P(FBLOC,U,I),$P(FBDATA,U,I)
..W ?31,$J($P(FBADJ,U,2),10) ;Units Paid
..W ?43,$P(FBDATA,U,6) ;Batch No.
..W ?54,$P(FBDATA,U,7) ;Invoice No.
..W ?64,$P(FBDATA,U,8) ;Voucher Date
..I $P($P(FBDATA,U,2),",",2)]"" D Q:FBOUT
...N FBI,FBMOD
...F FBI=2:1 S FBMOD=$P($P(FBDATA,U,2),",",FBI) Q:FBMOD="" D Q:FBOUT
....I $Y+7>IOSL D PAGE Q:FBOUT W !," (continued)"
....W !,?16,"-",FBMOD
..W !,$P(FBDATA,U,3) ;Amt Claimed
..W ?13,$P(FBDATA,U,4) ;Amt Paid
..W ?23,$S($P(FBADJ,U,3)]"":$P(FBADJ,U,3),1:$P(FBDATA,U,5)) ;Adj Code
..W ?33,$J($S($P(FBADJ,U,4)]"":$J($P(FBADJ,U,4),14),1:$P(FBADJ,U,1)),14) ;Adj Amts
..W ?48,$P(FBADJ,U,5) ;Remit Remarks
..W ?60,$P(FBADJ,U,6) ;Patient Account No.
..W !,?3,$S(FBBILL:"Y",1:"N"),?9,FBBILL ;FB*3.5*163 Billed Bill No.
..W ?24,FBINAU ;FB*3.5*163 Ins Auth No.
..S FBPDX=$P(FBDATA,U,10),FBPDXC=$$ICD9^FBCSV1(FBPDX,$$DT2FMDT^FBCSV1($P(FBDATA,U))),$P(FBDATA,U,10)=$E($$ICD9P^FBCSV1(FBPDX,3,$$DT2FMDT^FBCSV1($P(FBDATA,U))),1,19),FBPDXC=$S(FBPDXC="":"",1:" ("_FBPDXC_")")
..W !?3,"Primary Dx: ",$P(FBDATA,U,10),FBPDXC,?45,"S/C Condition? ",$P(FBDATA,U,9) W ?66,"Obl.#: ",$P(FBDATA,U,11)
..I FBCATC!FBINS D
...W !?5,">>>"
...I FBCATC=0 W "Cost recover from insurance."
...I FBCATC=1 W "Cost recover from means testing"_$S(FBINS:" and insurance.",1:".")
...I FBCATC=2 W "Cost recover from LTC co-pay"_$S(FBINS:" and insurance.",1:".")
...I FBCATC=3 W $S(FBINS:"Cost recover from insurance, ",1:"")_"1010EC Missing for LTC Patient."
...I FBCATC=4 W $S(FBINS:"Cost Recover from insurance and ",1:"")_"Potential Cost Recover from LTC co-pay."
.. D PRNT5010(3,M) ; FB*3.5*122
.. D PRTAUTH(M) ; FB*3.5*163
..S A3=".00"
I FB5010PV]"" D PRNT5010(2,FB5010PV) ; FB*3.5*122
Q
HDR ;main header
D HDR^FBPCR Q:FBOUT
HDR1 W !!?(IOM-(13+$L(FBXPROG))/2),"NVC PROGRAM: ",FBXPROG ;FB*3.5*163 - Changed from FEE to NVC
;W !!,?2,"Svc Date",?11,"CPT-MOD",?23,"Amount",?33," Amount",?42,"Susp",?49,"Travel",?57,"Batch",?63,"Invoice",?71,"Voucher"
;W !,?23,"Claimed",?35,"Paid",?42,"Code",?50,"Paid",?58,"Num",?64,"Num",?72,"Date",!,FBDASH
W !!,?1,"Svc Date",?11,"CPT-MOD ",?19,"Travel Paid",?31,"Units Paid",?43,"Batch No.",?54,"Inv No.",?64,"Voucher Date"
;W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36,"Adj Amounts",?48,"Remit Remark",?61,"Patient Account No",!,FBDASH
W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36,"Adj Amounts",?48,"Remit Remark",?61,"Patient Account No" ;FB*3.5*163
W !,"Billed?",?9,"Bill#",?24,"Ins Auth#",!,FBDASH ;FB*3.5*163
Q
SH ;subheader - vendor, prints when name changed
I ($Y+6)>IOSL D HDR Q:FBOUT
;W !!,"Vendor: ",$P(FBVI,";"),?41,"Vendor ID/NPI: ",$P(FBVI,";",2)
W !!,"Vendor: ",$P(FBVI,";"),?41,"Vendor ID: ",$P($P(FBVI,";",2),"/",1)
W !?20,"Fee Basis Billing Provider NPI: ",$P(FBVI,"/",2)
Q
CR ;read for display
S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1
Q
PAGE ;new page
D HDR Q:FBOUT D SH
Q
PRNT5010(FBTYPE,FBNODE) ; Format and print based on data type ; FB*3.5*122 FB*3.5*133
N FBVDAT,FBCNT
I $G(FBTYPE)=2 D Q ; Vender level
. I $G(FBPSF)]"",$G(FBPT)]"",$G(FBPI)]"",$G(FBNODE)]"",$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBNODE))]"" S FBVDAT=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBNODE)
. E Q
. F FBCNT=1,6 I $P(FBVDAT,U,FBCNT)]"" D
.. W !,$P(FBPVLIST,U,FBCNT)_": "_$P(FBVDAT,U,FBCNT),?55,$P(FBPVLIST,U,FBCNT+1)_": "_$P(FBVDAT,U,FBCNT+1)
.. W !,?6,$P(FBPVLIST,U,FBCNT+2)_": "_$P(FBVDAT,U,FBCNT+2)
. F FBCNT=4,11,9 I $P(FBVDAT,U,FBCNT)]"" D
.. W !,$P(FBPVLIST,U,FBCNT)_": "_$P(FBVDAT,U,FBCNT),?55,$P(FBPVLIST,U,FBCNT+1)_": "_$P(FBVDAT,U,FBCNT+1)
. I $P(FBVDAT,U,20)]"" D
.. W !," SERVICING FACILITY ADDRESS: "_$P(FBVDAT,U,20),!," "_$P(FBVDAT,U,21)_", "
.. I $P(FBVDAT,U,22)]"" W $$GET1^DIQ(5,$P(FBVDAT,U,22)_",",.01)
.. W " "_$P(FBVDAT,U,23),!
;
I $G(FBTYPE)=3 D Q ; Line Item level
. I $G(FBPSF)]"",$G(FBPT)]"",$G(FBPI)]"",$G(FBVI)]"",$G(FBDT)]"",$G(FBNODE)]"",$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT003"))]"" D
.. S FBVDAT=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT003")
.. W !,?8,$P(FBLIPVL,U,3)_": "_$P(FBVDAT,U,3)
.. W !,?12,$P(FBLIPVL,U,4)_": "_$P(FBVDAT,U,4),?35,$P(FBLIPVL,U,5),": ",$P(FBVDAT,U,5),!!
. ;
. ; FB*3.5*133
. I $G(FBPSF)]"",$G(FBPT)]"",$G(FBPI)]"",$G(FBVI)]"",$G(FBDT)]"",$G(FBNODE)]"",$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT004"))]"" D
.. S FBVDAT=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT004")
.. F FBCNT=1,6 I $P(FBVDAT,U,FBCNT)]"" D
... W !,$P(FBPVL133,U,FBCNT)_": "_$P(FBVDAT,U,FBCNT),?55,$P(FBPVL133,U,FBCNT+1)_": "_$P(FBVDAT,U,FBCNT+1)
... W !,?6,$P(FBPVL133,U,FBCNT+2)_": "_$P(FBVDAT,U,FBCNT+2)
.. F FBCNT=4,11,9 I $P(FBVDAT,U,FBCNT)]"" D
... W !,$P(FBPVL133,U,FBCNT)_": "_$P(FBVDAT,U,FBCNT),?55,$P(FBPVL133,U,FBCNT+1)_": "_$P(FBVDAT,U,FBCNT+1)
. ;
. I $G(FBPSF)]"",$G(FBPT)]"",$G(FBPI)]"",$G(FBVI)]"",$G(FBDT)]"",$G(FBNODE)]"",$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT005"))]"" D
.. S FBVDAT=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT005")
.. W !," SERVICING FACILITY ADDRESS: "_$P(FBVDAT,U,1),!," "_$P(FBVDAT,U,2)_", "
.. I $P(FBVDAT,U,3)]"" W $$GET1^DIQ(5,$P(FBVDAT,U,3)_",",.01)
.. W " "_$P(FBVDAT,U,4),!
Q
;
FBAUTH(FBAUTH,FBDFN) ;Get Authorization Data if it exists FB*3.5*163
N FBIEN
S (FBADX1,FBADX2,FBADX3,FBAICD,FBAREF,FBAREFA,FBARNPI,FBAVND,FBAVNDA,FBAVNPI,FBAVTAX)=""
Q:FBAUTH=""
S FBIEN=FBAUTH_","_FBDFN_","
S FBADX1=$$GET1^DIQ(161.01,FBIEN_",",.08)
S FBADX2=$$GET1^DIQ(161.01,FBIEN_",",.085)
S FBADX3=$$GET1^DIQ(161.01,FBIEN_",",.086)
S FBAICD=$$GET1^DIQ(161.01,FBIEN_",",.087)
S FBAREF=$$GET1^DIQ(161.01,FBIEN_",",104)
S FBAREFA=$$GET1^DIQ(161.01,FBIEN_",",104,"I")
I FBAREFA'="" S FBARNPI=$$GET1^DIQ(200,FBAREFA_",",41.99)
S FBAVND=$$GET1^DIQ(161.01,FBIEN_",",.04)
S FBAVNDA=$$GET1^DIQ(161.01,FBIEN_",",.04,"I")
I FBAVNDA'="" D
. S FBAVNPI=$$GET1^DIQ(161.2,FBAVNDA_",",41.01)
. S FBAVTAX=$$GET1^DIQ(161.2,FBAVNDA_",",42)
Q
;
PRTAUTH(FBX) ;Print Data from Authorization FB*3.5*163
N FBAUPR
I '$D(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBX,"FBAUTH")) Q
S FBAUPR=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBX,"FBAUTH")
W !,"** Authorization Data **"
W !," Diagnosis: ",$P(FBAUPR,U,1)," / ",$P(FBAUPR,U,2)," / ",$P(FBAUPR,U,3)," / ",$P(FBAUPR,U,4)
W !," Rendering Provider: "_$P(FBAUPR,U,7)
W !," NPI: "_$P(FBAUPR,U,8),?30,"TAXONOMY CODE: "_$P(FBAUPR,U,9)
W !," Referring Provider: "_$P(FBAUPR,U,5)
W !," NPI: "_$P(FBAUPR,U,6)
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPCR2 14050 printed Sep 23, 2025@19:35:41 Page 2
FBPCR2 ;AISC/DMK,GRR,TET-OUTPATIENT POTENTIAL COST RECOVERY SORT/PRINT ;7/1/2006
+1 ;;3.5;FEE BASIS;**4,48,55,69,76,98,122,133,163**;JAN 30, 1995;Build 21
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ;entry point
+1 SET (FBCATC,FBINS,FBPSF)=0
SORT ;sort by date finalized, patient, vendor, treatment ien, service ien
+1 ; FB*3.5*122
SET FBPVLIST="ATTENDING PROV NAME^ATTENDING PROV NPI^ATTENDING PROV TAXONOMY CODE^OPERATING PROV NAME^OPERATING PROV NPI^RENDERING PROV NAME"
+2 ; FB*3.5*122
SET FBPVLIST=FBPVLIST_"^RENDERING PROV NPI^RENDERING PROV TAXONOMY CODE^SERVICING PROV NAME^SERVICING PROV NPI^REFERRING PROV NAME^REFERRING PROV NPI"
+3 ; FB*3.5*122
SET FBLIPVL="^^LI-RENDERING-PROV-NAME^LI-RENDERING-PROV-NPI^LI-RENDERING-PROV-TAXONOMY"
+4 SET I=FBBDATE-.1
FOR
SET I=$ORDER(^FBAAC("AK",I))
if 'I!(I>FBEDATE)
QUIT
SET J=0
FOR
SET J=$ORDER(^FBAAC("AK",I,J))
if 'J
QUIT
Begin DoDot:1
+5 SET DFN=J
DO VET^FBPCR
+6 SET K=0
FOR
SET K=$ORDER(^FBAAC("AK",I,J,K))
if 'K
QUIT
SET L=0
FOR
SET L=$ORDER(^FBAAC("AK",I,J,K,L))
if 'L
QUIT
DO SETTR
SET M=0
FOR
SET M=$ORDER(^FBAAC("AK",I,J,K,L,M))
if 'M
QUIT
Begin DoDot:2
+7 DO SET
if 'FBPSV&('$DATA(FBPSV(FBPSF)))
QUIT
IF FBCATC!FBINS
DO SETTMP
End DoDot:2
SET (FBCATC,FBINS,FBPSF)=0
End DoDot:1
KILL ;kill variables set in this routine
+1 KILL A1,A2,A3,D,D2,DFN,FBAACPTC,FBBN,FBCATC,FBCP,FBDOB,FBDOS,FBDT,FBDT1,FBIN,FBINS,FBOB,FBP,FBPAT,FBPCR,FBPDX,FBPDXC,FBPID,FBPNAME,FBPSF,FBSC,FBTA,FBTYPE,FBVEN,FBVID,FBVNAME,FBVP,I,J,K,L,M,T,Y,FBMODLE
+2 ; FB*3.5*122 ; FB*3.5*133
KILL FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ,FBDAT002,FBDAT003,FBDAT004,FBDAT005,FBPVLIST,FBLIPVL,FBPVL133
+3 ; FB*3.5*163
KILL FBADX1,FBADX2,FBADX3,FBAICD,FBAIEN,FBAREF,FBAREFA,FBARNPI,FBAUTH,FBAVND,FBAVNDA,FBAVNPI,FBAVTAX
+4 QUIT
SET ;set variables - also entry point from FBPCR67
+1 NEW FBPCR,FBX
+2 SET Y=$GET(^FBAAC(J,1,K,1,L,1,M,0))
if '+$PIECE(Y,U,9)!($GET(^FBAAC(J,1,K,1,L,1,M,"FBREJ"))]"")
QUIT
+3 ; FB*3.5*122
SET FBY=$GET(^FBAAC(J,1,K,1,L,1,M,2))
SET FBDAT003=$GET(^FBAAC(J,1,K,1,L,1,M,3))
+4 ; FB*3.5*133
SET FBDAT004=$GET(^FBAAC(J,1,K,1,L,1,M,4))
SET FBDAT005=$GET(^FBAAC(J,1,K,1,L,1,M,5))
+5 SET FBVNAME=$EXTRACT($PIECE($GET(^FBAAV(K,0)),U),1,23)
SET FBVID=$SELECT(FBVNAME]"":$PIECE(^(0),U,2)_"/"_$SELECT($PIECE($GET(^(3)),U,2)]"":$PIECE(^(3),U,2),1:"**********"),1:"")
+6 SET FBP=+$PIECE(Y,U,9)
SET FBSC=$PIECE(Y,U,27)
SET FBPDX=+$PIECE(Y,U,23)
SET FBPSF=+$PIECE(Y,U,12)
+7 ; FB*3.5*122
SET ^TMP($JOB,"FB",FBPSF)=$GET(^FBAAC(J,1,K,1,L,4))
+8 SET FBSC=$SELECT(FBSC="Y":"YES",FBSC="N":"NO",1:"-")
+9 SET T=$PIECE(Y,U,5)
SET D2=$PIECE(Y,U,6)
SET FBDOS=D2
SET D2=$$DATX^FBAAUTL(D2)
SET FBCP=$PIECE(Y,U,18)
SET FBCP=$SELECT(FBCP=1:"(C&P)",1:"")
+10 ; FB*3.5*163 - baa start
+11 ;Q:FBCP]""!('FBPSV&('$D(FBPSV(FBPSF)))) S FBPCR=+$G(^FBAAC(J,1,K,1,L,0)),FBCATC=$$CATC^FBPCR(DFN,FBPCR,+$P(Y,U,18)),FBINS=$S(FBSC["N":$$INSURED^FBPCR4(DFN,FBPCR),1:0) Q:'FBCATC&'FBINS
+12 if FBCP]""!('FBPSV&('$DATA(FBPSV(FBPSF))))
QUIT
+13 SET FBPCR=+$GET(^FBAAC(J,1,K,1,L,0))
SET FBCATC=$$CATC^FBPCR(DFN,FBPCR,+$PIECE(Y,U,18))
SET FBINS=$$INSURED^FBPCR4(DFN,FBPCR)
+14 if 'FBCATC&'FBINS
QUIT
+15 ; FB*3.5*163 - baa end
+16 SET FBAACPTC=$$CPT^FBAAUTL4($PIECE(Y,U))
+17 SET FBOB=$PIECE(Y,U,10)
+18 IF T]""
SET T=$PIECE($GET(^FBAA(161.27,+T,0)),U)
+19 SET FBTYPE=$PIECE(Y,U,20)
SET FBVP=$PIECE(Y,U,21)
SET FBIN=$PIECE(Y,U,16)
SET FBBN=$PIECE(Y,U,8)
SET FBBN=$SELECT(FBBN']"":"",$DATA(^FBAA(161.7,FBBN,0)):$PIECE(^(0),U),1:"")
SET FBBN=$SELECT(FBBN="":"",1:$EXTRACT("00000",$LENGTH(FBBN)+1,5)_FBBN)
+20 SET FBVEN=FBVNAME_";"_FBVID
SET FBPAT=FBPNAME_";"_DFN
+21 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
+22 ;suspend code
IF T]""
SET T=$PIECE($GET(^FBAA(161.27,+T,0)),U)
+23 ;suspend amount
SET TAMT=$FNUMBER($PIECE(Y,U,4),"",2)
+24 ;units paid
SET FBUNITS=$PIECE(FBY,U,14)
+25 ;patient account number
SET FBCSID=$PIECE(FBY,U,16)
+26 SET FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
+27 ;adjustment codes
SET FBADJLR=$PIECE(FBX,U)
+28 ;adjustment amounts
SET FBADJLA=$PIECE(FBX,U,2)
+29 ;remit remarks
SET FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")
+30 ;output format
+31 SET A1=$JUSTIFY($PIECE(Y,U,2),6,2)
SET A2=$JUSTIFY($PIECE(Y,U,3),6,2)
SET A3=$JUSTIFY(A3,6,2)
SET FBIN=$JUSTIFY(FBIN,7)
+32 SET FBDT1=$SELECT(FBVP="VP":"#",1:"")_$SELECT(FBTYPE="R":"*",1:" ")_FBDT
+33 ;FB*3.5*163 - Get data from fee basis authorization if available
+34 ;FB*3.5*163
SET FBAUTH=$PIECE(FBDAT003,U,9)
+35 ;FB*3.5*163
IF FBAUTH
DO FBAUTH(FBAUTH,J)
+36 QUIT
+37 ;
SETTMP ;sort data by primary service facility, patient, fee program, vendor, date
+1 ;FB*3.5*163
NEW FBBILL,FBINAU,FBSKIP
+2 ;FB*3.5*163
SET FBSKIP=0
SET (FBBILL,FBINAU)=""
+3 if $$FILTER^FBPCR4()=0
QUIT
+4 IF $PIECE(Y,U,9)'=FBPI
QUIT
+5 ;FB*3.5*163
DO CHKBILL^IBFBUTIL(FBIN)
+6 ;Quit if running for not previously billed and bill IEN exists on File #360 FB*3.5*163
IF $GET(FBSKIP)
IF $GET(FBNPB)
QUIT
+7 SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M)=FBDT1_U_FBAACPTC_FBCP_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_FBPI_U_FBCATC_U_FBINS
+8 SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID
+9 ; FB*3.5*163 Bill Number
IF FBBILL
SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBBILL")=FBBILL
+10 ; FB*3.5*163 Insurance Auth
IF FBINAU
SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBINAU")=FBINAU
+11 ; FB*3.5*163
IF $GET(FBAUTH)'=""
SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBAUTH")=FBADX1_U_FBADX2_U_FBADX3_U_FBAICD_U_FBAREF_U_$GET(FBARNPI)_U_FBAVND_U_$GET(FBAVNPI)_U_$GET(FBAVTAX)
+12 ;I $TR($G(FBDAT002),U)'="" S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN)=FBDAT002 K FBDAT002 ; FB*3.5*122
+13 ;I $TR($G(FBDAT004),U)'="" S $P(^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN),U,20)=FBDAT004 K FBDAT004 ; FB*3.5*122
+14 ; FB*3.5*122
IF $TRANSLATE($GET(FBDAT003),U)'=""
SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBDAT003")=FBDAT003
KILL FBDAT003
+15 ; FB*3.5*133
IF $TRANSLATE($GET(FBDAT004),U)'=""
SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBDAT004")=FBDAT004
KILL FBDAT004
+16 ; FB*3.5*133
IF $TRANSLATE($GET(FBDAT005),U)'=""
SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBDAT005")=FBDAT005
KILL FBDAT005
+17 QUIT
SETTR SET D=$SELECT($DATA(^FBAAC(J,1,K,1,L,0)):$PIECE(^(0),"^",1),1:"")
SET A3=".00"
+1 IF D]""
IF $DATA(^FBAAC(J,3,"AB",D))
SET FBTA=$ORDER(^FBAAC(J,3,"AB",D,0))
SET A3=$SELECT($PIECE(^FBAAC(J,3,FBTA,0),"^",3)]"":$PIECE(^(0),"^",3),1:.0001)
+2 SET FBDT=$$DATX^FBAAUTL(D)
+3 ;S FBDAT002=$G(^FBAAC(J,1,K,1,L,2)) ; FB*3.5*122
+4 ;S FBDAT004=$G(^FBAAC(J,1,K,1,L,4)) ; FB*3.5*122
+5 QUIT
EN1 ;entry point to set variables, called by fbpcr67, anc
+1 NEW FBVEN,FBPAT,FBDT1
+2 DO SETTR
DO SET
+3 QUIT
PRINT ;write output
+1 NEW FB5010PV,FBLIPVL,FBPVLIST,FBBILL,FBINAU
+2 SET FB5010PV=""
+3 SET FBPVLIST="ATTENDING PROV NAME^NPI^TAXONOMY CODE^OPERATING PROV NAME^NPI^RENDERING PROV NAME^NPI^TAXONOMY CODE"
+4 SET FBPVLIST=FBPVLIST_"^SERVICING PROV NAME^NPI^REFERRING PROV NAME^NPI"
+5 ; FB*3.5*133
SET FBPVL133="ATTENDING PROV NAME^NPI^TAXONOMY CODE^OPERATING PROV NAME^NPI^RENDERING PROV NAME"
+6 ; FB*3.5*133
SET FBPVL133=FBPVL133_"^NPI^TAXONOMY CODE^SERVICING PROV NAME^NPI^REFERRING PROV NAME^NPI"
+7 SET FBLIPVL="^^RENDERING PROV NAME (LI)^NPI^TAXONOMY CODE"
+8 DO HDR1
SET FBVI=""
+9 FOR
SET FBVI=$ORDER(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI))
if FBVI']""!(FBOUT)
QUIT
if FB5010PV]""
DO PRNT5010(2,FB5010PV)
SET FB5010PV=FBVI
DO SH
if FBOUT
QUIT
Begin DoDot:1
+10 SET FBDT=0
FOR
SET FBDT=$ORDER(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT))
if 'FBDT
QUIT
SET M=0
FOR
SET M=$ORDER(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M))
if 'M
QUIT
Begin DoDot:2
+11 IF ($Y+4)>IOSL
DO PAGE
if FBOUT
QUIT
+12 SET FBDATA=^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M)
SET FBCATC=$PIECE(FBDATA,U,13)
SET FBINS=$PIECE(FBDATA,U,14)
+13 SET FBADJ=$GET(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M,"FBADJ"))
+14 ;FB*3.5*163
SET FBBILL=$GET(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M,"FBBILL"))
+15 ;FB*3.5*163
SET FBINAU=$GET(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M,"FBINAU"))
+16 ;S FBLOC=1_U_12_U_23_U_33_U_47_U_57_U_63_U_71
+17 WRITE !
+18 ;S I=1 W ?$P(FBLOC,U,I),$P(FBDATA,U,I)
+19 ;Service Date
WRITE ?1,$PIECE(FBDATA,U,1)
+20 ;S I=2 W ?$P(FBLOC,U,I),$P($P(FBDATA,U,I),",")
+21 ;CPT MOD
WRITE ?11,$PIECE($PIECE(FBDATA,U,2),",")
+22 ;F I=3:1:8 W ?$P(FBLOC,U,I),$P(FBDATA,U,I)
+23 ;Units Paid
WRITE ?31,$JUSTIFY($PIECE(FBADJ,U,2),10)
+24 ;Batch No.
WRITE ?43,$PIECE(FBDATA,U,6)
+25 ;Invoice No.
WRITE ?54,$PIECE(FBDATA,U,7)
+26 ;Voucher Date
WRITE ?64,$PIECE(FBDATA,U,8)
+27 IF $PIECE($PIECE(FBDATA,U,2),",",2)]""
Begin DoDot:3
+28 NEW FBI,FBMOD
+29 FOR FBI=2:1
SET FBMOD=$PIECE($PIECE(FBDATA,U,2),",",FBI)
if FBMOD=""
QUIT
Begin DoDot:4
+30 IF $Y+7>IOSL
DO PAGE
if FBOUT
QUIT
WRITE !," (continued)"
+31 WRITE !,?16,"-",FBMOD
End DoDot:4
if FBOUT
QUIT
End DoDot:3
if FBOUT
QUIT
+32 ;Amt Claimed
WRITE !,$PIECE(FBDATA,U,3)
+33 ;Amt Paid
WRITE ?13,$PIECE(FBDATA,U,4)
+34 ;Adj Code
WRITE ?23,$SELECT($PIECE(FBADJ,U,3)]"":$PIECE(FBADJ,U,3),1:$PIECE(FBDATA,U,5))
+35 ;Adj Amts
WRITE ?33,$JUSTIFY($SELECT($PIECE(FBADJ,U,4)]"":$JUSTIFY($PIECE(FBADJ,U,4),14),1:$PIECE(FBADJ,U,1)),14)
+36 ;Remit Remarks
WRITE ?48,$PIECE(FBADJ,U,5)
+37 ;Patient Account No.
WRITE ?60,$PIECE(FBADJ,U,6)
+38 ;FB*3.5*163 Billed Bill No.
WRITE !,?3,$SELECT(FBBILL:"Y",1:"N"),?9,FBBILL
+39 ;FB*3.5*163 Ins Auth No.
WRITE ?24,FBINAU
+40 SET FBPDX=$PIECE(FBDATA,U,10)
SET FBPDXC=$$ICD9^FBCSV1(FBPDX,$$DT2FMDT^FBCSV1($PIECE(FBDATA,U)))
SET $PIECE(FBDATA,U,10)=$EXTRACT($$ICD9P^FBCSV1(FBPDX,3,$$DT2FMDT^FBCSV1($PIECE(FBDATA,U))),1,19)
SET FBPDXC=$SELECT(FBPDXC="":"",1:" ("_FBPDXC_")")
+41 WRITE !?3,"Primary Dx: ",$PIECE(FBDATA,U,10),FBPDXC,?45,"S/C Condition? ",$PIECE(FBDATA,U,9)
WRITE ?66,"Obl.#: ",$PIECE(FBDATA,U,11)
+42 IF FBCATC!FBINS
Begin DoDot:3
+43 WRITE !?5,">>>"
+44 IF FBCATC=0
WRITE "Cost recover from insurance."
+45 IF FBCATC=1
WRITE "Cost recover from means testing"_$SELECT(FBINS:" and insurance.",1:".")
+46 IF FBCATC=2
WRITE "Cost recover from LTC co-pay"_$SELECT(FBINS:" and insurance.",1:".")
+47 IF FBCATC=3
WRITE $SELECT(FBINS:"Cost recover from insurance, ",1:"")_"1010EC Missing for LTC Patient."
+48 IF FBCATC=4
WRITE $SELECT(FBINS:"Cost Recover from insurance and ",1:"")_"Potential Cost Recover from LTC co-pay."
End DoDot:3
+49 ; FB*3.5*122
DO PRNT5010(3,M)
+50 ; FB*3.5*163
DO PRTAUTH(M)
+51 SET A3=".00"
End DoDot:2
if FBOUT
QUIT
End DoDot:1
if FBOUT
QUIT
+52 ; FB*3.5*122
IF FB5010PV]""
DO PRNT5010(2,FB5010PV)
+53 QUIT
HDR ;main header
+1 DO HDR^FBPCR
if FBOUT
QUIT
HDR1 ;FB*3.5*163 - Changed from FEE to NVC
WRITE !!?(IOM-(13+$LENGTH(FBXPROG))/2),"NVC PROGRAM: ",FBXPROG
+1 ;W !!,?2,"Svc Date",?11,"CPT-MOD",?23,"Amount",?33," Amount",?42,"Susp",?49,"Travel",?57,"Batch",?63,"Invoice",?71,"Voucher"
+2 ;W !,?23,"Claimed",?35,"Paid",?42,"Code",?50,"Paid",?58,"Num",?64,"Num",?72,"Date",!,FBDASH
+3 WRITE !!,?1,"Svc Date",?11,"CPT-MOD ",?19,"Travel Paid",?31,"Units Paid",?43,"Batch No.",?54,"Inv No.",?64,"Voucher Date"
+4 ;W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36,"Adj Amounts",?48,"Remit Remark",?61,"Patient Account No",!,FBDASH
+5 ;FB*3.5*163
WRITE !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36,"Adj Amounts",?48,"Remit Remark",?61,"Patient Account No"
+6 ;FB*3.5*163
WRITE !,"Billed?",?9,"Bill#",?24,"Ins Auth#",!,FBDASH
+7 QUIT
SH ;subheader - vendor, prints when name changed
+1 IF ($Y+6)>IOSL
DO HDR
if FBOUT
QUIT
+2 ;W !!,"Vendor: ",$P(FBVI,";"),?41,"Vendor ID/NPI: ",$P(FBVI,";",2)
+3 WRITE !!,"Vendor: ",$PIECE(FBVI,";"),?41,"Vendor ID: ",$PIECE($PIECE(FBVI,";",2),"/",1)
+4 WRITE !?20,"Fee Basis Billing Provider NPI: ",$PIECE(FBVI,"/",2)
+5 QUIT
CR ;read for display
+1 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
SET FBOUT=1
+2 QUIT
PAGE ;new page
+1 DO HDR
if FBOUT
QUIT
DO SH
+2 QUIT
PRNT5010(FBTYPE,FBNODE) ; Format and print based on data type ; FB*3.5*122 FB*3.5*133
+1 NEW FBVDAT,FBCNT
+2 ; Vender level
IF $GET(FBTYPE)=2
Begin DoDot:1
+3 IF $GET(FBPSF)]""
IF $GET(FBPT)]""
IF $GET(FBPI)]""
IF $GET(FBNODE)]""
IF $GET(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBNODE))]""
SET FBVDAT=^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBNODE)
+4 IF '$TEST
QUIT
+5 FOR FBCNT=1,6
IF $PIECE(FBVDAT,U,FBCNT)]""
Begin DoDot:2
+6 WRITE !,$PIECE(FBPVLIST,U,FBCNT)_": "_$PIECE(FBVDAT,U,FBCNT),?55,$PIECE(FBPVLIST,U,FBCNT+1)_": "_$PIECE(FBVDAT,U,FBCNT+1)
+7 WRITE !,?6,$PIECE(FBPVLIST,U,FBCNT+2)_": "_$PIECE(FBVDAT,U,FBCNT+2)
End DoDot:2
+8 FOR FBCNT=4,11,9
IF $PIECE(FBVDAT,U,FBCNT)]""
Begin DoDot:2
+9 WRITE !,$PIECE(FBPVLIST,U,FBCNT)_": "_$PIECE(FBVDAT,U,FBCNT),?55,$PIECE(FBPVLIST,U,FBCNT+1)_": "_$PIECE(FBVDAT,U,FBCNT+1)
End DoDot:2
+10 IF $PIECE(FBVDAT,U,20)]""
Begin DoDot:2
+11 WRITE !," SERVICING FACILITY ADDRESS: "_$PIECE(FBVDAT,U,20),!," "_$PIECE(FBVDAT,U,21)_", "
+12 IF $PIECE(FBVDAT,U,22)]""
WRITE $$GET1^DIQ(5,$PIECE(FBVDAT,U,22)_",",.01)
+13 WRITE " "_$PIECE(FBVDAT,U,23),!
End DoDot:2
End DoDot:1
QUIT
+14 ;
+15 ; Line Item level
IF $GET(FBTYPE)=3
Begin DoDot:1
+16 IF $GET(FBPSF)]""
IF $GET(FBPT)]""
IF $GET(FBPI)]""
IF $GET(FBVI)]""
IF $GET(FBDT)]""
IF $GET(FBNODE)]""
IF $GET(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT003"))]""
Begin DoDot:2
+17 SET FBVDAT=^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT003")
+18 WRITE !,?8,$PIECE(FBLIPVL,U,3)_": "_$PIECE(FBVDAT,U,3)
+19 WRITE !,?12,$PIECE(FBLIPVL,U,4)_": "_$PIECE(FBVDAT,U,4),?35,$PIECE(FBLIPVL,U,5),": ",$PIECE(FBVDAT,U,5),!!
End DoDot:2
+20 ;
+21 ; FB*3.5*133
+22 IF $GET(FBPSF)]""
IF $GET(FBPT)]""
IF $GET(FBPI)]""
IF $GET(FBVI)]""
IF $GET(FBDT)]""
IF $GET(FBNODE)]""
IF $GET(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT004"))]""
Begin DoDot:2
+23 SET FBVDAT=^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT004")
+24 FOR FBCNT=1,6
IF $PIECE(FBVDAT,U,FBCNT)]""
Begin DoDot:3
+25 WRITE !,$PIECE(FBPVL133,U,FBCNT)_": "_$PIECE(FBVDAT,U,FBCNT),?55,$PIECE(FBPVL133,U,FBCNT+1)_": "_$PIECE(FBVDAT,U,FBCNT+1)
+26 WRITE !,?6,$PIECE(FBPVL133,U,FBCNT+2)_": "_$PIECE(FBVDAT,U,FBCNT+2)
End DoDot:3
+27 FOR FBCNT=4,11,9
IF $PIECE(FBVDAT,U,FBCNT)]""
Begin DoDot:3
+28 WRITE !,$PIECE(FBPVL133,U,FBCNT)_": "_$PIECE(FBVDAT,U,FBCNT),?55,$PIECE(FBPVL133,U,FBCNT+1)_": "_$PIECE(FBVDAT,U,FBCNT+1)
End DoDot:3
End DoDot:2
+29 ;
+30 IF $GET(FBPSF)]""
IF $GET(FBPT)]""
IF $GET(FBPI)]""
IF $GET(FBVI)]""
IF $GET(FBDT)]""
IF $GET(FBNODE)]""
IF $GET(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT005"))]""
Begin DoDot:2
+31 SET FBVDAT=^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBNODE,"FBDAT005")
+32 WRITE !," SERVICING FACILITY ADDRESS: "_$PIECE(FBVDAT,U,1),!," "_$PIECE(FBVDAT,U,2)_", "
+33 IF $PIECE(FBVDAT,U,3)]""
WRITE $$GET1^DIQ(5,$PIECE(FBVDAT,U,3)_",",.01)
+34 WRITE " "_$PIECE(FBVDAT,U,4),!
End DoDot:2
End DoDot:1
QUIT
+35 QUIT
+36 ;
FBAUTH(FBAUTH,FBDFN) ;Get Authorization Data if it exists FB*3.5*163
+1 NEW FBIEN
+2 SET (FBADX1,FBADX2,FBADX3,FBAICD,FBAREF,FBAREFA,FBARNPI,FBAVND,FBAVNDA,FBAVNPI,FBAVTAX)=""
+3 if FBAUTH=""
QUIT
+4 SET FBIEN=FBAUTH_","_FBDFN_","
+5 SET FBADX1=$$GET1^DIQ(161.01,FBIEN_",",.08)
+6 SET FBADX2=$$GET1^DIQ(161.01,FBIEN_",",.085)
+7 SET FBADX3=$$GET1^DIQ(161.01,FBIEN_",",.086)
+8 SET FBAICD=$$GET1^DIQ(161.01,FBIEN_",",.087)
+9 SET FBAREF=$$GET1^DIQ(161.01,FBIEN_",",104)
+10 SET FBAREFA=$$GET1^DIQ(161.01,FBIEN_",",104,"I")
+11 IF FBAREFA'=""
SET FBARNPI=$$GET1^DIQ(200,FBAREFA_",",41.99)
+12 SET FBAVND=$$GET1^DIQ(161.01,FBIEN_",",.04)
+13 SET FBAVNDA=$$GET1^DIQ(161.01,FBIEN_",",.04,"I")
+14 IF FBAVNDA'=""
Begin DoDot:1
+15 SET FBAVNPI=$$GET1^DIQ(161.2,FBAVNDA_",",41.01)
+16 SET FBAVTAX=$$GET1^DIQ(161.2,FBAVNDA_",",42)
End DoDot:1
+17 QUIT
+18 ;
PRTAUTH(FBX) ;Print Data from Authorization FB*3.5*163
+1 NEW FBAUPR
+2 IF '$DATA(^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBX,"FBAUTH"))
QUIT
+3 SET FBAUPR=^TMP($JOB,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBX,"FBAUTH")
+4 WRITE !,"** Authorization Data **"
+5 WRITE !," Diagnosis: ",$PIECE(FBAUPR,U,1)," / ",$PIECE(FBAUPR,U,2)," / ",$PIECE(FBAUPR,U,3)," / ",$PIECE(FBAUPR,U,4)
+6 WRITE !," Rendering Provider: "_$PIECE(FBAUPR,U,7)
+7 WRITE !," NPI: "_$PIECE(FBAUPR,U,8),?30,"TAXONOMY CODE: "_$PIECE(FBAUPR,U,9)
+8 WRITE !," Referring Provider: "_$PIECE(FBAUPR,U,5)
+9 WRITE !," NPI: "_$PIECE(FBAUPR,U,6)
+10 WRITE !
+11 QUIT
