FBAAVP ;AISC/DMK - VOID & CANCEL VOIDED MEDICAL PAYMENT ;5/15/14 17:36
;;3.5;FEE BASIS;**4,69,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
;Variable 'FBVOID' is set if cancelling a voided payment.
D DT^DICRW
RDP K ^TMP($J) W !! S DIC="^FBAAC(",DIC(0)="AEQM",DIC("A")="Select Patient: " D ^DIC K DIC("A") G Q:X="^"!(X=""),RDP:Y<0 S DFN=+Y
S:'$D(^FBAAC(DFN,1,0)) ^FBAAC(DFN,1,0)="^162.01P^0^0"
RDV W !! S DIC="^FBAAV(",DIC(0)="AEQM",DA(1)=DFN D ^DIC G RDP:X="^"!(X=""),RDV:Y<0 S DA=+Y G:'$D(^FBAAC(DFN,DA,"AD")) NOCL^FBAAVP0 D EN1
I CNT'>0 G NVOID^FBAAVP0
D CPAY G Q
EN1 S Q="",$P(Q,"-",80)="-",CNT=0
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP D HED
F D=0:0 S D=$O(^FBAAC(DFN,DA,"AD",D)) Q:D'>0 F B=0:0 S B=$O(^FBAAC(DFN,DA,"AD",D,B)) Q:B'>0 F K=0:0 S K=$O(^FBAAC(DFN,1,DA,1,B,1,K)) Q:K'>0 S L=^(K,0) Q:$D(^FBAAC(DFN,1,DA,1,B,1,K,"FBREJ")) D EN2
Q
EN2 S FBAAPD=$P(L,"^",14),ZS=$P(L,"^",20),FD=$P(L,"^",6),FBON=$P(L,"^",10),V=$P(L,"^",21) I FD]""&$S($D(FBVOID):(V="VP"),1:(V="")) D WRT
Q
WRT N FBFPPSC S FBFPPSC=$P($G(^FBAAC(DFN,1,DA,1,B,1,K,3)),U,1)
S FBDT=$P(^FBAAC(DFN,1,DA,1,B,0),"^"),FBAADT=$E(FBDT,4,5)_"/"_$E(FBDT,6,7)_"/"_$E(FBDT,2,3),B1=$P(L,"^",8),B2=$S(B1="":"",$D(^FBAA(161.7,B1,0)):$P(^FBAA(161.7,B1,0),"^"),1:""),CNT=CNT+1,FBVD=DA,FBSD=B,FBSV=K
D FBCKO^FBAACCB2(DFN,FBVD,FBSD,FBSV)
S FBAAPD=$S(FBAAPD]"":$E(FBAAPD,4,5)_"/"_$E(FBAAPD,6,7)_"/"_$E(FBAAPD,2,3),1:"")
S A1=$P(L,"^",2)+.0001,A2=$P(L,"^",3)+.0001,A1=$P(A1,".")_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".")_"."_$E($P(A2,".",2),1,2),FBIN=$P(L,"^",16)
S FBAACPT=$$CPT^FBAAUTL4($P(L,"^"))
S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_DA_",1,"_B_",1,"_K_",""M"")","E")
W !,CNT_") ",$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""),?3,FBAADT,?14,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?23,"$",$J(A1,8),?34,"$",$J(A2,8),?49,FBIN,?60,B2,?68,FBAAPD
I $P($G(FBMODLE),",",2)]"" D ;Q:FBAAOUT
. N FBI
. F FBI=2:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D ;Q:FBAAOUT
. . ;I $Y+4>IOSL D Q:FBAAOUT
. . ;. I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
. . ;. D HED W !,CNT,") (continued)"
. . W !,?19,"-",FBMOD
I FBFPPSC]"" W !,?4,"FPPS Claim ID: ",FBFPPSC
D PMNT^FBAACCB2
I $D(^FBAAC(DFN,1,DA,1,B,1,K,"R")),^("R")]"" W !?3,"Reason:",!?10,^("R"),!
S ^TMP($J,CNT)=FBAADT_"^"_FBAACPT_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_"^"_$J(A1,8)_"^"_$J(A2,8)_"^"_FBFPPSC_"^"_FBIN_"^"_B2_"^"_FBAAPD_"^"_FBSD_"^"_FBSV_"^"_FD_"^"_A2_"^"_FBON Q
Q
HED W @IOF,"Patient Name: ",$P(^DPT(DFN,0),"^"),?50,"Pt.ID ",$$SSN^FBAAUTL(DFN),!!,?2,"VENDOR: ",$P(^FBAAV(DA,0),"^"),!,?10,"('*' Reimb. to Patient '#' Voided Payment)"
W !," SVC DATE",?11,"CPT-MOD",?20,"AMT CLAIMED",?35,"AMT PAID",?47,"INVOICE #",?57,"BATCH #",?66,"DATE PAID",!,Q,!
Q
Q K DIC,DIE,DA,DF,DA(1),^TMP($J),A,A1,A2,B,B1,B2,C,CNT,D,D0,D1,D2,D3,DI,DR,DFN,DIYS,FBAACB,FBAACPT,FBAADT,FBAAPD,FBX,DIR,FBDT,FBIN,FBON,FBSD,FBSV,FD,FBVD,FBVOID,I,K,L,ON,POP,P3,P4,Q,V,X,Y,VP,VAL,ZS,Z,ZZ,FBSSN,DIRUT,FBMOD,FBMODLE
Q
CPAY W !!,"Which payment item(s) would you like to ",$S($D(FBVOID):"Cancel the void on",1:"Void")," ? " S DIR(0)="L^1:"_CNT D ^DIR
G RDV:$D(DIRUT) S FBX=Y D HED
F A=1:1:CNT S X=$P(FBX,",",A) Q:X="" S Y(0)=^TMP($J,X),FBSD=$P(Y(0),"^",9),FBSV=$P(Y(0),"^",10),FD=$P(Y(0),"^",11),A2=$P(Y(0),"^",12),FBON=$P(Y(0),"^",13),^TMP($J,"VOID",X)=DFN_"^"_FBVD_"^"_FBSD_"^"_FBSV_"^"_FD_"^"_A2_"^"_FBON D PRT2
VERF S DIR(0)="Y",DIR("A")="Are you sure you want to "_$S($D(FBVOID):"Cancel the void on ",1:"Void ")_"the payment(s)",DIR("B")="NO" D ^DIR K DIR G RDP:$D(DIRUT)!'Y
F I=0:0 S I=$O(^TMP($J,"VOID",I)) Q:I'>0 S Y(0)=^(I),DFN=$P(Y(0),"^"),FBVD=$P(Y(0),"^",2),FBSD=$P(Y(0),"^",3),FBSV=$P(Y(0),"^",4),A2=$P(Y(0),"^",6),FBON=$P(Y(0),"^",7) D SETN,^FBAAVP0 W !,?5,".... Done.",!
K FBVR Q
SETN S DA=FBSV,VP=$S($D(FBVOID):"",1:"VOID")
I $D(FBVOID) S DR="24///@;24.5///@;25///@"
I '$D(FBVOID) S DR="24///^S X=VP;25////^S X=DUZ"_$S($D(FBVR):";24.5////^S X=FBVR",1:";24.5R;S FBVR=X")
S DIE="^FBAAC("_DFN_",1,"_FBVD_",1,"_FBSD_",1,",DIDEL=162 D ^DIE K DIDEL Q
PRT2 D FBCKO^FBAACCB2(DFN,FBVD,FBSD,FBSV)
W !,$P(Y(0),"^",1),?14,$P($P(Y(0),"^",2),","),?23,$P(Y(0),"^",3),?34,$P(Y(0),"^",4),?49,$P(Y(0),"^",6),?62,$P(Y(0),"^",7),?68,$P(Y(0),"^",8)
I $P($P(Y(0),U,2),",",2)]"" D ;Q:FBAAOUT
. N FBI
. F FBI=2:1 S FBMOD=$P($P(Y(0),U,2),",",FBI) Q:FBMOD="" D ;Q:FBAAOUT
. . ;I $Y+4>IOSL D Q:FBAAOUT
. . ;. I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
. . ;. D HED W !,CNT,") (continued)"
. . W !,?19,"-",FBMOD
I $P(Y(0),U,5)]"" W !,?4,"FPPS Claim ID: ",$P(Y(0),U,5)
W !
D PMNT^FBAACCB2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAVP 4676 printed Dec 13, 2024@01:57:08 Page 2
FBAAVP ;AISC/DMK - VOID & CANCEL VOIDED MEDICAL PAYMENT ;5/15/14 17:36
+1 ;;3.5;FEE BASIS;**4,69,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;Variable 'FBVOID' is set if cancelling a voided payment.
+4 DO DT^DICRW
RDP KILL ^TMP($JOB)
WRITE !!
SET DIC="^FBAAC("
SET DIC(0)="AEQM"
SET DIC("A")="Select Patient: "
DO ^DIC
KILL DIC("A")
if X="^"!(X="")
GOTO Q
if Y<0
GOTO RDP
SET DFN=+Y
+1 if '$DATA(^FBAAC(DFN,1,0))
SET ^FBAAC(DFN,1,0)="^162.01P^0^0"
RDV WRITE !!
SET DIC="^FBAAV("
SET DIC(0)="AEQM"
SET DA(1)=DFN
DO ^DIC
if X="^"!(X="")
GOTO RDP
if Y<0
GOTO RDV
SET DA=+Y
if '$DATA(^FBAAC(DFN,DA,"AD"))
GOTO NOCL^FBAAVP0
DO EN1
+1 IF CNT'>0
GOTO NVOID^FBAAVP0
+2 DO CPAY
GOTO Q
EN1 SET Q=""
SET $PIECE(Q,"-",80)="-"
SET CNT=0
+1 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
DO HED
+2 FOR D=0:0
SET D=$ORDER(^FBAAC(DFN,DA,"AD",D))
if D'>0
QUIT
FOR B=0:0
SET B=$ORDER(^FBAAC(DFN,DA,"AD",D,B))
if B'>0
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC(DFN,1,DA,1,B,1,K))
if K'>0
QUIT
SET L=^(K,0)
if $DATA(^FBAAC(DFN,1,DA,1,B,1,K,"FBREJ"))
QUIT
DO EN2
+3 QUIT
EN2 SET FBAAPD=$PIECE(L,"^",14)
SET ZS=$PIECE(L,"^",20)
SET FD=$PIECE(L,"^",6)
SET FBON=$PIECE(L,"^",10)
SET V=$PIECE(L,"^",21)
IF FD]""&$SELECT($DATA(FBVOID):(V="VP"),1:(V=""))
DO WRT
+1 QUIT
WRT NEW FBFPPSC
SET FBFPPSC=$PIECE($GET(^FBAAC(DFN,1,DA,1,B,1,K,3)),U,1)
+1 SET FBDT=$PIECE(^FBAAC(DFN,1,DA,1,B,0),"^")
SET FBAADT=$EXTRACT(FBDT,4,5)_"/"_$EXTRACT(FBDT,6,7)_"/"_$EXTRACT(FBDT,2,3)
SET B1=$PIECE(L,"^",8)
SET B2=$SELECT(B1="":"",$DATA(^FBAA(161.7,B1,0)):$PIECE(^FBAA(161.7,B1,0),"^"),1:"")
SET CNT=CNT+1
SET FBVD=DA
SET FBSD=B
SET FBSV=K
+2 DO FBCKO^FBAACCB2(DFN,FBVD,FBSD,FBSV)
+3 SET FBAAPD=$SELECT(FBAAPD]"":$EXTRACT(FBAAPD,4,5)_"/"_$EXTRACT(FBAAPD,6,7)_"/"_$EXTRACT(FBAAPD,2,3),1:"")
+4 SET A1=$PIECE(L,"^",2)+.0001
SET A2=$PIECE(L,"^",3)+.0001
SET A1=$PIECE(A1,".")_"."_$EXTRACT($PIECE(A1,".",2),1,2)
SET A2=$PIECE(A2,".")_"."_$EXTRACT($PIECE(A2,".",2),1,2)
SET FBIN=$PIECE(L,"^",16)
+5 SET FBAACPT=$$CPT^FBAAUTL4($PIECE(L,"^"))
+6 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_DA_",1,"_B_",1,"_K_",""M"")","E")
+7 WRITE !,CNT_") ",$SELECT(ZS="R":"*",1:""),$SELECT(V="VP":"#",1:""),?3,FBAADT,?14,FBAACPT_$SELECT($GET(FBMODLE)]"":"-"_$PIECE(FBMODLE,","),1:""),?23,"$",$JUSTIFY(A1,8),?34,"$",$JUSTIFY(A2,8),?49,FBIN,?60,B2,?68,FBAAPD
+8 ;Q:FBAAOUT
IF $PIECE($GET(FBMODLE),",",2)]""
Begin DoDot:1
+9 NEW FBI
+10 ;Q:FBAAOUT
FOR FBI=2:1
SET FBMOD=$PIECE(FBMODLE,",",FBI)
if FBMOD=""
QUIT
Begin DoDot:2
+11 ;I $Y+4>IOSL D Q:FBAAOUT
+12 ;. I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
+13 ;. D HED W !,CNT,") (continued)"
+14 WRITE !,?19,"-",FBMOD
End DoDot:2
End DoDot:1
+15 IF FBFPPSC]""
WRITE !,?4,"FPPS Claim ID: ",FBFPPSC
+16 DO PMNT^FBAACCB2
+17 IF $DATA(^FBAAC(DFN,1,DA,1,B,1,K,"R"))
IF ^("R")]""
WRITE !?3,"Reason:",!?10,^("R"),!
+18 SET ^TMP($JOB,CNT)=FBAADT_"^"_FBAACPT_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")_"^"_$JUSTIFY(A1,8)_"^"_$JUSTIFY(A2,8)_"^"_FBFPPSC_"^"_FBIN_"^"_B2_"^"_FBAAPD_"^"_FBSD_"^"_FBSV_"^"_FD_"^"_A2_"^"_FBON
QUIT
+19 QUIT
HED WRITE @IOF,"Patient Name: ",$PIECE(^DPT(DFN,0),"^"),?50,"Pt.ID ",$$SSN^FBAAUTL(DFN),!!,?2,"VENDOR: ",$PIECE(^FBAAV(DA,0),"^"),!,?10,"('*' Reimb. to Patient '#' Voided Payment)"
+1 WRITE !," SVC DATE",?11,"CPT-MOD",?20,"AMT CLAIMED",?35,"AMT PAID",?47,"INVOICE #",?57,"BATCH #",?66,"DATE PAID",!,Q,!
+2 QUIT
Q KILL DIC,DIE,DA,DF,DA(1),^TMP($JOB),A,A1,A2,B,B1,B2,C,CNT,D,D0,D1,D2,D3,DI,DR,DFN,DIYS,FBAACB,FBAACPT,FBAADT,FBAAPD,FBX,DIR,FBDT,FBIN,FBON,FBSD,FBSV,FD,FBVD,FBVOID,I,K,L,ON,POP,P3,P4,Q,V,X,Y,VP,VAL,ZS,Z,ZZ,FBSSN,DIRUT,FBMOD,FBMODLE
+1 QUIT
CPAY WRITE !!,"Which payment item(s) would you like to ",$SELECT($DATA(FBVOID):"Cancel the void on",1:"Void")," ? "
SET DIR(0)="L^1:"_CNT
DO ^DIR
+1 if $DATA(DIRUT)
GOTO RDV
SET FBX=Y
DO HED
+2 FOR A=1:1:CNT
SET X=$PIECE(FBX,",",A)
if X=""
QUIT
SET Y(0)=^TMP($JOB,X)
SET FBSD=$PIECE(Y(0),"^",9)
SET FBSV=$PIECE(Y(0),"^",10)
SET FD=$PIECE(Y(0),"^",11)
SET A2=$PIECE(Y(0),"^",12)
SET FBON=$PIECE(Y(0),"^",13)
SET ^TMP($JOB,"VOID",X)=DFN_"^"_FBVD_"^"_FBSD_"^"_FBSV_"^"_FD_"^"_A2_"^"_FBON
DO PRT2
VERF SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to "_$SELECT($DATA(FBVOID):"Cancel the void on ",1:"Void ")_"the payment(s)"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO RDP
+1 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"VOID",I))
if I'>0
QUIT
SET Y(0)=^(I)
SET DFN=$PIECE(Y(0),"^")
SET FBVD=$PIECE(Y(0),"^",2)
SET FBSD=$PIECE(Y(0),"^",3)
SET FBSV=$PIECE(Y(0),"^",4)
SET A2=$PIECE(Y(0),"^",6)
SET FBON=$PIECE(Y(0),"^",7)
DO SETN
DO ^FBAAVP0
WRITE !,?5,".... Done.",!
+2 KILL FBVR
QUIT
SETN SET DA=FBSV
SET VP=$SELECT($DATA(FBVOID):"",1:"VOID")
+1 IF $DATA(FBVOID)
SET DR="24///@;24.5///@;25///@"
+2 IF '$DATA(FBVOID)
SET DR="24///^S X=VP;25////^S X=DUZ"_$SELECT($DATA(FBVR):";24.5////^S X=FBVR",1:";24.5R;S FBVR=X")
+3 SET DIE="^FBAAC("_DFN_",1,"_FBVD_",1,"_FBSD_",1,"
SET DIDEL=162
DO ^DIE
KILL DIDEL
QUIT
PRT2 DO FBCKO^FBAACCB2(DFN,FBVD,FBSD,FBSV)
+1 WRITE !,$PIECE(Y(0),"^",1),?14,$PIECE($PIECE(Y(0),"^",2),","),?23,$PIECE(Y(0),"^",3),?34,$PIECE(Y(0),"^",4),?49,$PIECE(Y(0),"^",6),?62,$PIECE(Y(0),"^",7),?68,$PIECE(Y(0),"^",8)
+2 ;Q:FBAAOUT
IF $PIECE($PIECE(Y(0),U,2),",",2)]""
Begin DoDot:1
+3 NEW FBI
+4 ;Q:FBAAOUT
FOR FBI=2:1
SET FBMOD=$PIECE($PIECE(Y(0),U,2),",",FBI)
if FBMOD=""
QUIT
Begin DoDot:2
+5 ;I $Y+4>IOSL D Q:FBAAOUT
+6 ;. I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
+7 ;. D HED W !,CNT,") (continued)"
+8 WRITE !,?19,"-",FBMOD
End DoDot:2
End DoDot:1
+9 IF $PIECE(Y(0),U,5)]""
WRITE !,?4,"FPPS Claim ID: ",$PIECE(Y(0),U,5)
+10 WRITE !
+11 DO PMNT^FBAACCB2
+12 QUIT
