- FBAARD0 ;AISC/GRR - DELETE REJECTS ENTERED IN ERROR (CONT.) ;3/28/2012
- ;;3.5;FEE BASIS;**132**;JAN 30, 1995;Build 17
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- HELPD ;
- W !!,"If you answer 'Yes' to this question, the reject flag will be deleted from all"
- W !,"locally rejected line items in this batch. If you answer 'No', you will be"
- W !,"asked if you want to delete the reject flag from specific line items."
- Q
- DELC ; specify line items rejected in error for batch type B9
- S (QQ,FBAAOUT)=0 W @IOF D HEDC^FBAACCB1 F I=0:0 S I=$O(^FBAAI("AH",B,I)) Q:I'>0!(FBAAOUT) I $D(^FBAAI(I,0)) S Z(0)=^(0) D WRITC
- I QQ=0 W !,"No local rejects found in batch!" Q
- RL S DIR(0)="N^1:"_QQ,DIR("A")="Delete reject flag for which line item" D ^DIR K DIR Q:$D(DIRUT) S HX=X
- I '$D(QQ(HX)) W !,*7,"You already did that one !!" G RL
- ASKSU S DIR(0)="Y",DIR("A")="Are you sure you want to delete the reject on item number "_HX,DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT)!'Y RL
- S I=QQ(HX),(FBAAAP,FBAAMT)=+$P(^FBAAI(I,0),"^",9),FBII78=$P($G(^(0)),"^",5),FBMM=$E($P(^(0),U,6),4,5) S FBINVI=I D INPOST^FBAARD3 S I=FBINVI K FBINVI I $D(FBERR) G PROB^FBAARD1
- S FBX=$$DELREJ^FBAARR3(162.5,I_",")
- I 'FBX D
- . W !,"1358 was updated, but error occured while deleting the reject"
- . W !,"flag for line with IENS = "_I_","
- . W !," ",$P(FBX,"^",2)
- . S FBERR=1
- K QQ(HX),FBMM
- W !,"...Done"
- I '$D(^FBAAI("AH",B)) Q
- RDMORE S DIR(0)="Y",DIR("A")=$S($G(FBERR):"",1:"Item Deleted. ")_"Want to delete another",DIR("B")="YES" D ^DIR K DIR G RDMORE:$D(DIRUT),RL:Y
- Q
- WRITC ;
- Q:$P($G(^FBAAI(I,"FBREJ")),"^",4)=1 ; skip interface rejects
- S QQ=QQ+1,QQ(QQ)=I D CMORE^FBAACCB1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAARD0 1701 printed Jan 18, 2025@02:57:34 Page 2
- FBAARD0 ;AISC/GRR - DELETE REJECTS ENTERED IN ERROR (CONT.) ;3/28/2012
- +1 ;;3.5;FEE BASIS;**132**;JAN 30, 1995;Build 17
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- HELPD ;
- +1 WRITE !!,"If you answer 'Yes' to this question, the reject flag will be deleted from all"
- +2 WRITE !,"locally rejected line items in this batch. If you answer 'No', you will be"
- +3 WRITE !,"asked if you want to delete the reject flag from specific line items."
- +4 QUIT
- DELC ; specify line items rejected in error for batch type B9
- +1 SET (QQ,FBAAOUT)=0
- WRITE @IOF
- DO HEDC^FBAACCB1
- FOR I=0:0
- SET I=$ORDER(^FBAAI("AH",B,I))
- if I'>0!(FBAAOUT)
- QUIT
- IF $DATA(^FBAAI(I,0))
- SET Z(0)=^(0)
- DO WRITC
- +2 IF QQ=0
- WRITE !,"No local rejects found in batch!"
- QUIT
- RL SET DIR(0)="N^1:"_QQ
- SET DIR("A")="Delete reject flag for which line item"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- SET HX=X
- +1 IF '$DATA(QQ(HX))
- WRITE !,*7,"You already did that one !!"
- GOTO RL
- ASKSU SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want to delete the reject on item number "_HX
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)!'Y
- GOTO RL
- +1 SET I=QQ(HX)
- SET (FBAAAP,FBAAMT)=+$PIECE(^FBAAI(I,0),"^",9)
- SET FBII78=$PIECE($GET(^(0)),"^",5)
- SET FBMM=$EXTRACT($PIECE(^(0),U,6),4,5)
- SET FBINVI=I
- DO INPOST^FBAARD3
- SET I=FBINVI
- KILL FBINVI
- IF $DATA(FBERR)
- GOTO PROB^FBAARD1
- +2 SET FBX=$$DELREJ^FBAARR3(162.5,I_",")
- +3 IF 'FBX
- Begin DoDot:1
- +4 WRITE !,"1358 was updated, but error occured while deleting the reject"
- +5 WRITE !,"flag for line with IENS = "_I_","
- +6 WRITE !," ",$PIECE(FBX,"^",2)
- +7 SET FBERR=1
- End DoDot:1
- +8 KILL QQ(HX),FBMM
- +9 WRITE !,"...Done"
- +10 IF '$DATA(^FBAAI("AH",B))
- QUIT
- RDMORE SET DIR(0)="Y"
- SET DIR("A")=$SELECT($GET(FBERR):"",1:"Item Deleted. ")_"Want to delete another"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO RDMORE
- if Y
- GOTO RL
- +1 QUIT
- WRITC ;
- +1 ; skip interface rejects
- if $PIECE($GET(^FBAAI(I,"FBREJ")),"^",4)=1
- QUIT
- +2 SET QQ=QQ+1
- SET QQ(QQ)=I
- DO CMORE^FBAACCB1
- QUIT