FBCHVH ;AISC/DMK - VENDOR PAYMENT HISTORY ;7/17/2003
;;3.5;FEE BASIS;**55,61,122,108,135,144,123,164**;JAN 30, 1995;Build 28
;;Per VA Directive 6402, this routine should not be modified.
GETVEN K FBAANQ D GETVEN^FBAAUTL1 G END:IFN']""
D DATE^FBAAUTL G:FBPOP GETVEN S ZZ=9999999.9999,FBBEG=ZZ-ENDDATE,FBEND=ZZ-BEGDATE
I '$D(^FBAAI("AF",IFN)) W !,*7,"No invoices on line for this vendor." G GETVEN
S VAR="IFN^FBBEG^FBEND^BEGDATE^ENDDATE"_$S($D(FBPROG):"^FBPROG",1:""),VAL=IFN_"^"_FBBEG_"^"_FBEND_"^"_BEGDATE_"^"_ENDDATE_$S($D(FBPROG):"^"_FBPROG,1:""),PGM="START^FBCHVH" D ZIS^FBAAUTL G:FBPOP END S:IO=IO(0) FBAANQ=1
START S:'$D(FBPROG) FBPROG=6 S FBHEAD="VENDOR",Q="",$P(Q,"=",80)="=",FBAAOUT=0 U IO D GETDAT S:$E(IOST,1,2)'["C-" FBPG=1 D HEDC
F FBM=FBBEG-.1:0 S FBM=$O(^FBAAI("AF",IFN,FBM)) Q:FBM'>0!(FBM>FBEND) F FBI=0:0 S FBI=$O(^FBAAI("AF",IFN,FBM,FBI)) Q:FBI'>0!(FBAAOUT) I $D(^FBAAI(FBI,0)),$P(^(0),"^",12)=FBPROG,'$D(^("FBREJ")) D GETINV
G:$D(FBAANQ) GETVEN
END K DA,BEGDATE,ENDDATE,FBBEG,FBEND,DIC,FBAANQ,FBAAOUT,FBDX,FBI,FBIN,FBPROC,FBVEN,FBVID,IFN,J,K,L,PGM,Q,VADM,VAERR,VAL,VAR,X,Y,VA,ZZ,FBM,FBHEAD,FBPROG,FBPG,FBVINDT
D CLOSE^FBAAUTL Q
GETINV ;
N FBADJLA,FBADJLR,FBCDAYS,FBCSID,FBFPPSC,FBFPPSL,FBRRMKL,FBY2,FBY3,FBY5,FBADMTDX,FBPOA,FBCNTRN,B
N AD
S FBIN=^FBAAI(FBI,0)
S FBY2=$G(^FBAAI(FBI,2))
S FBY3=$G(^FBAAI(FBI,3))
S FBY5=$G(^FBAAI(FBI,5))
F J=1,2,3,4,6,7,8,9,10,11,13,14 S FBIN(J)=$P(FBIN,"^",J)
S FBVINDT=$P(FBY2,"^",2) D FBCKI^FBAACCB1(FBI)
S FBVEN=$S($D(^FBAAV(+FBIN(3),0)):$P(^(0),"^",1),1:"") I FBVEN]"" S FBVID=$P(^(0),"^",2)
S DFN=FBIN(4) Q:'DFN D DEM^VADPT
S Y=FBIN(2) D CDAT S FBIN(2)=Y
S Y=FBIN(6) D CDAT S FBIN(6)=Y,Y=FBIN(7) D CDAT S FBIN(7)=Y
S FBCDAYS=$P(FBY2,U,10) ; covered days
S FBCSID=$P(FBY2,U,11) ; patient control number
S FBFPPSC=$P(FBY3,U) ; fpps claim id
S FBFPPSL=$P(FBY3,U,2) ; fpps line item
S FBX=$$ADJLRA^FBCHFA(FBI_",")
S FBADJLR=$P(FBX,U)
S FBADJLA=$P(FBX,U,2)
S FBRRMKL=$$RRL^FBCHFR(FBI_",")
WRT I $Y+6>IOSL D HANG^FBAAUTL1:$E(IOST,1,2)["C-" Q:FBAAOUT I $D(^FBAAI(FBI,4)) D HEDC
W !,$S('$D(FBIN(13)):"",FBIN(13)="R":"*",1:""),$S($G(FBCAN)]"":"+",1:"")
W VADM(1)_" "_$P(VADM(2),"^",2),?48,FBCSID
W !,?4,FBVEN,?45,FBVID,?62,FBIN(1)
W !,$S(FBIN(13)["R":"*",1:""),$S(FBIN(14)]"":"#",1:"")
W ?4,FBFPPSC,?18,FBFPPSL,?35,FBIN(2),?46,$$DATX^FBAAUTL(FBVINDT),?57,FBIN(6),?68,FBIN(7)
W !?4,$J(FBIN(8),1,2),?17,$J(FBIN(9),1,2),?29,FBCDAYS
; write adjustment reasons, if null then write suspend code
W ?39,$S(FBADJLR]"":FBADJLR,1:FBIN(11))
; write adjustment amounts, if null then write amount suspended
W ?49,$S(FBADJLA]"":FBADJLA,1:$J(FBIN(10),1,2))
W ?64,FBRRMKL
;IPAC agreement data from patch FB*3.5*123
I +$P(FBY5,U,10) W !!?5,"IPAC Number: ",$P($G(^FBAA(161.95,+$P(FBY5,U,10),0)),U,1),?30,"DoD Invoice Number: ",$P(FBY5,U,7)
;write admitting diagnosis
S FBADMTDX=$P(FBY5,"^",9) I FBADMTDX]"" W !?2,"Admit Dx: ",$$ICD9^FBCSV1((FBADMTDX),$P($G(FBIN),"^",6))
;write contract number
S FBCNTRN=$S($P(FBY5,U,8):$P($G(^FBAA(161.43,$P(FBY5,U,8),0)),U),1:"")
I FBCNTRN]"" W ?25,"Contract Number: ",FBCNTRN
;set diagnosis code and present on admission code
N P1,P2
S P1=$G(^FBAAI(FBI,"DX"))
S P2=$G(^FBAAI(FBI,"POA"))
F K=1:1:25 D WRTDX
;display procedure code with line item prov data - FB*3.5*135
N DIR,DUOUT,DTOUT,FBOUT,F135,L,P3,P5,RPROV,STRLEN,WRTPC
S P5=$G(^FBAAI(FBI,"PROC")) ; Procedure codes
M RPROV=^FBAAI(FBI,"RPROV") ; LI Provider array
S F135=24,FBOUT=0,STRLEN=66
F L=1:1:25 S WRTPC=$$WRTPC I WRTPC]"" D Q:FBOUT
. S P3=$O(RPROV("B",L,0))
. I P3 D ; display LI Provider and NPI/TAXONOMY data if present
.. W !,?4,"PROC: "_WRTPC,?17,"RENDERING PROV NAME (LI): "_$P(RPROV(P3,0),U,2) S F135=1+F135,STRLEN=66
.. I '$L($P(RPROV(P3,0),U,3)),'$L($P(RPROV(P3,0),U,4)) Q
.. W !,?22,"NPI: "_$P(RPROV(P3,0),U,3),?43,"TAXONOMY CODE: "_$P(RPROV(P3,0),U,4) S F135=1+F135
. E D Q ; only display procedure code
.. I STRLEN>65 W !,?4,"PROC: " S STRLEN=0 ; start new line
.. W WRTPC_" " S STRLEN=1+STRLEN+$L(WRTPC)
. I F135>22 S F135=0,STRLEN=66,DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 ; pagination
I $D(^FBAAI(FBI,10)) D Q:FBOUT
. N AI,AID,AITI S AI=0 S WRTPC="Attachment ID:"
. F S AI=$O(^FBAAI(FBI,10,AI)) Q:'AI D Q:FBOUT
. . S AID=$P($G(^FBAAI(FBI,10,AI,0)),"^") I $L(WRTPC)>20 S WRTPC=WRTPC_","
. . S WRTPC=WRTPC_" "_AID
. . S AITI=$P($G(^FBAAI(FBI,10,AI,0)),"^",2) I AITI D
. . . S WRTPC=WRTPC_" ("_$P($G(^IBE(353.3,AITI,0)),"^")
. . . S WRTPC=WRTPC_" - "
. . . S WRTPC=WRTPC_$P($G(^IBE(353.3,AITI,0)),"^",2)_")"
. . I $L(WRTPC)>65 S FBOUT=$$WRTSTR(.WRTPC,65)
. I $L(WRTPC)>0 S FBOUT=$$WRTSTR(.WRTPC,65)
N A2 S A2=FBIN(9) W ! D PMNT^FBAACCB2
Q
WRTSTR(STR,MX) ; Wordwrap string
N RM,I S FBOUT=0
WRTSTR1 S RM=$S(STR?1"Attachment ID:".E:MX-4,1:MX-7)
F I=1:1:$L(STR," ") Q:$L($P(STR," ",1,I))>RM
W !,?4 W:STR'?1"Attachment ID:".E ?7 W $P(STR," ",1,$S(I=$L(STR," "):I,1:I-1))
S STR=$P(STR," ",I,999)
S F135=F135+1 I F135>22 S F135=0,DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 ; pagination
I FBOUT Q FBOUT
I $L(STR)>(MX-3) G WRTSTR1
Q FBOUT
WRTDX ;write dianosis code and present on admission code
N P3,P4
S FBDX=$P(P1,"^",K)
S FBPOA=$P(P2,"^",K)
Q:FBDX=""
S P3=$$ICD9^FBCSV1((FBDX),$P($G(FBIN),"^",6))_"/"
S P4=P3_$S(FBPOA:$P($G(^FB(161.94,FBPOA,0)),"^"),1:"")_" "
I K=1!($X+$L(P4)+2>IOM) W !,?4,"DX/POA: "
W P4,""
Q
WRTPC() ;write procedure code (if present) ; FB*3.5*135
N P6
S FBPROC=$P(P5,"^",L)
Q:FBPROC="" ""
S P6=$$ICD0^FBCSV1((FBPROC),$P($G(FBIN),"^",6))_" "
Q P6
HEDC I $D(FBHEAD) W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W ?25,FBHEAD_" PAYMENT HISTORY",!,?24,$E(Q,1,24),!?48,"Date Range: ",BEGDATE_" to "_ENDDATE
I '$D(FBHEAD) W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W !?32,"INVOICE DISPLAY",!,?31,$E(Q,1,17),!
W !,"Veteran's Name",?48,"Patient Control Number"
W !,"('*'Reimbursement to Veteran '+' Cancellation Activity) '#' Voided Payment)"
;FB*3.5*164
;W !,"('&' Additional Payment)"
;
W !,?4,"Vendor Name",?45,"Vendor ID",?59,"Invoice #"
;W !,?3,"Fr Date",?14,"To Date Claimed Paid",?41,"Sus Code",?59,"Dt. Rec.",?69,"Inv. Date"
W !,?4,"FPPS Claim ID",?18,"FPPS Line Item",?35,"Date Rec.",?46,"Inv. Date",?57,"Fr Date",?68,"To Date"
W !,?4,"Amt Claimed",?17,"Amt Paid",?29,"Cov.Days",?39,"Adj Code",?49,"Adj Amount",?64,"Remit Remark"
W !,Q,!
Q
CDAT S Y=$E(Y,4,5)_"/"_$S($E(Y,6,7)="00":$E(Y,2,3),1:$E(Y,6,7)_"/"_$E(Y,2,3)) Q
GETDAT S Y=BEGDATE D PDF^FBAAUTL S BEGDATE=Y,Y=ENDDATE D PDF^FBAAUTL S ENDDATE=Y
Q
PRVD ;DISPLAY PROVIDER INFORMATION BEFORE INVOICE DISPLAY FB*3.5*122
N FBPRI,FBSRVF,FBST
S FBPRI=$G(^FBAAI(FBI,4)),FBSRVF=$G(^FBAAI(FBI,5)),$P(FBSRVF,U,3)=$$GET1^DIQ(5,$P(FBSRVF,U,3)_",",1)
W @IOF,!?30,"INVOICE DISPLAY",!?30,"===============",!?28,"PROVIDER INFORMATION",!
I $L($P(FBPRI,U,1,3))>3 W !?3,"ATTENDING PROV NAME: "_$P(FBPRI,U),!?3,"ATTENDING PROV NPI: "_$P(FBPRI,U,2),?35,"ATTENDING PROV TAXONOMY CODE: "_$P(FBPRI,U,3)
I $L($P(FBPRI,U,4,5))>2 W !!?3,"OPERATING PROV NAME: "_$P(FBPRI,U,4),!?3,"OPERATING PROV NPI: "_$P(FBPRI,U,5)
I $L($P(FBPRI,U,6,8))>3 W !!?3,"RENDERING PROV NAME: "_$P(FBPRI,U,6),!?3,"RENDERING PROV NPI: "_$P(FBPRI,U,7),?35,"RENDERING PROV TAXONOMY CODE: "_$P(FBPRI,U,8)
I $L($P(FBPRI,U,9,10))>2 W !!?3,"SERVICING PROV NAME: "_$P(FBPRI,U,9),!?3,"SERVICING PROV NPI: "_$P(FBPRI,U,10)
I $L($P(FBSRVF,U,1,4))>4 W !?3,"SERVICING FACILITY ADDRESS: ",!?5,$P(FBSRVF,U),!?5,$P(FBSRVF,U,2) I $P(FBSRVF,U,2)'="" W ", "
W $P(FBSRVF,U,3)_" "_$P(FBSRVF,U,4)
I $L($P(FBPRI,U,11,12))>2 W !!?3,"REFERRING PROV NAME: "_$P(FBPRI,U,11),!?3,"REFERRING PROV NPI: "_$P(FBPRI,U,12),!!
S DIR(0)="E" D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHVH 7790 printed Sep 23, 2025@19:34:07 Page 2
FBCHVH ;AISC/DMK - VENDOR PAYMENT HISTORY ;7/17/2003
+1 ;;3.5;FEE BASIS;**55,61,122,108,135,144,123,164**;JAN 30, 1995;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
GETVEN KILL FBAANQ
DO GETVEN^FBAAUTL1
if IFN']""
GOTO END
+1 DO DATE^FBAAUTL
if FBPOP
GOTO GETVEN
SET ZZ=9999999.9999
SET FBBEG=ZZ-ENDDATE
SET FBEND=ZZ-BEGDATE
+2 IF '$DATA(^FBAAI("AF",IFN))
WRITE !,*7,"No invoices on line for this vendor."
GOTO GETVEN
+3 SET VAR="IFN^FBBEG^FBEND^BEGDATE^ENDDATE"_$SELECT($DATA(FBPROG):"^FBPROG",1:"")
SET VAL=IFN_"^"_FBBEG_"^"_FBEND_"^"_BEGDATE_"^"_ENDDATE_$SELECT($DATA(FBPROG):"^"_FBPROG,1:"")
SET PGM="START^FBCHVH"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
if IO=IO(0)
SET FBAANQ=1
START if '$DATA(FBPROG)
SET FBPROG=6
SET FBHEAD="VENDOR"
SET Q=""
SET $PIECE(Q,"=",80)="="
SET FBAAOUT=0
USE IO
DO GETDAT
if $EXTRACT(IOST,1,2)'["C-"
SET FBPG=1
DO HEDC
+1 FOR FBM=FBBEG-.1:0
SET FBM=$ORDER(^FBAAI("AF",IFN,FBM))
if FBM'>0!(FBM>FBEND)
QUIT
FOR FBI=0:0
SET FBI=$ORDER(^FBAAI("AF",IFN,FBM,FBI))
if FBI'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAAI(FBI,0))
IF $PIECE(^(0),"^",12)=FBPROG
IF '$DATA(^("FBREJ"))
DO GETINV
+2 if $DATA(FBAANQ)
GOTO GETVEN
END KILL DA,BEGDATE,ENDDATE,FBBEG,FBEND,DIC,FBAANQ,FBAAOUT,FBDX,FBI,FBIN,FBPROC,FBVEN,FBVID,IFN,J,K,L,PGM,Q,VADM,VAERR,VAL,VAR,X,Y,VA,ZZ,FBM,FBHEAD,FBPROG,FBPG,FBVINDT
+1 DO CLOSE^FBAAUTL
QUIT
GETINV ;
+1 NEW FBADJLA,FBADJLR,FBCDAYS,FBCSID,FBFPPSC,FBFPPSL,FBRRMKL,FBY2,FBY3,FBY5,FBADMTDX,FBPOA,FBCNTRN,B
+2 NEW AD
+3 SET FBIN=^FBAAI(FBI,0)
+4 SET FBY2=$GET(^FBAAI(FBI,2))
+5 SET FBY3=$GET(^FBAAI(FBI,3))
+6 SET FBY5=$GET(^FBAAI(FBI,5))
+7 FOR J=1,2,3,4,6,7,8,9,10,11,13,14
SET FBIN(J)=$PIECE(FBIN,"^",J)
+8 SET FBVINDT=$PIECE(FBY2,"^",2)
DO FBCKI^FBAACCB1(FBI)
+9 SET FBVEN=$SELECT($DATA(^FBAAV(+FBIN(3),0)):$PIECE(^(0),"^",1),1:"")
IF FBVEN]""
SET FBVID=$PIECE(^(0),"^",2)
+10 SET DFN=FBIN(4)
if 'DFN
QUIT
DO DEM^VADPT
+11 SET Y=FBIN(2)
DO CDAT
SET FBIN(2)=Y
+12 SET Y=FBIN(6)
DO CDAT
SET FBIN(6)=Y
SET Y=FBIN(7)
DO CDAT
SET FBIN(7)=Y
+13 ; covered days
SET FBCDAYS=$PIECE(FBY2,U,10)
+14 ; patient control number
SET FBCSID=$PIECE(FBY2,U,11)
+15 ; fpps claim id
SET FBFPPSC=$PIECE(FBY3,U)
+16 ; fpps line item
SET FBFPPSL=$PIECE(FBY3,U,2)
+17 SET FBX=$$ADJLRA^FBCHFA(FBI_",")
+18 SET FBADJLR=$PIECE(FBX,U)
+19 SET FBADJLA=$PIECE(FBX,U,2)
+20 SET FBRRMKL=$$RRL^FBCHFR(FBI_",")
WRT IF $Y+6>IOSL
if $EXTRACT(IOST,1,2)["C-"
DO HANG^FBAAUTL1
if FBAAOUT
QUIT
IF $DATA(^FBAAI(FBI,4))
DO HEDC
+1 WRITE !,$SELECT('$DATA(FBIN(13)):"",FBIN(13)="R":"*",1:""),$SELECT($GET(FBCAN)]"":"+",1:"")
+2 WRITE VADM(1)_" "_$PIECE(VADM(2),"^",2),?48,FBCSID
+3 WRITE !,?4,FBVEN,?45,FBVID,?62,FBIN(1)
+4 WRITE !,$SELECT(FBIN(13)["R":"*",1:""),$SELECT(FBIN(14)]"":"#",1:"")
+5 WRITE ?4,FBFPPSC,?18,FBFPPSL,?35,FBIN(2),?46,$$DATX^FBAAUTL(FBVINDT),?57,FBIN(6),?68,FBIN(7)
+6 WRITE !?4,$JUSTIFY(FBIN(8),1,2),?17,$JUSTIFY(FBIN(9),1,2),?29,FBCDAYS
+7 ; write adjustment reasons, if null then write suspend code
+8 WRITE ?39,$SELECT(FBADJLR]"":FBADJLR,1:FBIN(11))
+9 ; write adjustment amounts, if null then write amount suspended
+10 WRITE ?49,$SELECT(FBADJLA]"":FBADJLA,1:$JUSTIFY(FBIN(10),1,2))
+11 WRITE ?64,FBRRMKL
+12 ;IPAC agreement data from patch FB*3.5*123
+13 IF +$PIECE(FBY5,U,10)
WRITE !!?5,"IPAC Number: ",$PIECE($GET(^FBAA(161.95,+$PIECE(FBY5,U,10),0)),U,1),?30,"DoD Invoice Number: ",$PIECE(FBY5,U,7)
+14 ;write admitting diagnosis
+15 SET FBADMTDX=$PIECE(FBY5,"^",9)
IF FBADMTDX]""
WRITE !?2,"Admit Dx: ",$$ICD9^FBCSV1((FBADMTDX),$PIECE($GET(FBIN),"^",6))
+16 ;write contract number
+17 SET FBCNTRN=$SELECT($PIECE(FBY5,U,8):$PIECE($GET(^FBAA(161.43,$PIECE(FBY5,U,8),0)),U),1:"")
+18 IF FBCNTRN]""
WRITE ?25,"Contract Number: ",FBCNTRN
+19 ;set diagnosis code and present on admission code
+20 NEW P1,P2
+21 SET P1=$GET(^FBAAI(FBI,"DX"))
+22 SET P2=$GET(^FBAAI(FBI,"POA"))
+23 FOR K=1:1:25
DO WRTDX
+24 ;display procedure code with line item prov data - FB*3.5*135
+25 NEW DIR,DUOUT,DTOUT,FBOUT,F135,L,P3,P5,RPROV,STRLEN,WRTPC
+26 ; Procedure codes
SET P5=$GET(^FBAAI(FBI,"PROC"))
+27 ; LI Provider array
MERGE RPROV=^FBAAI(FBI,"RPROV")
+28 SET F135=24
SET FBOUT=0
SET STRLEN=66
+29 FOR L=1:1:25
SET WRTPC=$$WRTPC
IF WRTPC]""
Begin DoDot:1
+30 SET P3=$ORDER(RPROV("B",L,0))
+31 ; display LI Provider and NPI/TAXONOMY data if present
IF P3
Begin DoDot:2
+32 WRITE !,?4,"PROC: "_WRTPC,?17,"RENDERING PROV NAME (LI): "_$PIECE(RPROV(P3,0),U,2)
SET F135=1+F135
SET STRLEN=66
+33 IF '$LENGTH($PIECE(RPROV(P3,0),U,3))
IF '$LENGTH($PIECE(RPROV(P3,0),U,4))
QUIT
+34 WRITE !,?22,"NPI: "_$PIECE(RPROV(P3,0),U,3),?43,"TAXONOMY CODE: "_$PIECE(RPROV(P3,0),U,4)
SET F135=1+F135
End DoDot:2
+35 ; only display procedure code
IF '$TEST
Begin DoDot:2
+36 ; start new line
IF STRLEN>65
WRITE !,?4,"PROC: "
SET STRLEN=0
+37 WRITE WRTPC_" "
SET STRLEN=1+STRLEN+$LENGTH(WRTPC)
End DoDot:2
QUIT
+38 ; pagination
IF F135>22
SET F135=0
SET STRLEN=66
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
SET FBOUT=1
End DoDot:1
if FBOUT
QUIT
+39 IF $DATA(^FBAAI(FBI,10))
Begin DoDot:1
+40 NEW AI,AID,AITI
SET AI=0
SET WRTPC="Attachment ID:"
+41 FOR
SET AI=$ORDER(^FBAAI(FBI,10,AI))
if 'AI
QUIT
Begin DoDot:2
+42 SET AID=$PIECE($GET(^FBAAI(FBI,10,AI,0)),"^")
IF $LENGTH(WRTPC)>20
SET WRTPC=WRTPC_","
+43 SET WRTPC=WRTPC_" "_AID
+44 SET AITI=$PIECE($GET(^FBAAI(FBI,10,AI,0)),"^",2)
IF AITI
Begin DoDot:3
+45 SET WRTPC=WRTPC_" ("_$PIECE($GET(^IBE(353.3,AITI,0)),"^")
+46 SET WRTPC=WRTPC_" - "
+47 SET WRTPC=WRTPC_$PIECE($GET(^IBE(353.3,AITI,0)),"^",2)_")"
End DoDot:3
+48 IF $LENGTH(WRTPC)>65
SET FBOUT=$$WRTSTR(.WRTPC,65)
End DoDot:2
if FBOUT
QUIT
+49 IF $LENGTH(WRTPC)>0
SET FBOUT=$$WRTSTR(.WRTPC,65)
End DoDot:1
if FBOUT
QUIT
+50 NEW A2
SET A2=FBIN(9)
WRITE !
DO PMNT^FBAACCB2
+51 QUIT
WRTSTR(STR,MX) ; Wordwrap string
+1 NEW RM,I
SET FBOUT=0
WRTSTR1 SET RM=$SELECT(STR?1"Attachment ID:".E:MX-4,1:MX-7)
+1 FOR I=1:1:$LENGTH(STR," ")
if $LENGTH($PIECE(STR," ",1,I))>RM
QUIT
+2 WRITE !,?4
if STR'?1"Attachment ID
WRITE ?7
WRITE $PIECE(STR," ",1,$SELECT(I=$LENGTH(STR," "):I,1:I-1))
+3 SET STR=$PIECE(STR," ",I,999)
+4 ; pagination
SET F135=F135+1
IF F135>22
SET F135=0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
SET FBOUT=1
+5 IF FBOUT
QUIT FBOUT
+6 IF $LENGTH(STR)>(MX-3)
GOTO WRTSTR1
+7 QUIT FBOUT
WRTDX ;write dianosis code and present on admission code
+1 NEW P3,P4
+2 SET FBDX=$PIECE(P1,"^",K)
+3 SET FBPOA=$PIECE(P2,"^",K)
+4 if FBDX=""
QUIT
+5 SET P3=$$ICD9^FBCSV1((FBDX),$PIECE($GET(FBIN),"^",6))_"/"
+6 SET P4=P3_$SELECT(FBPOA:$PIECE($GET(^FB(161.94,FBPOA,0)),"^"),1:"")_" "
+7 IF K=1!($X+$LENGTH(P4)+2>IOM)
WRITE !,?4,"DX/POA: "
+8 WRITE P4,""
+9 QUIT
WRTPC() ;write procedure code (if present) ; FB*3.5*135
+1 NEW P6
+2 SET FBPROC=$PIECE(P5,"^",L)
+3 if FBPROC=""
QUIT ""
+4 SET P6=$$ICD0^FBCSV1((FBPROC),$PIECE($GET(FBIN),"^",6))_" "
+5 QUIT P6
HEDC IF $DATA(FBHEAD)
if '$GET(FBPG)
WRITE @IOF
if $GET(FBPG)
KILL FBPG
WRITE ?25,FBHEAD_" PAYMENT HISTORY",!,?24,$EXTRACT(Q,1,24),!?48,"Date Range: ",BEGDATE_" to "_ENDDATE
+1 IF '$DATA(FBHEAD)
if '$GET(FBPG)
WRITE @IOF
if $GET(FBPG)
KILL FBPG
WRITE !?32,"INVOICE DISPLAY",!,?31,$EXTRACT(Q,1,17),!
+2 WRITE !,"Veteran's Name",?48,"Patient Control Number"
+3 WRITE !,"('*'Reimbursement to Veteran '+' Cancellation Activity) '#' Voided Payment)"
+4 ;FB*3.5*164
+5 ;W !,"('&' Additional Payment)"
+6 ;
+7 WRITE !,?4,"Vendor Name",?45,"Vendor ID",?59,"Invoice #"
+8 ;W !,?3,"Fr Date",?14,"To Date Claimed Paid",?41,"Sus Code",?59,"Dt. Rec.",?69,"Inv. Date"
+9 WRITE !,?4,"FPPS Claim ID",?18,"FPPS Line Item",?35,"Date Rec.",?46,"Inv. Date",?57,"Fr Date",?68,"To Date"
+10 WRITE !,?4,"Amt Claimed",?17,"Amt Paid",?29,"Cov.Days",?39,"Adj Code",?49,"Adj Amount",?64,"Remit Remark"
+11 WRITE !,Q,!
+12 QUIT
CDAT SET Y=$EXTRACT(Y,4,5)_"/"_$SELECT($EXTRACT(Y,6,7)="00":$EXTRACT(Y,2,3),1:$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3))
QUIT
GETDAT SET Y=BEGDATE
DO PDF^FBAAUTL
SET BEGDATE=Y
SET Y=ENDDATE
DO PDF^FBAAUTL
SET ENDDATE=Y
+1 QUIT
PRVD ;DISPLAY PROVIDER INFORMATION BEFORE INVOICE DISPLAY FB*3.5*122
+1 NEW FBPRI,FBSRVF,FBST
+2 SET FBPRI=$GET(^FBAAI(FBI,4))
SET FBSRVF=$GET(^FBAAI(FBI,5))
SET $PIECE(FBSRVF,U,3)=$$GET1^DIQ(5,$PIECE(FBSRVF,U,3)_",",1)
+3 WRITE @IOF,!?30,"INVOICE DISPLAY",!?30,"===============",!?28,"PROVIDER INFORMATION",!
+4 IF $LENGTH($PIECE(FBPRI,U,1,3))>3
WRITE !?3,"ATTENDING PROV NAME: "_$PIECE(FBPRI,U),!?3,"ATTENDING PROV NPI: "_$PIECE(FBPRI,U,2),?35,"ATTENDING PROV TAXONOMY CODE: "_$PIECE(FBPRI,U,3)
+5 IF $LENGTH($PIECE(FBPRI,U,4,5))>2
WRITE !!?3,"OPERATING PROV NAME: "_$PIECE(FBPRI,U,4),!?3,"OPERATING PROV NPI: "_$PIECE(FBPRI,U,5)
+6 IF $LENGTH($PIECE(FBPRI,U,6,8))>3
WRITE !!?3,"RENDERING PROV NAME: "_$PIECE(FBPRI,U,6),!?3,"RENDERING PROV NPI: "_$PIECE(FBPRI,U,7),?35,"RENDERING PROV TAXONOMY CODE: "_$PIECE(FBPRI,U,8)
+7 IF $LENGTH($PIECE(FBPRI,U,9,10))>2
WRITE !!?3,"SERVICING PROV NAME: "_$PIECE(FBPRI,U,9),!?3,"SERVICING PROV NPI: "_$PIECE(FBPRI,U,10)
+8 IF $LENGTH($PIECE(FBSRVF,U,1,4))>4
WRITE !?3,"SERVICING FACILITY ADDRESS: ",!?5,$PIECE(FBSRVF,U),!?5,$PIECE(FBSRVF,U,2)
IF $PIECE(FBSRVF,U,2)'=""
WRITE ", "
+9 WRITE $PIECE(FBSRVF,U,3)_" "_$PIECE(FBSRVF,U,4)
+10 IF $LENGTH($PIECE(FBPRI,U,11,12))>2
WRITE !!?3,"REFERRING PROV NAME: "_$PIECE(FBPRI,U,11),!?3,"REFERRING PROV NPI: "_$PIECE(FBPRI,U,12),!!
+11 SET DIR(0)="E"
DO ^DIR
+12 QUIT
