- FBAAVS ;AISC/GRR-DISPLAY VENDOR PAYMENT RECORDS ;7/17/2003
- ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- RDP 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 D EN1
- G RDV
- EN1 ; display payments for veteran (DFN) and vendor (DA)
- N FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRRMKL,FBUNITS
- N FBY2,FBY3,TAMT
- S Q="" F A=1:1:79 S Q=Q_"-",FBAAOUT=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!(FBAAOUT) F B=0:0 S B=$O(^FBAAC(DFN,DA,"AD",D,B)) Q:B'>0!(FBAAOUT) F K=0:0 S K=$O(^FBAAC(DFN,1,DA,1,B,1,K)) Q:K'>0!(FBAAOUT) S L=^(K,0) D MORE,WRT
- W ! K B,C,D,T
- Q
- HED W @IOF,"Patient Name: ",$P(^DPT(DFN,0),"^",1),?50,"SSN: ",$P(^(0),"^",9),!!,?2,"VENDOR: ",$P(^FBAAV(DA,0),"^",1),!?5,$P(^FBAAV(DA,0),"^",3) S FBST=$P(^FBAAV(DA,0),"^",5)
- W !?5,$P(^FBAAV(DA,0),"^",4)_", "_$P($G(^DIC(5,+FBST,0)),U)_" "_$P(^FBAAV(DA,0),"^",6)
- W !,?10,"('*' Reimb. to Patient '+' Cancel. Activity '#' Voided Payment)"
- W !,?2,"SVC DATE",?12,"CPT-MOD",?22,"REV.CODE",?32,"UNITS",?39,"PATIENT ACCOUNT NO.",?61,"INVOICE #",?72,"BATCH #"
- W !,?12,"AMT CLAIMED",?25,"AMT PAID",?38,"ADJ CODE",?48,"ADJ AMOUNT",?65,"REMIT REMARK"
- W !,Q,!
- Q
- WRT I $E(IOST,1,2)["C-",$Y+3>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q:FBAAOUT D HED
- S FBAADT=$P(^FBAAC(DFN,1,DA,1,B,0),"^",1),FBAADT=$E(FBAADT,4,5)_"/"_$E(FBAADT,6,7)_"/"_$E(FBAADT,2,3),B1=$P(L,"^",8),B2=$S(B1="":"",$D(^FBAA(161.7,B1,0)):$P(^FBAA(161.7,B1,0),"^",1),1:"")
- S TAMT=$FN($P(L,U,4),"",2)
- S A1=$P(L,"^",2)+.0001,A2=$P(L,"^",3)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2),FBIN=$P(L,"^",16)
- S FBAACPT=$$CPT^FBAAUTL4($P(L,"^",1))
- S FBUNITS=$P(FBY2,U,14)
- S FBCSID=$P(FBY2,U,16)
- S FBFPPSC=$P(FBY3,U)
- S FBFPPSL=$P(FBY3,U,2)
- D FBCKO^FBAACCB2(DFN,DA,B,K)
- W !,$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""),$S($G(FBCAN)]"":"+",1:"")
- W ?2,FBAADT,?12,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?22,FBAARCE,?32,FBUNITS,?39,FBCSID,?61,FBIN,?72,B2
- ; write additional modifiers (if any)
- 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+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 !,"(continued)"
- . . W !,?17,"-",FBMOD
- W !?12,"$",$J(A1,8),?25,"$",$J(A2,8)
- ; write adjustment reasons, if null then write suspend code
- W ?38,$S(FBADJLR]"":FBADJLR,1:T)
- ; write adjustment amounts, if null then write amount suspended
- W ?48,"$",$S(FBADJLA]"":FBADJLA,1:TAMT)
- W ?65,FBRRMKL
- I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL
- D PMNT^FBAACCB2
- Q
- Q K DIC,DIE,DA,DF,DA(1),FBAAOUT,A,A1,A2,B1,B2,D1,FBAACPT,FBAADT,FBAAPD,FBIN,K,L,Q,X,Y,ZS,V,FBST,FBMODLE
- Q
- MORE N FBX
- S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_DA_",1,"_B_",1,"_K_",""M"")","E")
- S T=$P(L,"^",5),T=$S(T>9:$P(^FBAA(161.27,T,0),"^"),1:T),ZS=$P(L,"^",20),V=$P(L,"^",21)
- S FBY2=$G(^FBAAC(DFN,1,DA,1,B,1,K,2))
- S FBY3=$G(^FBAAC(DFN,1,DA,1,B,1,K,3))
- S FBX=$$ADJLRA^FBAAFA(K_","_B_","_DA_","_DFN_",")
- S FBADJLR=$P(FBX,U)
- S FBADJLA=$P(FBX,U,2)
- S FBRRMKL=$$RRL^FBAAFR(K_","_B_","_DA_","_DFN_",")
- S FBAARCE=$$GET1^DIQ(162.03,K_","_B_","_DA_","_DFN_",",48)
- Q
- NOCL W !,"Vendor has no Payment data for this Patient!",! G RDV
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAVS 3665 printed Jan 18, 2025@02:58:30 Page 2
- FBAAVS ;AISC/GRR-DISPLAY VENDOR PAYMENT RECORDS ;7/17/2003
- +1 ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- RDP 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
- DO EN1
- +1 GOTO RDV
- EN1 ; display payments for veteran (DFN) and vendor (DA)
- +1 NEW FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRRMKL,FBUNITS
- +2 NEW FBY2,FBY3,TAMT
- +3 SET Q=""
- FOR A=1:1:79
- SET Q=Q_"-"
- SET FBAAOUT=0
- +4 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
- DO ^%ZIS
- KILL IOP
- DO HED
- +5 FOR D=0:0
- SET D=$ORDER(^FBAAC(DFN,DA,"AD",D))
- if D'>0!(FBAAOUT)
- QUIT
- FOR B=0:0
- SET B=$ORDER(^FBAAC(DFN,DA,"AD",D,B))
- if B'>0!(FBAAOUT)
- QUIT
- FOR K=0:0
- SET K=$ORDER(^FBAAC(DFN,1,DA,1,B,1,K))
- if K'>0!(FBAAOUT)
- QUIT
- SET L=^(K,0)
- DO MORE
- DO WRT
- +6 WRITE !
- KILL B,C,D,T
- +7 QUIT
- HED WRITE @IOF,"Patient Name: ",$PIECE(^DPT(DFN,0),"^",1),?50,"SSN: ",$PIECE(^(0),"^",9),!!,?2,"VENDOR: ",$PIECE(^FBAAV(DA,0),"^",1),!?5,$PIECE(^FBAAV(DA,0),"^",3)
- SET FBST=$PIECE(^FBAAV(DA,0),"^",5)
- +1 WRITE !?5,$PIECE(^FBAAV(DA,0),"^",4)_", "_$PIECE($GET(^DIC(5,+FBST,0)),U)_" "_$PIECE(^FBAAV(DA,0),"^",6)
- +2 WRITE !,?10,"('*' Reimb. to Patient '+' Cancel. Activity '#' Voided Payment)"
- +3 WRITE !,?2,"SVC DATE",?12,"CPT-MOD",?22,"REV.CODE",?32,"UNITS",?39,"PATIENT ACCOUNT NO.",?61,"INVOICE #",?72,"BATCH #"
- +4 WRITE !,?12,"AMT CLAIMED",?25,"AMT PAID",?38,"ADJ CODE",?48,"ADJ AMOUNT",?65,"REMIT REMARK"
- +5 WRITE !,Q,!
- +6 QUIT
- WRT IF $EXTRACT(IOST,1,2)["C-"
- IF $Y+3>IOSL
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET FBAAOUT=1
- if FBAAOUT
- QUIT
- DO HED
- +1 SET FBAADT=$PIECE(^FBAAC(DFN,1,DA,1,B,0),"^",1)
- SET FBAADT=$EXTRACT(FBAADT,4,5)_"/"_$EXTRACT(FBAADT,6,7)_"/"_$EXTRACT(FBAADT,2,3)
- SET B1=$PIECE(L,"^",8)
- SET B2=$SELECT(B1="":"",$DATA(^FBAA(161.7,B1,0)):$PIECE(^FBAA(161.7,B1,0),"^",1),1:"")
- +2 SET TAMT=$FNUMBER($PIECE(L,U,4),"",2)
- +3 SET A1=$PIECE(L,"^",2)+.0001
- SET A2=$PIECE(L,"^",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 FBIN=$PIECE(L,"^",16)
- +4 SET FBAACPT=$$CPT^FBAAUTL4($PIECE(L,"^",1))
- +5 SET FBUNITS=$PIECE(FBY2,U,14)
- +6 SET FBCSID=$PIECE(FBY2,U,16)
- +7 SET FBFPPSC=$PIECE(FBY3,U)
- +8 SET FBFPPSL=$PIECE(FBY3,U,2)
- +9 DO FBCKO^FBAACCB2(DFN,DA,B,K)
- +10 WRITE !,$SELECT(ZS="R":"*",1:""),$SELECT(V="VP":"#",1:""),$SELECT($GET(FBCAN)]"":"+",1:"")
- +11 WRITE ?2,FBAADT,?12,FBAACPT_$SELECT($GET(FBMODLE)]"":"-"_$PIECE(FBMODLE,","),1:""),?22,FBAARCE,?32,FBUNITS,?39,FBCSID,?61,FBIN,?72,B2
- +12 ; write additional modifiers (if any)
- +13 IF $PIECE($GET(FBMODLE),",",2)]""
- Begin DoDot:1
- +14 NEW FBI,FBMOD
- +15 FOR FBI=2:1
- SET FBMOD=$PIECE(FBMODLE,",",FBI)
- if FBMOD=""
- QUIT
- Begin DoDot:2
- +16 IF $Y+4>IOSL
- Begin DoDot:3
- +17 IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET FBAAOUT=1
- QUIT
- +18 DO HED
- WRITE !,"(continued)"
- End DoDot:3
- if FBAAOUT
- QUIT
- +19 WRITE !,?17,"-",FBMOD
- End DoDot:2
- if FBAAOUT
- QUIT
- End DoDot:1
- if FBAAOUT
- QUIT
- +20 WRITE !?12,"$",$JUSTIFY(A1,8),?25,"$",$JUSTIFY(A2,8)
- +21 ; write adjustment reasons, if null then write suspend code
- +22 WRITE ?38,$SELECT(FBADJLR]"":FBADJLR,1:T)
- +23 ; write adjustment amounts, if null then write amount suspended
- +24 WRITE ?48,"$",$SELECT(FBADJLA]"":FBADJLA,1:TAMT)
- +25 WRITE ?65,FBRRMKL
- +26 IF FBFPPSC]""
- WRITE !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL
- +27 DO PMNT^FBAACCB2
- +28 QUIT
- Q KILL DIC,DIE,DA,DF,DA(1),FBAAOUT,A,A1,A2,B1,B2,D1,FBAACPT,FBAADT,FBAAPD,FBIN,K,L,Q,X,Y,ZS,V,FBST,FBMODLE
- +1 QUIT
- MORE NEW FBX
- +1 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_DA_",1,"_B_",1,"_K_",""M"")","E")
- +2 SET T=$PIECE(L,"^",5)
- SET T=$SELECT(T>9:$PIECE(^FBAA(161.27,T,0),"^"),1:T)
- SET ZS=$PIECE(L,"^",20)
- SET V=$PIECE(L,"^",21)
- +3 SET FBY2=$GET(^FBAAC(DFN,1,DA,1,B,1,K,2))
- +4 SET FBY3=$GET(^FBAAC(DFN,1,DA,1,B,1,K,3))
- +5 SET FBX=$$ADJLRA^FBAAFA(K_","_B_","_DA_","_DFN_",")
- +6 SET FBADJLR=$PIECE(FBX,U)
- +7 SET FBADJLA=$PIECE(FBX,U,2)
- +8 SET FBRRMKL=$$RRL^FBAAFR(K_","_B_","_DA_","_DFN_",")
- +9 SET FBAARCE=$$GET1^DIQ(162.03,K_","_B_","_DA_","_DFN_",",48)
- +10 QUIT
- NOCL WRITE !,"Vendor has no Payment data for this Patient!",!
- GOTO RDV