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