source: FOIAVistA/tag/r/FEE_BASIS-FB/FBPAY.m@ 628

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