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^")=""
D
. 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
Q
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
Q
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)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHEAP 4165 printed Dec 13, 2024@01:57:40 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
