FBAARD1 ;AISC/GRR - FEE BASIS VOUCHER AUDIT DELETE REJECT FLAG ;4/17/2012
;;3.5;FEE BASIS;**132**;JAN 30, 1995;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified.
RD S DIR(0)="Y",DIR("A")="Are you sure you want to delete reject code for all locally rejected items in this batch",DIR("B")="NO" D ^DIR K DIR G Q^FBAARD:$D(DIRUT),RD1^FBAARD:'Y
D WAIT^DICD,ALLM:FBTYPE="B3",ALLT:FBTYPE="B2",ALLP:FBTYPE="B5",ALLC:FBTYPE="B9"
G Q^FBAARD:$D(FBERR)
G RDD^FBAARD
ALLM ;
F J=0:0 S J=$O(^FBAAC("AH",B,J)) Q:J'>0!($D(FBERR)) F K=0:0 S K=$O(^FBAAC("AH",B,J,K)) Q:K'>0!($D(FBERR)) F L=0:0 S L=$O(^FBAAC("AH",B,J,K,L)) Q:L'>0!($D(FBERR)) F M=0:0 S M=$O(^FBAAC("AH",B,J,K,L,M)) Q:M'>0!($D(FBERR)) D REJM Q:$D(FBERR)
ADONE ;
W:'$D(FBERR) !!,"Local reject codes for all items have been deleted!"
Q
REJM ;
Q:$P($G(^FBAAC(J,1,K,1,L,1,M,"FBREJ")),"^",4)=1 ; skip interface rej.
S FBAAMT=+$P(^FBAAC(J,1,K,1,L,1,M,0),"^",3)
D POST^FBAARD3 I $D(FBERR) G PROB
S FBX=$$DELREJ^FBAARR3("162.03",M_","_L_","_K_","_J_",")
Q
ALLT ;
F J=0:0 S J=$O(^FBAAC("AG",B,J)) Q:J'>0!($D(FBERR)) F K=0:0 S K=$O(^FBAAC("AG",B,J,K)) Q:K'>0!($D(FBERR)) D REJT Q:$D(FBERR)
G ADONE
REJT ;
Q:$P($G(^FBAAC(J,3,K,"FBREJ")),"^",4)=1 ; skip interface reject
S FBAAMT=$P(^FBAAC(J,3,K,0),"^",3)
D POST^FBAARD3 I $D(FBERR) G PROB
S FBX=$$DELREJ^FBAARR3("162.04",K_","_J_",")
Q
ALLP ;
F J=0:0 S J=$O(^FBAA(162.1,"AF",B,J)) Q:J'>0!($D(FBERR)) F K=0:0 S K=$O(^FBAA(162.1,"AF",B,J,K)) Q:K'>0!($D(FBERR)) D REJP Q:$D(FBERR)
G ADONE
REJP ;
Q:$P($G(^FBAA(162.1,J,"RX",K,"FBREJ")),"^",4)=1 ; skip interface rej.
S FBAAMT=+$P(^FBAA(162.1,J,"RX",K,0),"^",16)
D POST^FBAARD3 I $D(FBERR) G PROB
S FBX=$$DELREJ^FBAARR3("162.11",K_","_J_",")
Q
ALLC ;
F J=0:0 S J=$O(^FBAAI("AH",B,J)) Q:J'>0!($D(FBERR)) I $D(^FBAAI(J,0)) D REJC Q:$D(FBERR)
G ADONE
REJC ;
Q:$P($G(^FBAAI(J,"FBREJ")),"^",4)=1 ; skip interface reject
S FBAAMT=+$P(^FBAAI(J,0),"^",9),FBII78=$P($G(^(0)),"^",5),FBMM=$E($P(^(0),U,6),4,5)
D INPOST^FBAARD3 I $D(FBERR) G PROB
S FBX=$$DELREJ^FBAARR3("162.5",J_",")
K FBMM
Q
PROB W !!,*7,"There is a problem with your 1358. Unable to delete reject flag!",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAARD1 2218 printed Sep 23, 2025@19:32:26 Page 2
FBAARD1 ;AISC/GRR - FEE BASIS VOUCHER AUDIT DELETE REJECT FLAG ;4/17/2012
+1 ;;3.5;FEE BASIS;**132**;JAN 30, 1995;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
RD SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete reject code for all locally rejected items in this batch"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q^FBAARD
if 'Y
GOTO RD1^FBAARD
+1 DO WAIT^DICD
if FBTYPE="B3"
DO ALLM
if FBTYPE="B2"
DO ALLT
if FBTYPE="B5"
DO ALLP
if FBTYPE="B9"
DO ALLC
+2 if $DATA(FBERR)
GOTO Q^FBAARD
+3 GOTO RDD^FBAARD
ALLM ;
+1 FOR J=0:0
SET J=$ORDER(^FBAAC("AH",B,J))
if J'>0!($DATA(FBERR))
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("AH",B,J,K))
if K'>0!($DATA(FBERR))
QUIT
FOR L=0:0
SET L=$ORDER(^FBAAC("AH",B,J,K,L))
if L'>0!($DATA(FBERR))
QUIT
FOR M=0:0
SET M=$ORDER(^FBAAC("AH",B,J,K,L,M))
if M'>0!($DATA(FBERR))
QUIT
DO REJM
if $DATA(FBERR)
QUIT
ADONE ;
+1 if '$DATA(FBERR)
WRITE !!,"Local reject codes for all items have been deleted!"
+2 QUIT
REJM ;
+1 ; skip interface rej.
if $PIECE($GET(^FBAAC(J,1,K,1,L,1,M,"FBREJ")),"^",4)=1
QUIT
+2 SET FBAAMT=+$PIECE(^FBAAC(J,1,K,1,L,1,M,0),"^",3)
+3 DO POST^FBAARD3
IF $DATA(FBERR)
GOTO PROB
+4 SET FBX=$$DELREJ^FBAARR3("162.03",M_","_L_","_K_","_J_",")
+5 QUIT
ALLT ;
+1 FOR J=0:0
SET J=$ORDER(^FBAAC("AG",B,J))
if J'>0!($DATA(FBERR))
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("AG",B,J,K))
if K'>0!($DATA(FBERR))
QUIT
DO REJT
if $DATA(FBERR)
QUIT
+2 GOTO ADONE
REJT ;
+1 ; skip interface reject
if $PIECE($GET(^FBAAC(J,3,K,"FBREJ")),"^",4)=1
QUIT
+2 SET FBAAMT=$PIECE(^FBAAC(J,3,K,0),"^",3)
+3 DO POST^FBAARD3
IF $DATA(FBERR)
GOTO PROB
+4 SET FBX=$$DELREJ^FBAARR3("162.04",K_","_J_",")
+5 QUIT
ALLP ;
+1 FOR J=0:0
SET J=$ORDER(^FBAA(162.1,"AF",B,J))
if J'>0!($DATA(FBERR))
QUIT
FOR K=0:0
SET K=$ORDER(^FBAA(162.1,"AF",B,J,K))
if K'>0!($DATA(FBERR))
QUIT
DO REJP
if $DATA(FBERR)
QUIT
+2 GOTO ADONE
REJP ;
+1 ; skip interface rej.
if $PIECE($GET(^FBAA(162.1,J,"RX",K,"FBREJ")),"^",4)=1
QUIT
+2 SET FBAAMT=+$PIECE(^FBAA(162.1,J,"RX",K,0),"^",16)
+3 DO POST^FBAARD3
IF $DATA(FBERR)
GOTO PROB
+4 SET FBX=$$DELREJ^FBAARR3("162.11",K_","_J_",")
+5 QUIT
ALLC ;
+1 FOR J=0:0
SET J=$ORDER(^FBAAI("AH",B,J))
if J'>0!($DATA(FBERR))
QUIT
IF $DATA(^FBAAI(J,0))
DO REJC
if $DATA(FBERR)
QUIT
+2 GOTO ADONE
REJC ;
+1 ; skip interface reject
if $PIECE($GET(^FBAAI(J,"FBREJ")),"^",4)=1
QUIT
+2 SET FBAAMT=+$PIECE(^FBAAI(J,0),"^",9)
SET FBII78=$PIECE($GET(^(0)),"^",5)
SET FBMM=$EXTRACT($PIECE(^(0),U,6),4,5)
+3 DO INPOST^FBAARD3
IF $DATA(FBERR)
GOTO PROB
+4 SET FBX=$$DELREJ^FBAARR3("162.5",J_",")
+5 KILL FBMM
+6 QUIT
PROB WRITE !!,*7,"There is a problem with your 1358. Unable to delete reject flag!",!
+1 QUIT
