FBUCPAY ;ALBISC/TET - PAYMENT DRIVER ;12/17/2014
;;3.5;FEE BASIS;**7,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
ASK ;ask to whom payment should be made, vendor and veteran (to narrow selection)
S DIR(0)="SMO^1:PATIENT;2:VENDOR",DIR("A")="Select to whom payment should be made" D ^DIR K DIR G END:$D(DIRUT),ASK:'+Y!($G(Y(0))']"")
S FBPAY=+Y ;1 for patient, 2 for vendor
GET ;get claim for payment, only approved dispositioned claims, non cnh program, ven and vet must match
K FBVEN,FBVET
VET ;get vet info
S DIR(0)="162.7,2O",DIR("A")="Select VETERAN" D ^DIR K DIR G END:$D(DIRUT),VET:+Y'>0 S FBVET=+Y
VEN ;get vendor info
S DIR(0)="162.7,1O",DIR("A")="Select FEE VENDOR" D ^DIR K DIR G END:$D(DUOUT)!($D(DTOUT)),VEN:+Y'>0 S FBVEN=+Y
LOOKUP ;select claim
S FBIX="APMS",FBIEN=FBVET,FBO="40^70^90^" D DISP7^FBUCUTL5(FBIX,FBIEN,FBO) ;lookup by patient, dispostioned claim only
;delete entries from array which don't meet criteria: program=7(cnh), vendor'=fbven, disposition not approved or approved to stabilization
S (FBCNT,FBI)=0 F S FBI=$O(^TMP("FBAR",$J,FBI)) Q:'FBI S FBZ=$G(^FB583(+^(FBI),0)) D
.I $S($P(FBZ,U,2)=7:1,$P(FBZ,U,3)'=FBVEN:1,$P(FBZ,U,11)'=1&($P(FBZ,U,11)'=4):1,1:0) D:$$GO(FBI) K ^TMP("FBAR",$J,FBI) S $P(^("FBAR"),";")=+^TMP("FBAR",$J,"FBAR")-1 Q
..S FBZ=$P(^(FBI+1),";")_"; "_$$EXTRL^FBMRASVR($P($P(^(FBI),U),";",2))_U_$P($P(^(FBI+1),U),";",2)_U_$P(^(FBI),U,3,8),$P(FBZ,U,7)=" "_$$EXTRL^FBMRASVR($P(FBZ,U,7)),^TMP("FBAR",$J,FBI+1)=FBZ K FBZ
.S FBCNT=FBCNT+1 I FBI'=FBCNT S ^TMP("FBAR",$J,FBCNT)=^TMP("FBAR",$J,FBI) K ^TMP("FBAR",$J,FBI)
D DISPX^FBUCUTL1(1,1) ;display/make selection
K ^TMP("FBAR",$J) G END:FBOUT!('+$G(FBARY)) ;nothing selected so go to end
LOOP ;loop thru selection and make payments
N FBDA,FBI,FBNODE,FBP,FBPL,FBW,FBZ D PARSE^FBUCUTL4(FBARY)
S (FBOUT,FBI)=0 F S FBI=$O(^TMP("FBARY",$J,FBI)) Q:'FBI S FBNODE=$G(^(FBI)),FBDA=+$P(FBNODE,";"),FBZ=$G(^FB583(FBDA,0)) D ;D:$D(FBMESS) WRITE G END:FBOUT,ASK
.I +$G(FBARY)>1 D LINE^FBUCUTL4(FBNODE,FBI,FBPL,FBW)
.N FBI,FTP,DUOUT,DTOUT S FBOUT=0 D PAY(FBVET,FBPAY,FBZ)
D END G ASK
;
PAY(FBVET,FBPAY,FBZ) ;determine payments
I '($P(FBZ,U,11)=1!($P(FBZ,U,11)=4)) W *7 S FBMESS="Unauthorized claim must be Approved or Approved to Stabilization" D WRITE S FBMESS=" in order to make a payment." D WRITE S FBOUT=1 Q
S (DFN,D0)=FBVET,FBPROG(1)=+$P(FBZ,U,2),FBSUBMIT=$P(FBZ,U,23),FBAAPTC=$S(FBPAY=2:"V",1:"R"),FBAIEN=+$P(FBZ,U,27) ;,FBAAPTC=$S(FBSUBMIT["DPT(":"R",FBSUBMIT["FBAAV(":"V",FBSUBMIT["VA(200,":"O",1:0)
I FBPROG(1)=7 W *7,! S FBMESS="Fee program is community nursing home." D WRITE S FBMESS="Payments should not be authorized." D WRITE S FBOUT=1 Q
I FBPROG(1)=6 S DIR(0)="YO",DIR("A")="Is this an ancillary payment",DIR("B")="No" D ^DIR K DIR S:$D(DIRUT) FBOUT=1 Q:$G(FBOUT) S FBANC=+Y
S FBPROG="I $P(^(0),""^"",9)[""FB583(""&($P(^(0),""^"",3)="_FBPROG(1)_")"
S X=FBAIEN,CNT=X,CNT(CNT)=X D 2^FBAAUTL1 I $D(DUOUT)!(FTP']"") S FBOUT=1 Q
;
; enforce separation of duties
I '$$UOKPAY^FBUTL9(DFN,FTP) D S FBOUT=1 Q
. W !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
. W !,"due to separation of duties."
;
I 'FBAIEN W *7 S FBMESS="No authorization associated with this 583!" D WRITE S FBOUT=1 Q
;I FB583'=FBDA W *7 S FBMESS="Authorization does not pertain to the selected unauthorized claim." D WRITE S FBOUT=1 Q
I FBTYPE'=FBPROG(1) W *7 S FBMESS="Authorization Fee program differs from Fee program in Unauthorized Claim." D WRITE S FBOUT=1 Q
S FBV583=FB583_";FB583("
D CR Q:FBOUT
D HOME^%ZIS W @IOF,!?25,"< UNAUTHORIZED CLAIM >",!! S DIC="^FB583(",DA=FB583,DR="0:LOG",DIQ(0)="C" D EN^DIQ W ! K DIC,DIQ,DR,DA,CNT,X
D CR Q:FBOUT
D ;G 2:FBPROG(1)=2,3:FBPROG(1)=3,6:FBPROG(1)=6,7:FBPROG(1)=7
.;payment for outpatinet
.I FBPROG(1)=2 D EN583^FBAACO Q
.;payments for pharmacy
.I FBPROG(1)=3 D ^FBAAPIE Q
.;payments for civil hospital
.I FBPROG(1)=6 S FBI7078=FB583_";FB583(",$P(FBZ(0),"^",4)=$P(FBZ,U,5),FBRESUB="" D EN583^FBCHEP:'FBANC,EN583^FBCHCO:FBANC Q
.;payments for community nursing home
.I FBPROG(1)=7 W *7,! S FBMESS="Fee program is community nursing home." D WRITE S FBMESS="Payments should not be authorized." D WRITE
Q
END ;kill variables and quit
K FB,FBAABDT,FBAAEDT,FBAAOUT,FBAAPTC,FBAIEN,FBANC,FBASSOC,FBARY,FBCNT,FBDA,FBD1,FBFDC,FBI,FBIEN,FBIX,FBI7078,FBMST,FBO,FBOUT
K FBRESUB,FBTTYPE,FBDMRA,FBMESS,FBPAY,FBPOV,FBPSA,FBPROG,FBPT,FBSUBMIT,FBTP,FBTT,FBTYPE,FBVEN,FBVET,FBV583,FBZ,FB583,FB7078,FTP
K CNT,DFN,D0,DTOUT,DUOUT,DIC,DIR,DIRUT,DTOUT,DUOUT,TA,X,Y,^TMP("FBARY",$J)
Q
WRITE ;write message
W !?5,FBMESS
Q
CR ;ask carriage return to continue
S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) S FBOUT=1
Q
;
GO(X) ;X=counter from ^TMP("FBAR",$J,X)
I '$G(X) Q 0
Q $S($P($G(^TMP("FBAR",$J,X)),U,3,8)']"":0,'$G(^TMP("FBAR",$J,X+1)):0,$P($G(^TMP("FBAR",$J,X+1)),U,3,8)]"":0,1:1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCPAY 4984 printed Sep 23, 2025@19:36:30 Page 2
FBUCPAY ;ALBISC/TET - PAYMENT DRIVER ;12/17/2014
+1 ;;3.5;FEE BASIS;**7,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
ASK ;ask to whom payment should be made, vendor and veteran (to narrow selection)
+1 SET DIR(0)="SMO^1:PATIENT;2:VENDOR"
SET DIR("A")="Select to whom payment should be made"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
if '+Y!($GET(Y(0))']"")
GOTO ASK
+2 ;1 for patient, 2 for vendor
SET FBPAY=+Y
GET ;get claim for payment, only approved dispositioned claims, non cnh program, ven and vet must match
+1 KILL FBVEN,FBVET
VET ;get vet info
+1 SET DIR(0)="162.7,2O"
SET DIR("A")="Select VETERAN"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
if +Y'>0
GOTO VET
SET FBVET=+Y
VEN ;get vendor info
+1 SET DIR(0)="162.7,1O"
SET DIR("A")="Select FEE VENDOR"
DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
if +Y'>0
GOTO VEN
SET FBVEN=+Y
LOOKUP ;select claim
+1 ;lookup by patient, dispostioned claim only
SET FBIX="APMS"
SET FBIEN=FBVET
SET FBO="40^70^90^"
DO DISP7^FBUCUTL5(FBIX,FBIEN,FBO)
+2 ;delete entries from array which don't meet criteria: program=7(cnh), vendor'=fbven, disposition not approved or approved to stabilization
+3 SET (FBCNT,FBI)=0
FOR
SET FBI=$ORDER(^TMP("FBAR",$JOB,FBI))
if 'FBI
QUIT
SET FBZ=$GET(^FB583(+^(FBI),0))
Begin DoDot:1
+4 IF $SELECT($PIECE(FBZ,U,2)=7:1,$PIECE(FBZ,U,3)'=FBVEN:1,$PIECE(FBZ,U,11)'=1&($PIECE(FBZ,U,11)'=4):1,1:0)
if $$GO(FBI)
Begin DoDot:2
+5 SET FBZ=$PIECE(^(FBI+1),";")_"; "_$$EXTRL^FBMRASVR($PIECE($PIECE(^(FBI),U),";",2))_U_$PIECE($PIECE(^(FBI+1),U),";",2)_U_$PIECE(^(FBI),U,3,8)
SET $PIECE(FBZ,U,7)=" "_$$EXTRL^FBMRASVR($PIECE(FBZ,U,7))
SET ^TMP("FBAR",$JOB,FBI+1)=FBZ
KILL FBZ
End DoDot:2
KILL ^TMP("FBAR",$JOB,FBI)
SET $PIECE(^("FBAR"),";")=+^TMP("FBAR",$JOB,"FBAR")-1
QUIT
+6 SET FBCNT=FBCNT+1
IF FBI'=FBCNT
SET ^TMP("FBAR",$JOB,FBCNT)=^TMP("FBAR",$JOB,FBI)
KILL ^TMP("FBAR",$JOB,FBI)
End DoDot:1
+7 ;display/make selection
DO DISPX^FBUCUTL1(1,1)
+8 ;nothing selected so go to end
KILL ^TMP("FBAR",$JOB)
if FBOUT!('+$GET(FBARY))
GOTO END
LOOP ;loop thru selection and make payments
+1 NEW FBDA,FBI,FBNODE,FBP,FBPL,FBW,FBZ
DO PARSE^FBUCUTL4(FBARY)
+2 ;D:$D(FBMESS) WRITE G END:FBOUT,ASK
SET (FBOUT,FBI)=0
FOR
SET FBI=$ORDER(^TMP("FBARY",$JOB,FBI))
if 'FBI
QUIT
SET FBNODE=$GET(^(FBI))
SET FBDA=+$PIECE(FBNODE,";")
SET FBZ=$GET(^FB583(FBDA,0))
Begin DoDot:1
+3 IF +$GET(FBARY)>1
DO LINE^FBUCUTL4(FBNODE,FBI,FBPL,FBW)
+4 NEW FBI,FTP,DUOUT,DTOUT
SET FBOUT=0
DO PAY(FBVET,FBPAY,FBZ)
End DoDot:1
+5 DO END
GOTO ASK
+6 ;
PAY(FBVET,FBPAY,FBZ) ;determine payments
+1 IF '($PIECE(FBZ,U,11)=1!($PIECE(FBZ,U,11)=4))
WRITE *7
SET FBMESS="Unauthorized claim must be Approved or Approved to Stabilization"
DO WRITE
SET FBMESS=" in order to make a payment."
DO WRITE
SET FBOUT=1
QUIT
+2 ;,FBAAPTC=$S(FBSUBMIT["DPT(":"R",FBSUBMIT["FBAAV(":"V",FBSUBMIT["VA(200,":"O",1:0)
SET (DFN,D0)=FBVET
SET FBPROG(1)=+$PIECE(FBZ,U,2)
SET FBSUBMIT=$PIECE(FBZ,U,23)
SET FBAAPTC=$SELECT(FBPAY=2:"V",1:"R")
SET FBAIEN=+$PIECE(FBZ,U,27)
+3 IF FBPROG(1)=7
WRITE *7,!
SET FBMESS="Fee program is community nursing home."
DO WRITE
SET FBMESS="Payments should not be authorized."
DO WRITE
SET FBOUT=1
QUIT
+4 IF FBPROG(1)=6
SET DIR(0)="YO"
SET DIR("A")="Is this an ancillary payment"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET FBOUT=1
if $GET(FBOUT)
QUIT
SET FBANC=+Y
+5 SET FBPROG="I $P(^(0),""^"",9)[""FB583(""&($P(^(0),""^"",3)="_FBPROG(1)_")"
+6 SET X=FBAIEN
SET CNT=X
SET CNT(CNT)=X
DO 2^FBAAUTL1
IF $DATA(DUOUT)!(FTP']"")
SET FBOUT=1
QUIT
+7 ;
+8 ; enforce separation of duties
+9 IF '$$UOKPAY^FBUTL9(DFN,FTP)
Begin DoDot:1
+10 WRITE !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
+11 WRITE !,"due to separation of duties."
End DoDot:1
SET FBOUT=1
QUIT
+12 ;
+13 IF 'FBAIEN
WRITE *7
SET FBMESS="No authorization associated with this 583!"
DO WRITE
SET FBOUT=1
QUIT
+14 ;I FB583'=FBDA W *7 S FBMESS="Authorization does not pertain to the selected unauthorized claim." D WRITE S FBOUT=1 Q
+15 IF FBTYPE'=FBPROG(1)
WRITE *7
SET FBMESS="Authorization Fee program differs from Fee program in Unauthorized Claim."
DO WRITE
SET FBOUT=1
QUIT
+16 SET FBV583=FB583_";FB583("
+17 DO CR
if FBOUT
QUIT
+18 DO HOME^%ZIS
WRITE @IOF,!?25,"< UNAUTHORIZED CLAIM >",!!
SET DIC="^FB583("
SET DA=FB583
SET DR="0:LOG"
SET DIQ(0)="C"
DO EN^DIQ
WRITE !
KILL DIC,DIQ,DR,DA,CNT,X
+19 DO CR
if FBOUT
QUIT
+20 ;G 2:FBPROG(1)=2,3:FBPROG(1)=3,6:FBPROG(1)=6,7:FBPROG(1)=7
Begin DoDot:1
+21 ;payment for outpatinet
+22 IF FBPROG(1)=2
DO EN583^FBAACO
QUIT
+23 ;payments for pharmacy
+24 IF FBPROG(1)=3
DO ^FBAAPIE
QUIT
+25 ;payments for civil hospital
+26 IF FBPROG(1)=6
SET FBI7078=FB583_";FB583("
SET $PIECE(FBZ(0),"^",4)=$PIECE(FBZ,U,5)
SET FBRESUB=""
if 'FBANC
DO EN583^FBCHEP
if FBANC
DO EN583^FBCHCO
QUIT
+27 ;payments for community nursing home
+28 IF FBPROG(1)=7
WRITE *7,!
SET FBMESS="Fee program is community nursing home."
DO WRITE
SET FBMESS="Payments should not be authorized."
DO WRITE
End DoDot:1
+29 QUIT
END ;kill variables and quit
+1 KILL FB,FBAABDT,FBAAEDT,FBAAOUT,FBAAPTC,FBAIEN,FBANC,FBASSOC,FBARY,FBCNT,FBDA,FBD1,FBFDC,FBI,FBIEN,FBIX,FBI7078,FBMST,FBO,FBOUT
+2 KILL FBRESUB,FBTTYPE,FBDMRA,FBMESS,FBPAY,FBPOV,FBPSA,FBPROG,FBPT,FBSUBMIT,FBTP,FBTT,FBTYPE,FBVEN,FBVET,FBV583,FBZ,FB583,FB7078,FTP
+3 KILL CNT,DFN,D0,DTOUT,DUOUT,DIC,DIR,DIRUT,DTOUT,DUOUT,TA,X,Y,^TMP("FBARY",$JOB)
+4 QUIT
WRITE ;write message
+1 WRITE !?5,FBMESS
+2 QUIT
CR ;ask carriage return to continue
+1 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET FBOUT=1
+2 QUIT
+3 ;
GO(X) ;X=counter from ^TMP("FBAR",$J,X)
+1 IF '$GET(X)
QUIT 0
+2 QUIT $SELECT($PIECE($GET(^TMP("FBAR",$JOB,X)),U,3,8)']"":0,'$GET(^TMP("FBAR",$JOB,X+1)):0,$PIECE($GET(^TMP("FBAR",$JOB,X+1)),U,3,8)]"":0,1:1)
