FBAACO4.m

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 ---FBAACO4   1529     printed  Apr 09, 2024@21:06:39                                                                                                                                                                                                     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