- 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 Feb 18, 2025@23:21:26 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