FBPAY ;AISC/DMK,GRR,TET-PATIENT/VENDOR PAYMENT OUTPUT DRIVER ;20/NOV/2006
;;3.5;FEE BASIS;**32,69,101**;JAN 30, 1995;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
GETVEN ;select vendor
K FBX S FBSORT=0 ;FBSORT=1 for patient, = 0 for vendor
S DIC="^FBAAV(",DIC(0)="AEQMZ",DIC("A")="Select Fee Vendor: " W !! D ^DIC K DIC("A") G EXIT:$D(DTOUT)!($D(DUOUT))!(X=""),GETVEN:Y<0
S FBIEN=+Y,FBNAME=$S(Y(0,0)]"":Y(0,0),1:"UNKNOWN"),FBID=$S($P(Y(0),U,2)]"":$P(Y(0),U,2),1:"UNKNOWN") G DATE
GETVET ;select patient
K FBX S FBSORT=1 ;FBSORT=1 for patient, =0 for vendor
S DIC="^FBAAA("
S DIC(0)="AEQMNZ",DIC("A")="Select Fee Patient: " W !! D ^DIC K DIC("A") G EXIT:$D(DTOUT)!($D(DUOUT))!(X=""),GETVET:Y<0
S FBIEN=+Y,FBNAME=Y(0,0),FBID=$$SSNL4^FBAAUTL($$SSN^FBAAUTL(FBIEN))
DATE ;select date range
D DATE^FBAAUTL I FBPOP G GETVET:FBSORT,GETVEN
S FBBDATE=BEGDATE,FBEDATE=ENDDATE
S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE
PROG ;select one/many/all fee programs
I '$G(FBCHK) S DIC="^FBAA(161.8,",DIC("S")="I $P(^(0),U,3)",VAUTSTR="FEE Program",VAUTNI=2,VAUTVB="FBPROG" D FIRST^VAUTOMA I 'FBPROG&('$O(FBPROG(0))) G GETVET:FBSORT,GETVEN
I FBPROG S FBERR=0 D ARRAY G EXIT:FBERR
ASKMB ; if outpatient or civil hospital or pharmacy selected then ask if
; report for just mill-bill (1725) or just non-mill bill claims
I $D(FBPROG(2))!$D(FBPROG(3))!$D(FBPROG(6)) S FB1725R=$$ASKMB^FBUCUTL9 I FB1725R="" G EXIT
Q K ^TMP($J,"FB"),^TMP($J,"FBTR"),DIC S FBX=FBSORT
S VAR="FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPROG^FBPROG(^FBSORT^FB1725R",VAL=VAR,PGM="DQ^FBPAY" D ZIS^FBAAUTL G:FBPOP EXIT
DQ S $P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBPG=0,FBCRT=$S($E(IOST,1,2)="C-":1,1:0),FBOUT=0,FBBEG=FBBEG-.9 U IO
SORT ;sort driver for payment output(s)
S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D
.I FBPI=2 D EN^FBPAY2 ;outpatient payments
.I FBPI=3 D EN^FBPAY3 ;pharmacy payments
.I FBPI=6!(FBPI=7) S:FBPI=6&$D(FBPROG(7)) FBPIFLG=67 D EN^FBPAY67 S:$D(FBPIFLG) FBPI=7 K FBPIFLG ;civil hospital/cnh payments
PRINT ;print driver for payment output(s)
S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT
S (FBOUT,FBPI)=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D Q:FBOUT
.I FBPI=2,$D(^TMP($J,"FB",FBPI)) D PRINT^FBPAY21 Q:$G(FBOUT) D:$D(^TMP($J,"FB",FBPI_"O")) OTH Q
.I FBPI=3 D:$D(^TMP($J,"FB",FBPI)) PRINT^FBPAY3 Q:$G(FBOUT) D:$D(^TMP($J,"FB",FBPI_"O")) OTH Q
.I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPI)) PRINT^FBPAY671 Q:$G(FBOUT) D:$D(^TMP($J,"FB",FBPI_"O")) OTH Q
OUT I FBOUT!$D(ZTQUEUED) G EXIT
D KILL G GETVET:FBX,GETVEN
Q
EXIT ;kill and quit
K FBX
KILL ;kill all variables set in the FBPAY* routines, other than fbx
D CLOSE^FBAAUTL K ^TMP($J,"FB"),^TMP($J,"FBTR")
K A1,A2,A3,BEGDATE,B3,C,C3,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE
K FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD,FBMOD
K FBI,FBID,FBIEN,FBIN,FBINVN,FBIX,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIFLG,FBPIN,FBPISV,FBPNAME,FBPROG,FBPT,FBPV,FBQTY,FBREIM,FBR,FBRX,FBTRCK
K FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,TAMT,FBRRMKL,FBADJ,FBINV
K FBSC,FBSL,FBSORT,FBSTR,FBSUSP,FBTA,FBTRDT,FBTRX,FBTYPE,FBV,FBVCHAIN,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,J,K,L,M,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z
K FB1725R
Q
ARRAY ;set array if all programs are selected
S FBPI=0 F S FBPI=$O(^FBAA(161.8,FBPI)) Q:'FBPI S FBPIN=$G(^(FBPI,0)) I $P(FBPIN,U,3) S FBPROG(FBPI)=$P(FBPIN,U)
I '$D(FBPROG) S FBERR=1
Q
WMSG ;write message if no matches found
S FBPG=FBPG+1 W:$G(FBCRT) @IOF W !
W !?25,$S($G(FBSORT):"VETERAN",1:"VENDOR")," PAYMENT HISTORY"
I $G(FB1725R)]"",FB1725R'="A" W " ",$S(FB1725R="M":"for 38 U.S.C. 1725 Claims",1:"excluding 38 U.S.C. 1725 Claims")
W !?24,$E(FBDASH,1,24),?71,"Page: ",FBPG
I FBSORT W !,"Patient: ",FBNAME,?41,"Patient ID:",FBID
I 'FBSORT W !,"Vendor: ",FBNAME,?41,"Vendor ID:",FBID
;W !?(IOM-12/2),"FEE PROGRAM:"
W !?3,"('*' Reimb. to Patient '+' Cancel. Activity '#' Voided Payment)"
W !!!,FBDASH
W !!,"There are no payments on file for "_$S(FBSORT:"Veteran",1:"Vendor")_" ",FBNAME,!?3,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE)
I 'FBPROG D
.W !?3,"and selected Fee Program(s):"
.S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI W !?30,FBPROG(FBPI)
I FBPROG W !?3,"and ALL Fee programs"
W ".",*7,!!
Q
OTH ;other fee basis programs
I '$D(^TMP($J,"FB",FBPI_"O")) Q
S FBZ=FBPI,FBPI=FBPI_"O",FBPROG(FBPI)="**OUTPATIENT** "_FBXPROG
D PRINT^FBPAY21
K FBPROG(FBPI) S FBPI=FBZ K FBZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPAY 4760 printed Sep 23, 2025@19:35:33 Page 2
FBPAY ;AISC/DMK,GRR,TET-PATIENT/VENDOR PAYMENT OUTPUT DRIVER ;20/NOV/2006
+1 ;;3.5;FEE BASIS;**32,69,101**;JAN 30, 1995;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
GETVEN ;select vendor
+1 ;FBSORT=1 for patient, = 0 for vendor
KILL FBX
SET FBSORT=0
+2 SET DIC="^FBAAV("
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Fee Vendor: "
WRITE !!
DO ^DIC
KILL DIC("A")
if $DATA(DTOUT)!($DATA(DUOUT))!(X="")
GOTO EXIT
if Y<0
GOTO GETVEN
+3 SET FBIEN=+Y
SET FBNAME=$SELECT(Y(0,0)]"":Y(0,0),1:"UNKNOWN")
SET FBID=$SELECT($PIECE(Y(0),U,2)]"":$PIECE(Y(0),U,2),1:"UNKNOWN")
GOTO DATE
GETVET ;select patient
+1 ;FBSORT=1 for patient, =0 for vendor
KILL FBX
SET FBSORT=1
+2 SET DIC="^FBAAA("
+3 SET DIC(0)="AEQMNZ"
SET DIC("A")="Select Fee Patient: "
WRITE !!
DO ^DIC
KILL DIC("A")
if $DATA(DTOUT)!($DATA(DUOUT))!(X="")
GOTO EXIT
if Y<0
GOTO GETVET
+4 SET FBIEN=+Y
SET FBNAME=Y(0,0)
SET FBID=$$SSNL4^FBAAUTL($$SSN^FBAAUTL(FBIEN))
DATE ;select date range
+1 DO DATE^FBAAUTL
IF FBPOP
if FBSORT
GOTO GETVET
GOTO GETVEN
+2 SET FBBDATE=BEGDATE
SET FBEDATE=ENDDATE
+3 SET Z=9999999.9999
SET FBBEG=Z-FBEDATE
SET FBEND=Z-FBBDATE
PROG ;select one/many/all fee programs
+1 IF '$GET(FBCHK)
SET DIC="^FBAA(161.8,"
SET DIC("S")="I $P(^(0),U,3)"
SET VAUTSTR="FEE Program"
SET VAUTNI=2
SET VAUTVB="FBPROG"
DO FIRST^VAUTOMA
IF 'FBPROG&('$ORDER(FBPROG(0)))
if FBSORT
GOTO GETVET
GOTO GETVEN
+2 IF FBPROG
SET FBERR=0
DO ARRAY
if FBERR
GOTO EXIT
ASKMB ; if outpatient or civil hospital or pharmacy selected then ask if
+1 ; report for just mill-bill (1725) or just non-mill bill claims
+2 IF $DATA(FBPROG(2))!$DATA(FBPROG(3))!$DATA(FBPROG(6))
SET FB1725R=$$ASKMB^FBUCUTL9
IF FB1725R=""
GOTO EXIT
Q KILL ^TMP($JOB,"FB"),^TMP($JOB,"FBTR"),DIC
SET FBX=FBSORT
+1 SET VAR="FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPROG^FBPROG(^FBSORT^FB1725R"
SET VAL=VAR
SET PGM="DQ^FBPAY"
DO ZIS^FBAAUTL
if FBPOP
GOTO EXIT
DQ SET $PIECE(FBDASH,"=",80)=""
SET $PIECE(FBDASH1,"-",80)=""
SET FBPG=0
SET FBCRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
SET FBOUT=0
SET FBBEG=FBBEG-.9
USE IO
SORT ;sort driver for payment output(s)
+1 SET FBPI=0
FOR
SET FBPI=$ORDER(FBPROG(FBPI))
if 'FBPI
QUIT
SET FBXPROG=FBPROG(FBPI)
Begin DoDot:1
+2 ;outpatient payments
IF FBPI=2
DO EN^FBPAY2
+3 ;pharmacy payments
IF FBPI=3
DO EN^FBPAY3
+4 ;civil hospital/cnh payments
IF FBPI=6!(FBPI=7)
if FBPI=6&$DATA(FBPROG(7))
SET FBPIFLG=67
DO EN^FBPAY67
if $DATA(FBPIFLG)
SET FBPI=7
KILL FBPIFLG
End DoDot:1
PRINT ;print driver for payment output(s)
+1 SET FBPI=$ORDER(^TMP($JOB,"FB",0))
IF FBPI']""
DO WMSG
GOTO OUT
+2 SET (FBOUT,FBPI)=0
FOR
SET FBPI=$ORDER(FBPROG(FBPI))
if 'FBPI
QUIT
SET FBXPROG=FBPROG(FBPI)
Begin DoDot:1
+3 IF FBPI=2
IF $DATA(^TMP($JOB,"FB",FBPI))
DO PRINT^FBPAY21
if $GET(FBOUT)
QUIT
if $DATA(^TMP($JOB,"FB",FBPI_"O"))
DO OTH
QUIT
+4 IF FBPI=3
if $DATA(^TMP($JOB,"FB",FBPI))
DO PRINT^FBPAY3
if $GET(FBOUT)
QUIT
if $DATA(^TMP($JOB,"FB",FBPI_"O"))
DO OTH
QUIT
+5 IF FBPI=6!(FBPI=7)
if $DATA(^TMP($JOB,"FB",FBPI))
DO PRINT^FBPAY671
if $GET(FBOUT)
QUIT
if $DATA(^TMP($JOB,"FB",FBPI_"O"))
DO OTH
QUIT
End DoDot:1
if FBOUT
QUIT
OUT IF FBOUT!$DATA(ZTQUEUED)
GOTO EXIT
+1 DO KILL
if FBX
GOTO GETVET
GOTO GETVEN
+2 QUIT
EXIT ;kill and quit
+1 KILL FBX
KILL ;kill all variables set in the FBPAY* routines, other than fbx
+1 DO CLOSE^FBAAUTL
KILL ^TMP($JOB,"FB"),^TMP($JOB,"FBTR")
+2 KILL A1,A2,A3,BEGDATE,B3,C,C3,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE
+3 KILL FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD,FBMOD
+4 KILL FBI,FBID,FBIEN,FBIN,FBINVN,FBIX,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIFLG,FBPIN,FBPISV,FBPNAME,FBPROG,FBPT,FBPV,FBQTY,FBREIM,FBR,FBRX,FBTRCK
+5 KILL FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,TAMT,FBRRMKL,FBADJ,FBINV
+6 KILL FBSC,FBSL,FBSORT,FBSTR,FBSUSP,FBTA,FBTRDT,FBTRX,FBTYPE,FBV,FBVCHAIN,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,J,K,L,M,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z
+7 KILL FB1725R
+8 QUIT
ARRAY ;set array if all programs are selected
+1 SET FBPI=0
FOR
SET FBPI=$ORDER(^FBAA(161.8,FBPI))
if 'FBPI
QUIT
SET FBPIN=$GET(^(FBPI,0))
IF $PIECE(FBPIN,U,3)
SET FBPROG(FBPI)=$PIECE(FBPIN,U)
+2 IF '$DATA(FBPROG)
SET FBERR=1
+3 QUIT
WMSG ;write message if no matches found
+1 SET FBPG=FBPG+1
if $GET(FBCRT)
WRITE @IOF
WRITE !
+2 WRITE !?25,$SELECT($GET(FBSORT):"VETERAN",1:"VENDOR")," PAYMENT HISTORY"
+3 IF $GET(FB1725R)]""
IF FB1725R'="A"
WRITE " ",$SELECT(FB1725R="M":"for 38 U.S.C. 1725 Claims",1:"excluding 38 U.S.C. 1725 Claims")
+4 WRITE !?24,$EXTRACT(FBDASH,1,24),?71,"Page: ",FBPG
+5 IF FBSORT
WRITE !,"Patient: ",FBNAME,?41,"Patient ID:",FBID
+6 IF 'FBSORT
WRITE !,"Vendor: ",FBNAME,?41,"Vendor ID:",FBID
+7 ;W !?(IOM-12/2),"FEE PROGRAM:"
+8 WRITE !?3,"('*' Reimb. to Patient '+' Cancel. Activity '#' Voided Payment)"
+9 WRITE !!!,FBDASH
+10 WRITE !!,"There are no payments on file for "_$SELECT(FBSORT:"Veteran",1:"Vendor")_" ",FBNAME,!?3,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE)
+11 IF 'FBPROG
Begin DoDot:1
+12 WRITE !?3,"and selected Fee Program(s):"
+13 SET FBPI=0
FOR
SET FBPI=$ORDER(FBPROG(FBPI))
if 'FBPI
QUIT
WRITE !?30,FBPROG(FBPI)
End DoDot:1
+14 IF FBPROG
WRITE !?3,"and ALL Fee programs"
+15 WRITE ".",*7,!!
+16 QUIT
OTH ;other fee basis programs
+1 IF '$DATA(^TMP($JOB,"FB",FBPI_"O"))
QUIT
+2 SET FBZ=FBPI
SET FBPI=FBPI_"O"
SET FBPROG(FBPI)="**OUTPATIENT** "_FBXPROG
+3 DO PRINT^FBPAY21
+4 KILL FBPROG(FBPI)
SET FBPI=FBZ
KILL FBZ
+5 QUIT
