Routine: FBCHEAP

FBCHEAP ;AISC/DMK - ENTER AMOUNT PAID FROM PRICER ;10/1/2014

 ;;3.5;FEE BASIS;**38,55,61,77,154,158**;JAN 30, 1995;Build 94

 ;;Per VA Directive 6402, this routine should not be modified.

DIC W ! S DIC="^FBAA(161.7,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,15)=""Y""&($G(^(""ST""))=""P"")"_$S($D(^XUSEC("FBAA LEVEL 2",DUZ)):"",1:"&($P(^(0),U,5)=DUZ)") D ^DIC

 G END:X="^"!(X=""),DIC:Y<0 S FBN=+Y,FBN(0)=Y(0)

ASK S DIR(0)="Y",DIR("A")="Would you like to reject any invoices from the pricer",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT),REJECT:Y

DIC1 W !! S DIC="^FBAAI(",DIC(0)="AEQMZ",DIC("A")="Select Patient: ",D="D",DIC("S")="I $P(^(0),U,17)=FBN",DIC("W")="W ?25,$S($D(^DPT($P(^(0),U,4),0)):$P(^(0),U),1:"""")" D ^DIC S DIE=DIC K DIC,D G END:X="^",DIC:X=""!(Y<0)

 S (DA,FBI)=+Y,FBI(0)=Y(0) G END:'$D(^FBAAI(FBI,0))

DISP S FBLISTC="" D HOME^%ZIS,START^FBCHDI2

 W !!

 ;enforce separation of duties

 S FBDFN=$P(FBI(0),U,4)

 S FB7078I=$P(FBI(0),U,5)

 S FTP=$S(FB7078I]"":$O(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")

 I FBDFN,FTP,'$$UOKPAY^FBUTL9(FBDFN,FTP) D  G DIC1

 . W "You cannot process a payment associated with authorization ",FBDFN,"-",FTP

 . W !,"due to separation of duties."

 S FBJ=$P(FBI(0),"^",8)

 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim

 S FB1725=$S($P(FBI(0),U,5)["FB583":+$P($G(^FB583(+$P(FBI(0),U,5),0)),U,28),1:0)

 S DR="26;S FBPAMT=X;W:FB1725 !?2,""**Payment is for emergency treatment under 38 U.S.C. 1725."";W:FB1725&($G(FBPAMT)>0) !?2,""  70% of Pricer Amount = ""_$J(.7*FBPAMT,0,2);8;S FBK=X"

 ;S DR(1,162.5,1)="S:(FBJ-FBK)'>0 Y=24;9//^S X=$S(FBJ-FBK:FBJ-FBK,1:"""");S:'X Y=24;10;S:X'=4 Y=24;18"

 S DR(1,162.5,1)="S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,5,,,1,.FBRRMK,1)"

 S DR(1,162.5,2)="@20;24R;S:$$INPICD^FBCSV1(X,$G(DA),$P($G(FBIN),""^"",6)) Y=""@20"";24.5R"

 S DIE("NO^")=""

 . N ICDVDT S ICDVDT=$P($G(FBIN),"^",6) D ^DIE

 K DIE("NO^") G END:$D(DTOUT)

 ; file adjustment reasons

 D FILEADJ^FBCHFA(FBI_",",.FBADJ)

 ; file remittance remarks

 D FILERR^FBCHFR(FBI_",",.FBRRMK)

 D TOT S $P(FBN(0),"^",9)=FBK(1),^FBAA(161.7,FBN,0)=FBN(0)

 D CHK I $D(FBCHSW) K FBCHSW G DIC1

 I '$D(FBCHSW) S DA=FBN,(DIC,DIE)="^FBAA(161.7,",DIC(0)="LQ",DR="11////^S X=""A""",DLAYGO=161.7 D ^DIE G DIC

 G DIC1:$O(^FBAAI("AC",FBN,FBI))

END K DA,DFN,DIC,DIE,DR,FBAAOUT,FBDX,FBI,FBIN,FBJ,FBK,FBLISTC,FBN,FBPROC,FBVEN,FBVID,I,J,K,L,POP,Q,VA,VADM,X,POP,YS,VAL,ZZ,Y,FBRR,FBTYPE,FBCHSW,DIRUT,FB1725,FBPAMT

 K FBADJ,FBRRMK,FBDFN,FB7078I,FTP

 D END^FBCHDI

REJECT S FBTYPE="B9"

 W ! S DIC="^FBAAI(",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,17)=FBN&($P(^(0),U,9)="""")",DIC("W")="W ?25,$S($D(^DPT($P(^(0),U,4),0)):$P(^(0),U),1:"""")" D ^DIC G END:X=""!(X="^"),REJECT:Y<0 S FBI=+Y,FBI(0)=Y(0)

 S FBLISTC="" D HOME^%ZIS,START^FBCHDI2

 ;enforce separation of duties

 S FBDFN=$P(FBI(0),U,4)

 S FB7078I=$P(FBI(0),U,5)

 S FTP=$S(FB7078I]"":$O(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")

 I FBDFN,FTP,'$$UOKPAY^FBUTL9(FBDFN,FTP) D  G REJECT

 . W !,"You cannot process a payment associated with authorization ",FBDFN,"-",FTP

 . W !,"due to separation of duties."

RASK S DIR(0)="F^2:40",DIR("A")="Enter reason for rejecting (2-40 characters)",DIR("?")="Enter a reason for rejecting payment from Austin Pricer" D ^DIR K DIR G END:$D(DIRUT) S FBRR=X

ASKSU S DIR(0)="Y",DIR("A")="Are you sure you want to reject this item",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT),DIC:'Y

 S (DLAYGO,DIDEL)=162.5,DIC(0)="AEQLM"

 S (DIC,DIE)="^FBAAI(",DA=FBI,DR="13////^S X=""P"";14////^S X=FBRR;15////^S X=FBN;20///^S X=""@""" D ^DIE

 S $P(FBN(0),"^",10)=$P(FBN(0),"^",10)-1,$P(FBN(0),"^",11)=$P(FBN(0),"^",11)-1,$P(FBN(0),"^",17)="Y",^FBAA(161.7,FBN,0)=FBN(0)

RASKSU I $O(^FBAAI("AC",FBN,FBI)) S DIR(0)="Y",DIR("A")="Reject another",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT),REJECT:Y

 I $P(^FBAA(161.7,FBN,0),"^",11)=0 S (DIC,DIE)="^FBAA(161.7,",DIC(0)="AEQM",DA=FBN,DR="11////^S X=""V"";12////^S X=DT" D ^DIE G DIC

 G END

CHK F I=0:0 S I=$O(^FBAAI("AC",FBN,I)) Q:I'>0  I $D(^FBAAI(I,0)),$P(^(0),"^",9)="" S FBCHSW=1

TOT S FBK(1)=0 F I=0:0 S I=$O(^FBAAI("AC",FBN,I)) Q:'I  S FBK(1)=FBK(1)+$P($G(^FBAAI(I,0)),"^",9)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHEAP   4165     printed  Feb 18, 2025@23:24:06                                                                                                                                                                                                     Page 2

FBCHEAP   ;AISC/DMK - ENTER AMOUNT PAID FROM PRICER ;10/1/2014

 +1       ;;3.5;FEE BASIS;**38,55,61,77,154,158**;JAN 30, 1995;Build 94

 +2       ;;Per VA Directive 6402, this routine should not be modified.

DIC        WRITE !

           SET DIC="^FBAA(161.7,"

           SET DIC(0)="AEQMZ"

           SET DIC("S")="I $P(^(0),U,15)=""Y""&($G(^(""ST""))=""P"")"_$SELECT($DATA(^XUSEC("FBAA LEVEL 2",DUZ)):"",1:"&($P(^(0),U,5)=DUZ)")

           DO ^DIC

 +1        if X="^"!(X="")

               GOTO END

           if Y<0

               GOTO DIC

           SET FBN=+Y

           SET FBN(0)=Y(0)

ASK        SET DIR(0)="Y"

           SET DIR("A")="Would you like to reject any invoices from the pricer"

           SET DIR("B")="NO"

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO END

           if Y

               GOTO REJECT

DIC1       WRITE !!

           SET DIC="^FBAAI("

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select Patient: "

           SET D="D"

           SET DIC("S")="I $P(^(0),U,17)=FBN"

           SET DIC("W")="W ?25,$S($D(^DPT($P(^(0),U,4),0)):$P(^(0),U),1:"""")"

           DO ^DIC

           SET DIE=DIC

           KILL DIC,D

           if X="^"

               GOTO END

           if X=""!(Y<0)

               GOTO DIC

 +1        SET (DA,FBI)=+Y

           SET FBI(0)=Y(0)

           if '$DATA(^FBAAI(FBI,0))

               GOTO END

DISP       SET FBLISTC=""

           DO HOME^%ZIS

           DO START^FBCHDI2

 +1        WRITE !!

 +2       ;

 +3       ;enforce separation of duties

 +4        SET FBDFN=$PIECE(FBI(0),U,4)

 +5        SET FB7078I=$PIECE(FBI(0),U,5)

 +6        SET FTP=$SELECT(FB7078I]"":$ORDER(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")

 +7        IF FBDFN

               IF FTP

                   IF '$$UOKPAY^FBUTL9(FBDFN,FTP)

                       Begin DoDot:1

 +8                        WRITE "You cannot process a payment associated with authorization ",FBDFN,"-",FTP

 +9                        WRITE !,"due to separation of duties."

                       End DoDot:1

                       GOTO DIC1

 +10      ;

 +11       SET FBJ=$PIECE(FBI(0),"^",8)

 +12      ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim

 +13       SET FB1725=$SELECT($PIECE(FBI(0),U,5)["FB583":+$PIECE($GET(^FB583(+$PIECE(FBI(0),U,5),0)),U,28),1:0)

 +14       SET DR="26;S FBPAMT=X;W:FB1725 !?2,""**Payment is for emergency treatment under 38 U.S.C. 1725."";W:FB1725&($G(FBPAMT)>0) !?2,""  70% of Pricer Amount = ""_$J(.7*FBPAMT,0,2);8;S FBK=X"

 +15      ;S DR(1,162.5,1)="S:(FBJ-FBK)'>0 Y=24;9//^S X=$S(FBJ-FBK:FBJ-FBK,1:"""");S:'X Y=24;10;S:X'=4 Y=24;18"

 +16       SET DR(1,162.5,1)="S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,5,,,1,.FBRRMK,1)"

 +17       SET DR(1,162.5,2)="@20;24R;S:$$INPICD^FBCSV1(X,$G(DA),$P($G(FBIN),""^"",6)) Y=""@20"";24.5R"

 +18       SET DIE("NO^")=""

 +19       Begin DoDot:1

 +20           NEW ICDVDT

               SET ICDVDT=$PIECE($GET(FBIN),"^",6)

               DO ^DIE

           End DoDot:1

 +21       KILL DIE("NO^")

           if $DATA(DTOUT)

               GOTO END

 +22      ; file adjustment reasons

 +23       DO FILEADJ^FBCHFA(FBI_",",.FBADJ)

 +24      ; file remittance remarks

 +25       DO FILERR^FBCHFR(FBI_",",.FBRRMK)

 +26       DO TOT

           SET $PIECE(FBN(0),"^",9)=FBK(1)

           SET ^FBAA(161.7,FBN,0)=FBN(0)

 +27       DO CHK

           IF $DATA(FBCHSW)

               KILL FBCHSW

               GOTO DIC1

 +28       IF '$DATA(FBCHSW)

               SET DA=FBN

               SET (DIC,DIE)="^FBAA(161.7,"

               SET DIC(0)="LQ"

               SET DR="11////^S X=""A"""

               SET DLAYGO=161.7

               DO ^DIE

               GOTO DIC

 +29       if $ORDER(^FBAAI("AC",FBN,FBI))

               GOTO DIC1

END        KILL DA,DFN,DIC,DIE,DR,FBAAOUT,FBDX,FBI,FBIN,FBJ,FBK,FBLISTC,FBN,FBPROC,FBVEN,FBVID,I,J,K,L,POP,Q,VA,VADM,X,POP,YS,VAL,ZZ,Y,FBRR,FBTYPE,FBCHSW,DIRUT,FB1725,FBPAMT

 +1        KILL FBADJ,FBRRMK,FBDFN,FB7078I,FTP

 +2        DO END^FBCHDI

 +3        QUIT

REJECT     SET FBTYPE="B9"

 +1        WRITE !

           SET DIC="^FBAAI("

           SET DIC(0)="AEQMZ"

           SET DIC("S")="I $P(^(0),U,17)=FBN&($P(^(0),U,9)="""")"

           SET DIC("W")="W ?25,$S($D(^DPT($P(^(0),U,4),0)):$P(^(0),U),1:"""")"

           DO ^DIC

           if X=""!(X="^")

               GOTO END

           if Y<0

               GOTO REJECT

           SET FBI=+Y

           SET FBI(0)=Y(0)

 +2        SET FBLISTC=""

           DO HOME^%ZIS

           DO START^FBCHDI2

 +3       ;

 +4       ;enforce separation of duties

 +5        SET FBDFN=$PIECE(FBI(0),U,4)

 +6        SET FB7078I=$PIECE(FBI(0),U,5)

 +7        SET FTP=$SELECT(FB7078I]"":$ORDER(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")

 +8        IF FBDFN

               IF FTP

                   IF '$$UOKPAY^FBUTL9(FBDFN,FTP)

                       Begin DoDot:1

 +9                        WRITE !,"You cannot process a payment associated with authorization ",FBDFN,"-",FTP

 +10                       WRITE !,"due to separation of duties."

                       End DoDot:1

                       GOTO REJECT

 +11      ;

RASK       SET DIR(0)="F^2:40"

           SET DIR("A")="Enter reason for rejecting (2-40 characters)"

           SET DIR("?")="Enter a reason for rejecting payment from Austin Pricer"

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO END

           SET FBRR=X

ASKSU      SET DIR(0)="Y"

           SET DIR("A")="Are you sure you want to reject this item"

           SET DIR("B")="NO"

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO END

           if 'Y

               GOTO DIC

 +1        SET (DLAYGO,DIDEL)=162.5

           SET DIC(0)="AEQLM"

 +2        SET (DIC,DIE)="^FBAAI("

           SET DA=FBI

           SET DR="13////^S X=""P"";14////^S X=FBRR;15////^S X=FBN;20///^S X=""@"""

           DO ^DIE

 +3        SET $PIECE(FBN(0),"^",10)=$PIECE(FBN(0),"^",10)-1

           SET $PIECE(FBN(0),"^",11)=$PIECE(FBN(0),"^",11)-1

           SET $PIECE(FBN(0),"^",17)="Y"

           SET ^FBAA(161.7,FBN,0)=FBN(0)

RASKSU     IF $ORDER(^FBAAI("AC",FBN,FBI))

               SET DIR(0)="Y"

               SET DIR("A")="Reject another"

               SET DIR("B")="NO"

               DO ^DIR

               KILL DIR

               if $DATA(DIRUT)

                   GOTO END

               if Y

                   GOTO REJECT

 +1        IF $PIECE(^FBAA(161.7,FBN,0),"^",11)=0

               SET (DIC,DIE)="^FBAA(161.7,"

               SET DIC(0)="AEQM"

               SET DA=FBN

               SET DR="11////^S X=""V"";12////^S X=DT"

               DO ^DIE

               GOTO DIC

 +2        GOTO END

CHK        FOR I=0:0

               SET I=$ORDER(^FBAAI("AC",FBN,I))

               if I'>0

                   QUIT

               IF $DATA(^FBAAI(I,0))

                   IF $PIECE(^(0),"^",9)=""

                       SET FBCHSW=1

 +1        QUIT

TOT        SET FBK(1)=0

           FOR I=0:0

               SET I=$ORDER(^FBAAI("AC",FBN,I))

               if 'I

                   QUIT

               SET FBK(1)=FBK(1)+$PIECE($GET(^FBAAI(I,0)),"^",9)

 +1        QUIT

FBCHEAP.m