- 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 Jan 18, 2025@02:56:25 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