FBAACO4 ;AISC/CMR-ENTER PAYMENT CONTINUED ;5/11/1999
;;3.5;FEE BASIS;**4**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
S FBJ=0,FBDA=DA
CORRF I $D(^FBAA(161.25,"AF",FBDA)) F S FBJ=$O(^FBAA(161.25,"AF",FBDA,FBJ)) Q:'FBJ S:'$D(FBAR(FBJ)) FBA(FBJ)=""
S FBJ=0 I $D(^FBAA(161.25,FBDA,0)) S FBJ=$P(^(0),"^",6) I $G(FBJ)]"",(FBJ'=FBDA) S:'$D(FBAR(FBJ)) FBA(FBJ)=""
S FBDA=0,FBDA=$O(FBA(FBDA)) Q:'FBDA S FBAR(FBDA)="" K FBA(FBDA) D CORRF
Q
CHK ;Checks for payments against all linked vendors.
S FBDA=DA,FBAAOUT=0
S FBJ=0 F S FBJ=$O(FBAR(FBJ)) Q:'FBJ I $D(^FBAAC(DFN,FBJ,"AD")) S FBAACK1=1,DA=FBJ N FBAADT,FBAACPT,FBMOD D EN1^FBAAVS Q:$G(FBAAOUT) S DIR(0)="E" D ^DIR K DIR Q:'Y
I '$G(FBAACK1) W !!,"Vendor has no prior payments for this patient",!
S DA=FBDA Q
CHK1 ;Checks for valid invoice selected from all linked vendors.
K FBAACK1
I $D(^FBAAC("C",X)) S FBJ=0 F S FBJ=$O(FBAR(FBJ)) Q:'FBJ D K X(1) I $G(FBAACK1) S FBV=FBJ Q
.I '$G(FBCNP) I $D(^FBAAC("C",X,DFN,FBJ)) S FBAACK1=1
.I $G(FBCNP) S X(1)=$O(^FBAAC("C",X,0)) I $D(^FBAAC("C",X,X(1),FBJ)) S FBAACK1=1
I '$G(FBAACK1) W !,*7,"That number not valid for this vendor!"
Q
CHK2 ;Checks for duplicate payments on all linked vendors.
N FBMODL
S FBMODL=$$MODL^FBAAUTL4("FBMODA","I")
I $D(^FBAAC("AE",DFN,FBV,FBAADT,FBAACP_$S($G(FBMODL)]"":"-"_FBMODL,1:""))) S FBJ=FBV Q
S FBJ=0 F S FBJ=$O(FBAR(FBJ)) Q:$S('FBJ:1,$D(^FBAAC("AE",DFN,FBJ,FBAADT,FBAACP_$S($G(FBMODL)]"":"-"_FBMODL,1:""))):1,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACO4 1529 printed Sep 23, 2025@19:31:17 Page 2
FBAACO4 ;AISC/CMR-ENTER PAYMENT CONTINUED ;5/11/1999
+1 ;;3.5;FEE BASIS;**4**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET FBJ=0
SET FBDA=DA
CORRF IF $DATA(^FBAA(161.25,"AF",FBDA))
FOR
SET FBJ=$ORDER(^FBAA(161.25,"AF",FBDA,FBJ))
if 'FBJ
QUIT
if '$DATA(FBAR(FBJ))
SET FBA(FBJ)=""
+1 SET FBJ=0
IF $DATA(^FBAA(161.25,FBDA,0))
SET FBJ=$PIECE(^(0),"^",6)
IF $GET(FBJ)]""
IF (FBJ'=FBDA)
if '$DATA(FBAR(FBJ))
SET FBA(FBJ)=""
+2 SET FBDA=0
SET FBDA=$ORDER(FBA(FBDA))
if 'FBDA
QUIT
SET FBAR(FBDA)=""
KILL FBA(FBDA)
DO CORRF
+3 QUIT
CHK ;Checks for payments against all linked vendors.
+1 SET FBDA=DA
SET FBAAOUT=0
+2 SET FBJ=0
FOR
SET FBJ=$ORDER(FBAR(FBJ))
if 'FBJ
QUIT
IF $DATA(^FBAAC(DFN,FBJ,"AD"))
SET FBAACK1=1
SET DA=FBJ
NEW FBAADT,FBAACPT,FBMOD
DO EN1^FBAAVS
if $GET(FBAAOUT)
QUIT
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
QUIT
+3 IF '$GET(FBAACK1)
WRITE !!,"Vendor has no prior payments for this patient",!
+4 SET DA=FBDA
QUIT
CHK1 ;Checks for valid invoice selected from all linked vendors.
+1 KILL FBAACK1
+2 IF $DATA(^FBAAC("C",X))
SET FBJ=0
FOR
SET FBJ=$ORDER(FBAR(FBJ))
if 'FBJ
QUIT
Begin DoDot:1
+3 IF '$GET(FBCNP)
IF $DATA(^FBAAC("C",X,DFN,FBJ))
SET FBAACK1=1
+4 IF $GET(FBCNP)
SET X(1)=$ORDER(^FBAAC("C",X,0))
IF $DATA(^FBAAC("C",X,X(1),FBJ))
SET FBAACK1=1
End DoDot:1
KILL X(1)
IF $GET(FBAACK1)
SET FBV=FBJ
QUIT
+5 IF '$GET(FBAACK1)
WRITE !,*7,"That number not valid for this vendor!"
+6 QUIT
CHK2 ;Checks for duplicate payments on all linked vendors.
+1 NEW FBMODL
+2 SET FBMODL=$$MODL^FBAAUTL4("FBMODA","I")
+3 IF $DATA(^FBAAC("AE",DFN,FBV,FBAADT,FBAACP_$SELECT($GET(FBMODL)]"":"-"_FBMODL,1:"")))
SET FBJ=FBV
QUIT
+4 SET FBJ=0
FOR
SET FBJ=$ORDER(FBAR(FBJ))
if $SELECT('FBJ
QUIT
+5 QUIT
