Routine: FBUCPAY

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

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)

WRITE ;write message

 W !?5,FBMESS

CR ;ask carriage return to continue

 S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) S FBOUT=1

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  Mar 13, 2025@21:05:18                                                                                                                                                                                                     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)

FBUCPAY.m