FBAACCB ;AISC/GRR - CLERK CLOSE BATCH ;7/9/14 16:16
;;3.5;FEE BASIS;**4,61,77,116,154,164**;JAN 30, 1995;Build 28
;;Per VA Directive 6402, this routine should not be modified.
K QQ D DT^DICRW
BT W !! S DIC="^FBAA(161.7,",DIC(0)="AEQ",DIC("S")=$S($D(^XUSEC("FBAA LEVEL 2",DUZ)):"I $G(^(""ST""))=""O""",1:"I $P(^(0),U,5)=DUZ&($G(^(""ST""))=""O"")") D ^DIC K DIC("S")
G Q^FBAACCB0:X="^"!(X=""),BT:Y<0 S B=+Y,FZ=^FBAA(161.7,B,0),FBTYPE=$P(FZ,"^",3)
I FBTYPE="B3",'$D(^FBAAC("AC",B)) W !!,*7,"No payments in Batch yet!",! G BT
I FBTYPE="B2",'$D(^FBAAC("AD",B)) W !!,*7,"No Payments in Batch yet!",! G BT
I FBTYPE="B5",'$D(^FBAA(162.1,"AE",B)) W !!,*7,"No Payments in Batch yet!",! G BT
I FBTYPE="B9",'$D(^FBAAI("AC",B)) W !!,*7,"No Payments in Batch yet!",! G BT
RDD S DIR(0)="Y",DIR("A")="Want to review batch",DIR("B")="NO",DIR("?")="If you want a detail list of each payment line, answer ""Yes"" otherwise press Return key" D ^DIR K DIR
G BT:$D(DIRUT) W:Y @IOF D:Y LIST:FBTYPE="B3",LISTP:FBTYPE="B5",LISTT^FBAACCB0:FBTYPE="B2",LISTC^FBAACCB1:FBTYPE="B9"
RDD1 S DIR(0)="Y",DIR("A")="Do you still want to close Batch",DIR("B")="YES" D ^DIR K DIR G BT:'Y!$D(DIRUT)
N FBARY,FBOLD,FBINVT
;
S C=0,T=0 G PHARM^FBAACCB1:FBTYPE="B5",TRAV^FBAACCB1:FBTYPE="B2",CHNH^FBAACCB1:FBTYPE="B9"
F J=0:0 S J=$O(^FBAAC("AC",B,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("AC",B,J,K)) Q:K'>0 F L=0:0 S L=$O(^FBAAC("AC",B,J,K,L)) Q:L'>0 F M=0:0 S M=$O(^FBAAC("AC",B,J,K,L,M)) Q:M'>0 D GOT
FIN ; FB*3.5*116 - check and handle $0 invoices
D CHECK(.FBARY)
I $D(FBARY) D G BT
. ;D EN^DDIOL(.FBARY)
. W *7,!!?2,"Batch cannot be closed. Listed invoices are zero dollar "
. W *7,!?2,"and must be corrected or removed from the batch."
; end of changes
;
S $P(FZ,"^",9)=T,$P(FZ,"^",11)=C
S $P(FZ,"^",13)=DT,^FBAA(161.7,B,0)=FZ,^FBAA(161.7,B,"ST")="C",^FBAA(161.7,"AC","C",B)="",DA=B,DR="0;ST" K ^FBAA(161.7,"AC","O",B),^FBAA(161.7,"AB","O",$P(^FBAA(161.7,B,0),"^",5),B) W !! D EN^DIQ W !!,"Batch Closed" G BT
;
GOT S Y(0)=$G(^FBAAC(J,1,K,1,L,1,M,0)),FBIN=$P(Y(0),"^",16)
; HIPAA 5010 - count line items that have 0.00 amount paid
S T=T+$P(Y(0),"^",3),C=C+1
; FB*3.5*116 -collect amount paid for each invoice in batch
S FBARY(FBIN)=$G(FBARY(FBIN))+$P(Y(0),"^",3)
Q
;
CHECK(FBINV) ; order thru array and save zero dollar invoices; report any zero dollar invoices
; FBINV = array of invoices
N FBAAIN
S FBAAIN=0 F S FBAAIN=$O(FBINV(FBAAIN)) Q:'FBAAIN D
. I FBINV(FBAAIN)'>0 W !!,"Invoice #: "_FBAAIN_" totals $0.00"
. E K FBINV(FBAAIN) ; remove array elements that represent non-zero dollar invoices
Q
;
LIST S Q="",$P(Q,"=",80)="="
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
ENM D HED S (FBIN,FBINOLD)="",(FBAAOUT,FBINTOT)=0 F XY=0:0 S FBIN=$O(^FBAAC("AJ",B,FBIN)) Q:FBIN=""!($G(FBAAOUT)) D INTOT^FBAACCB0 F J=0:0 S J=$O(^FBAAC("AJ",B,FBIN,J)) Q:J'>0!($G(FBAAOUT)) D GMORE^FBAACCB0
I '$G(FBAAOUT) S FBIN=0 D INTOT^FBAACCB0
Q
SET ;
N FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBX,FBY3,TAMT
S N=$S($D(^DPT(J,0)):$P(^DPT(J,0),"^",1),1:""),S=$S(N]"":$P(^DPT(J,0),"^",9),1:""),V=$S($D(^FBAAV(K,0)):$P(^FBAAV(K,0),"^",1),1:""),VID=$S(V]"":$P(^(0),"^",2),1:"")
S D=+$G(^FBAAC(J,1,K,1,L,0)) Q:'D
S Y=$G(^FBAAC(J,1,K,1,L,1,M,0)) Q:Y']""
S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3))
S FBFPPSC=$P(FBY3,U)
S FBFPPSL=$P(FBY3,U,2)
S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
S FBADJLR=$P(FBX,U)
S FBADJLA=$P(FBX,U,2)
S T=$P(Y,"^",5),FBIN=$P(Y,"^",16),ZS=$P(Y,"^",20)
S TAMT=$FN($P(Y,"^",4),"",2)
S FBVP=$S($P(Y,"^",21)="VP":"#",1:"")
S FBAACPT=$$CPT^FBAAUTL4($P(Y,U))
S CPTDESC=$$CPT^FBAAUTL4($P(Y,U),1,D)
S FBVCHDT=$P(Y,"^",6),FBIN(1)=$P(Y,"^",15) D FBCKO^FBAACCB2(J,K,L,M)
S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
GO S A1=$P(Y,"^",2)+.0001,A2=$P(Y,"^",3)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2),FBINTOT=FBINTOT+A2
D WRT:FBTYPE'="B2",WRTT^FBAACCB0:FBTYPE="B2"
Q
WRT I $Y+8>IOSL D ASKH^FBAACCB0:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF D HED
S B(1617)=$S(B="":"",$D(^FBAA(161.7,B,0)):$P(^(0),"^"),1:"")
W !!,N,?35,$$SSN^FBAAUTL(J),?58,B(1617),?67,$$DATX^FBAAUTL($G(FBVCHDT)),!,?3,V,?42,VID,?55,FBIN,?67,$$DATX^FBAAUTL(FBIN(1))
W !,$S($D(QQ):QQ_")",1:""),$S(ZS="R":"*",1:""),$S(FBTYPE="B3":FBVP,1:""),$S(FBTYPE="B5":FBPV,1:""),$S($G(FBCAN)]"":"+",1:"")
I FBTYPE="B3" W ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?24,CPTDESC,?54,FBFPPSC,?66,FBFPPSL
I FBTYPE="B5" W ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?24,CPTDESC,?56,FBFPPSC,?68,FBFPPSL
I $P($G(FBMODLE),",",2)]"" D Q:FBAAOUT
. N FBI,FBMOD
. F FBI=2:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D Q:FBAAOUT
. . I $Y+5>IOSL D Q:FBAAOUT
. . . I $E(IOST,1,2)="C-" D ASKH^FBAACCB0 Q:FBAAOUT
. . . W @IOF D HED W !,"(continued)"
. . W !,?19,"-",FBMOD
W !?4,$J(A1,6),?17,$J(A2,6)
; write adjustment reasons, if null then write suspend code
W ?30,$S(FBADJLR]"":FBADJLR,1:T)
; write adjustment amounts, if null then write amount suspended
W ?41,$S(FBADJLA]"":FBADJLA,1:TAMT)
; write attachment IDs FB*3.5*164
I FBTYPE="B3",$D(^FBAAC(J,1,K,1,L,1,M,10)) D
. N AI,AID,AITI S AI=0 S WRTPC="Attachment ID:"
. F S AI=$O(^FBAAC(J,1,K,1,L,1,M,10,AI)) Q:'AI D
. . S AID=$P($G(^FBAAC(J,1,K,1,L,1,M,10,AI,0)),U) I AI>1 S WRTPC=WRTPC_","
. . S WRTPC=WRTPC_" "_AID
. . S AITI=$P($G(^FBAAC(J,1,K,1,L,1,M,10,AI,0)),U,2) I AITI D
. . . S WRTPC=WRTPC_" ("_$P($G(^IBE(353.3,AITI,0)),U)
. . . S WRTPC=WRTPC_" - "
. . . S WRTPC=WRTPC_$P($G(^IBE(353.3,AITI,0)),U,2)_")"
. . I $L(WRTPC)>IOM D WRTSTR^FBAACCB1(.WRTPC,IOM)
. I $L(WRTPC)>0 D WRTSTR^FBAACCB1(.WRTPC,IOM)
;
D PMNT^FBAACCB2 S FBINOLD=FBIN
Q
HED W "Patient Name",?20,"('*' Reimbursement to Patient '+' Cancellation Activity)",!,?13,"('#' Voided Payment)",?58,"Batch #",?67,"Voucher Date"
W !,?3,"Vendor Name",?42,"Vendor ID",?53,"Invoice #",?67,"Date Rec'd."
I FBTYPE="B3" D
. W !,?4,"SVC DATE",?14,"CPT-MOD",?24,"SERVICE PROVIDED",?54,"FPPS CLAIM",?66,"FPPS LINE"
. W !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ AMOUNT"
I FBTYPE="B5" D
. W !,?4,"RX DATE",?14,"RX #",?24,"DRUG NAME",?56,"FPPS CLAIM",?68,"FPPS LINE"
. W !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ AMOUNT"
W !,Q,!
Q
LISTP S Q="",$P(Q,"=",80)="="
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
ENP D HED S (FBAAOUT,FBINTOT)=0,FBINOLD=""
F A=0:0 S A=$O(^FBAA(162.1,"AE",B,A)) Q:A'>0!($G(FBAAOUT)) S FBIN=A D SETV^FBAACCB0 F B2=0:0 S B2=$O(^FBAA(162.1,"AE",B,A,B2)) Q:B2'>0!($G(FBAAOUT)) D INTOT^FBAACCB0 I $D(^FBAA(162.1,A,"RX",B2,0)) S Z(0)=^(0) D MORE^FBAACCB1
I '$G(FBAAOUT) S FBIN=0 D INTOT^FBAACCB0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACCB 6774 printed Sep 23, 2025@19:31:04 Page 2
FBAACCB ;AISC/GRR - CLERK CLOSE BATCH ;7/9/14 16:16
+1 ;;3.5;FEE BASIS;**4,61,77,116,154,164**;JAN 30, 1995;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 KILL QQ
DO DT^DICRW
BT WRITE !!
SET DIC="^FBAA(161.7,"
SET DIC(0)="AEQ"
SET DIC("S")=$SELECT($DATA(^XUSEC("FBAA LEVEL 2",DUZ)):"I $G(^(""ST""))=""O""",1:"I $P(^(0),U,5)=DUZ&($G(^(""ST""))=""O"")")
DO ^DIC
KILL DIC("S")
+1 if X="^"!(X="")
GOTO Q^FBAACCB0
if Y<0
GOTO BT
SET B=+Y
SET FZ=^FBAA(161.7,B,0)
SET FBTYPE=$PIECE(FZ,"^",3)
+2 IF FBTYPE="B3"
IF '$DATA(^FBAAC("AC",B))
WRITE !!,*7,"No payments in Batch yet!",!
GOTO BT
+3 IF FBTYPE="B2"
IF '$DATA(^FBAAC("AD",B))
WRITE !!,*7,"No Payments in Batch yet!",!
GOTO BT
+4 IF FBTYPE="B5"
IF '$DATA(^FBAA(162.1,"AE",B))
WRITE !!,*7,"No Payments in Batch yet!",!
GOTO BT
+5 IF FBTYPE="B9"
IF '$DATA(^FBAAI("AC",B))
WRITE !!,*7,"No Payments in Batch yet!",!
GOTO BT
RDD SET DIR(0)="Y"
SET DIR("A")="Want to review batch"
SET DIR("B")="NO"
SET DIR("?")="If you want a detail list of each payment line, answer ""Yes"" otherwise press Return key"
DO ^DIR
KILL DIR
+1 if $DATA(DIRUT)
GOTO BT
if Y
WRITE @IOF
if Y
if FBTYPE="B3"
DO LIST
if FBTYPE="B5"
DO LISTP
if FBTYPE="B2"
DO LISTT^FBAACCB0
if FBTYPE="B9"
DO LISTC^FBAACCB1
RDD1 SET DIR(0)="Y"
SET DIR("A")="Do you still want to close Batch"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if 'Y!$DATA(DIRUT)
GOTO BT
+1 NEW FBARY,FBOLD,FBINVT
+2 ;
+3 SET C=0
SET T=0
if FBTYPE="B5"
GOTO PHARM^FBAACCB1
if FBTYPE="B2"
GOTO TRAV^FBAACCB1
if FBTYPE="B9"
GOTO CHNH^FBAACCB1
+4 FOR J=0:0
SET J=$ORDER(^FBAAC("AC",B,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("AC",B,J,K))
if K'>0
QUIT
FOR L=0:0
SET L=$ORDER(^FBAAC("AC",B,J,K,L))
if L'>0
QUIT
FOR M=0:0
SET M=$ORDER(^FBAAC("AC",B,J,K,L,M))
if M'>0
QUIT
DO GOT
FIN ; FB*3.5*116 - check and handle $0 invoices
+1 DO CHECK(.FBARY)
+2 IF $DATA(FBARY)
Begin DoDot:1
+3 ;D EN^DDIOL(.FBARY)
+4 WRITE *7,!!?2,"Batch cannot be closed. Listed invoices are zero dollar "
+5 WRITE *7,!?2,"and must be corrected or removed from the batch."
End DoDot:1
GOTO BT
+6 ; end of changes
+7 ;
+8 SET $PIECE(FZ,"^",9)=T
SET $PIECE(FZ,"^",11)=C
+9 SET $PIECE(FZ,"^",13)=DT
SET ^FBAA(161.7,B,0)=FZ
SET ^FBAA(161.7,B,"ST")="C"
SET ^FBAA(161.7,"AC","C",B)=""
SET DA=B
SET DR="0;ST"
KILL ^FBAA(161.7,"AC","O",B),^FBAA(161.7,"AB","O",$PIECE(^FBAA(161.7,B,0),"^",5),B)
WRITE !!
DO EN^DIQ
WRITE !!,"Batch Closed"
GOTO BT
+10 ;
GOT SET Y(0)=$GET(^FBAAC(J,1,K,1,L,1,M,0))
SET FBIN=$PIECE(Y(0),"^",16)
+1 ; HIPAA 5010 - count line items that have 0.00 amount paid
+2 SET T=T+$PIECE(Y(0),"^",3)
SET C=C+1
+3 ; FB*3.5*116 -collect amount paid for each invoice in batch
+4 SET FBARY(FBIN)=$GET(FBARY(FBIN))+$PIECE(Y(0),"^",3)
+5 QUIT
+6 ;
CHECK(FBINV) ; order thru array and save zero dollar invoices; report any zero dollar invoices
+1 ; FBINV = array of invoices
+2 NEW FBAAIN
+3 SET FBAAIN=0
FOR
SET FBAAIN=$ORDER(FBINV(FBAAIN))
if 'FBAAIN
QUIT
Begin DoDot:1
+4 IF FBINV(FBAAIN)'>0
WRITE !!,"Invoice #: "_FBAAIN_" totals $0.00"
+5 ; remove array elements that represent non-zero dollar invoices
IF '$TEST
KILL FBINV(FBAAIN)
End DoDot:1
+6 QUIT
+7 ;
LIST SET Q=""
SET $PIECE(Q,"=",80)="="
+1 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
ENM DO HED
SET (FBIN,FBINOLD)=""
SET (FBAAOUT,FBINTOT)=0
FOR XY=0:0
SET FBIN=$ORDER(^FBAAC("AJ",B,FBIN))
if FBIN=""!($GET(FBAAOUT))
QUIT
DO INTOT^FBAACCB0
FOR J=0:0
SET J=$ORDER(^FBAAC("AJ",B,FBIN,J))
if J'>0!($GET(FBAAOUT))
QUIT
DO GMORE^FBAACCB0
+1 IF '$GET(FBAAOUT)
SET FBIN=0
DO INTOT^FBAACCB0
+2 QUIT
SET ;
+1 NEW FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBX,FBY3,TAMT
+2 SET N=$SELECT($DATA(^DPT(J,0)):$PIECE(^DPT(J,0),"^",1),1:"")
SET S=$SELECT(N]"":$PIECE(^DPT(J,0),"^",9),1:"")
SET V=$SELECT($DATA(^FBAAV(K,0)):$PIECE(^FBAAV(K,0),"^",1),1:"")
SET VID=$SELECT(V]"":$PIECE(^(0),"^",2),1:"")
+3 SET D=+$GET(^FBAAC(J,1,K,1,L,0))
if 'D
QUIT
+4 SET Y=$GET(^FBAAC(J,1,K,1,L,1,M,0))
if Y']""
QUIT
+5 SET FBY3=$GET(^FBAAC(J,1,K,1,L,1,M,3))
+6 SET FBFPPSC=$PIECE(FBY3,U)
+7 SET FBFPPSL=$PIECE(FBY3,U,2)
+8 SET FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
+9 SET FBADJLR=$PIECE(FBX,U)
+10 SET FBADJLA=$PIECE(FBX,U,2)
+11 SET T=$PIECE(Y,"^",5)
SET FBIN=$PIECE(Y,"^",16)
SET ZS=$PIECE(Y,"^",20)
+12 SET TAMT=$FNUMBER($PIECE(Y,"^",4),"",2)
+13 SET FBVP=$SELECT($PIECE(Y,"^",21)="VP":"#",1:"")
+14 SET FBAACPT=$$CPT^FBAAUTL4($PIECE(Y,U))
+15 SET CPTDESC=$$CPT^FBAAUTL4($PIECE(Y,U),1,D)
+16 SET FBVCHDT=$PIECE(Y,"^",6)
SET FBIN(1)=$PIECE(Y,"^",15)
DO FBCKO^FBAACCB2(J,K,L,M)
+17 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
GO SET A1=$PIECE(Y,"^",2)+.0001
SET A2=$PIECE(Y,"^",3)+.0001
SET A1=$PIECE(A1,".",1)_"."_$EXTRACT($PIECE(A1,".",2),1,2)
SET A2=$PIECE(A2,".",1)_"."_$EXTRACT($PIECE(A2,".",2),1,2)
SET FBINTOT=FBINTOT+A2
+1 if FBTYPE'="B2"
DO WRT
if FBTYPE="B2"
DO WRTT^FBAACCB0
+2 QUIT
WRT IF $Y+8>IOSL
if $EXTRACT(IOST,1,2)["C-"
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
WRITE @IOF
DO HED
+1 SET B(1617)=$SELECT(B="":"",$DATA(^FBAA(161.7,B,0)):$PIECE(^(0),"^"),1:"")
+2 WRITE !!,N,?35,$$SSN^FBAAUTL(J),?58,B(1617),?67,$$DATX^FBAAUTL($GET(FBVCHDT)),!,?3,V,?42,VID,?55,FBIN,?67,$$DATX^FBAAUTL(FBIN(1))
+3 WRITE !,$SELECT($DATA(QQ):QQ_")",1:""),$SELECT(ZS="R":"*",1:""),$SELECT(FBTYPE="B3":FBVP,1:""),$SELECT(FBTYPE="B5":FBPV,1:""),$SELECT($GET(FBCAN)]"":"+",1:"")
+4 IF FBTYPE="B3"
WRITE ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$SELECT($GET(FBMODLE)]"":"-"_$PIECE(FBMODLE,","),1:""),?24,CPTDESC,?54,FBFPPSC,?66,FBFPPSL
+5 IF FBTYPE="B5"
WRITE ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$SELECT($GET(FBMODLE)]"":"-"_$PIECE(FBMODLE,","),1:""),?24,CPTDESC,?56,FBFPPSC,?68,FBFPPSL
+6 IF $PIECE($GET(FBMODLE),",",2)]""
Begin DoDot:1
+7 NEW FBI,FBMOD
+8 FOR FBI=2:1
SET FBMOD=$PIECE(FBMODLE,",",FBI)
if FBMOD=""
QUIT
Begin DoDot:2
+9 IF $Y+5>IOSL
Begin DoDot:3
+10 IF $EXTRACT(IOST,1,2)="C-"
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
+11 WRITE @IOF
DO HED
WRITE !,"(continued)"
End DoDot:3
if FBAAOUT
QUIT
+12 WRITE !,?19,"-",FBMOD
End DoDot:2
if FBAAOUT
QUIT
End DoDot:1
if FBAAOUT
QUIT
+13 WRITE !?4,$JUSTIFY(A1,6),?17,$JUSTIFY(A2,6)
+14 ; write adjustment reasons, if null then write suspend code
+15 WRITE ?30,$SELECT(FBADJLR]"":FBADJLR,1:T)
+16 ; write adjustment amounts, if null then write amount suspended
+17 WRITE ?41,$SELECT(FBADJLA]"":FBADJLA,1:TAMT)
+18 ; write attachment IDs FB*3.5*164
+19 IF FBTYPE="B3"
IF $DATA(^FBAAC(J,1,K,1,L,1,M,10))
Begin DoDot:1
+20 NEW AI,AID,AITI
SET AI=0
SET WRTPC="Attachment ID:"
+21 FOR
SET AI=$ORDER(^FBAAC(J,1,K,1,L,1,M,10,AI))
if 'AI
QUIT
Begin DoDot:2
+22 SET AID=$PIECE($GET(^FBAAC(J,1,K,1,L,1,M,10,AI,0)),U)
IF AI>1
SET WRTPC=WRTPC_","
+23 SET WRTPC=WRTPC_" "_AID
+24 SET AITI=$PIECE($GET(^FBAAC(J,1,K,1,L,1,M,10,AI,0)),U,2)
IF AITI
Begin DoDot:3
+25 SET WRTPC=WRTPC_" ("_$PIECE($GET(^IBE(353.3,AITI,0)),U)
+26 SET WRTPC=WRTPC_" - "
+27 SET WRTPC=WRTPC_$PIECE($GET(^IBE(353.3,AITI,0)),U,2)_")"
End DoDot:3
+28 IF $LENGTH(WRTPC)>IOM
DO WRTSTR^FBAACCB1(.WRTPC,IOM)
End DoDot:2
+29 IF $LENGTH(WRTPC)>0
DO WRTSTR^FBAACCB1(.WRTPC,IOM)
End DoDot:1
+30 ;
+31 DO PMNT^FBAACCB2
SET FBINOLD=FBIN
+32 QUIT
HED WRITE "Patient Name",?20,"('*' Reimbursement to Patient '+' Cancellation Activity)",!,?13,"('#' Voided Payment)",?58,"Batch #",?67,"Voucher Date"
+1 WRITE !,?3,"Vendor Name",?42,"Vendor ID",?53,"Invoice #",?67,"Date Rec'd."
+2 IF FBTYPE="B3"
Begin DoDot:1
+3 WRITE !,?4,"SVC DATE",?14,"CPT-MOD",?24,"SERVICE PROVIDED",?54,"FPPS CLAIM",?66,"FPPS LINE"
+4 WRITE !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ AMOUNT"
End DoDot:1
+5 IF FBTYPE="B5"
Begin DoDot:1
+6 WRITE !,?4,"RX DATE",?14,"RX #",?24,"DRUG NAME",?56,"FPPS CLAIM",?68,"FPPS LINE"
+7 WRITE !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ AMOUNT"
End DoDot:1
+8 WRITE !,Q,!
+9 QUIT
LISTP SET Q=""
SET $PIECE(Q,"=",80)="="
+1 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
ENP DO HED
SET (FBAAOUT,FBINTOT)=0
SET FBINOLD=""
+1 FOR A=0:0
SET A=$ORDER(^FBAA(162.1,"AE",B,A))
if A'>0!($GET(FBAAOUT))
QUIT
SET FBIN=A
DO SETV^FBAACCB0
FOR B2=0:0
SET B2=$ORDER(^FBAA(162.1,"AE",B,A,B2))
if B2'>0!($GET(FBAAOUT))
QUIT
DO INTOT^FBAACCB0
IF $DATA(^FBAA(162.1,A,"RX",B2,0))
SET Z(0)=^(0)
DO MORE^FBAACCB1
+2 IF '$GET(FBAAOUT)
SET FBIN=0
DO INTOT^FBAACCB0
+3 QUIT
