- FBAARD ;AISC/DMK - DELETE REJECTS ENTERED IN ERROR ;4/4/2012
- ;;3.5;FEE BASIS;**114,132**;JAN 30, 1995;Build 17
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
- S Q="",$P(Q,"=",80)="=",UL="",$P(UL,"-",80)="-",(CNT,FBAAOUT,FBINTOT)=0
- D DT^DICRW
- I '$D(^XUSEC("FBAAREJECT",DUZ)) W !!,$C(7),"Sorry, you must hold the FBAAREJECT flag to use this option!" G Q
- BT K QQ W !! S DIC="^FBAA(161.7,",DIC(0)="AEQMN",DIC("S")="I $G(^(""ST""))=""F""&($P(^(0),U,17)]"""")" D ^DIC K DIC("S") G Q:X="^"!(X=""),BT:Y<0 S FBN=+Y,B=FBN
- L +^FBAA(161.7,FBN):$G(DILOCKTM,3)
- I '$T W !,"Another user is editing this batch. Try again later." G BT
- S FZ=^FBAA(161.7,FBN,0),FBTYPE=$P(FZ,"^",3),FBAAON=$P(FZ,"^",2),FBAARA=0
- I FBTYPE="B9",$P(FZ,"^",15)="" S FBCNH=1
- S FBAAB=$P(FZ,"^"),FBAAOB=$P(FZ,"^",8)_"-"_FBAAON,FBCOMM="Rejects deleted from batch "_FBAAB
- I '$S(FBTYPE="B3":$D(^FBAAC("AH",B)),FBTYPE="B2":$D(^FBAAC("AG",B)),FBTYPE="B5":$D(^FBAA(162.1,"AF",B)),FBTYPE="B9":$D(^FBAAI("AH",B)),1:0) W !!,*7,"No items rejected in this batch!" L -^FBAA(161.7,FBN) G BT
- S DA=FBN,DR="0:1;ST" W !! D EN^DIQ
- S FBNUM=$P(^FBAA(161.7,B,0),"^",1),FBVD=$P(^(0),"^",12),FBVDUZ=$P(^(0),"^",16)
- ASKLL S B=FBN,FBNNP=1 S DIR(0)="Y",DIR("A")="Want line items listed",DIR("B")="NO" D ^DIR K DIR W:Y @IOF D:Y MORE^FBAARJP:FBTYPE="B3",PMORE^FBAARJP:FBTYPE="B5",TMORE^FBAARJP:FBTYPE="B2",CMORE^FBAARJP:FBTYPE="B9" K FBNNP
- RD0 S DIR(0)="Y",DIR("A")="Want to delete local rejection codes for the entire Batch",DIR("B")="NO",DIR("?")="^D ^FBAARD0" D ^DIR K DIR G Q:$D(DIRUT),^FBAARD1:Y
- RD1 S DIR(0)="Y",DIR("A")="Want to delete local rejection code for any line items",DIR("B")="NO" D ^DIR K DIR G Q:'Y,Q:$D(DIRUT) D DELT^FBAARD2:FBTYPE="B2",DELM:FBTYPE="B3",DELP^FBAARD2:FBTYPE="B5",DELC^FBAARD0:FBTYPE="B9"
- G Q:$D(FBERR)
- RDD ;
- S DIC="^FBAA(161.7,",DA=FBN,DR="0:1;ST" W !! D EN^DIQ
- L -^FBAA(161.7,FBN)
- G BT
- Q ; clean-up
- I $G(FBN) L -^FBAA(161.7,FBN)
- K B,J,K,L,M,X,Y,Z,DIC,A,A1,A2,CPTDESC,DIRUT,DR,FBAACB,FBAACPT,FBAAON,FBAAOUT,FBAARA,FBIN,FBINOLD,FBINTOT,FBNUM,FBRR,FBTYPE,FBVD,FBVDUZ,FBVP,FZ,FBN,CNT,Q,P3,P4,UL,VAL,FBERR,FBAAMT,FBAAOB,FBCOMM,FBAAB,V,VID
- K FBAC,FBAP,FBDX,FBFD,FBK,FBX,FBPDT,FBSC,FBTD,S,ZS,PRCSCPAN,FBCNH,DUOUT
- Q
- DELM ; specify line items rejected in error for batch type B3
- ; select patient
- S J=$$ASKVET^FBAAUTL1("I $D(^FBAAC(""AH"",B,+Y))")
- Q:'J
- K QQ
- S QQ=0,FBAAOUT="" W @IOF D HED^FBAACCB
- F K=0:0 S K=$O(^FBAAC("AH",B,J,K)) Q:K'>0!(FBAAOUT) F L=0:0 S L=$O(^FBAAC("AH",B,J,K,L)) Q:L'>0!(FBAAOUT) F M=0:0 S M=$O(^FBAAC("AH",B,J,K,L,M)) Q:M'>0!(FBAAOUT) D WRITM
- I QQ=0 W !,"No local rejects found in batch for this patient!" G DELM
- RL1 S DIR(0)="Y",DIR("A")="Delete Reject flag for all items for this patient",DIR("B")="YES" D ^DIR K DIR Q:$D(DIRUT) G LOOP:Y
- RL S DIR(0)="N^1:"_QQ,DIR("A")="Delete reject for which line item"
- D ^DIR K DIR Q:$D(DIRUT) S HX=X
- I '$D(QQ(HX)) W !,*7,"You already deleted that one!!" G RL
- ASUR S DIR(0)="Y",DIR("A")="Are you sure you want to delete reject for item number "_HX,DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT)!'Y RL
- S J=$P(QQ(HX),"^",1),K=$P(QQ(HX),"^",2),L=$P(QQ(HX),"^",3),M=$P(QQ(HX),"^",4)
- D STUFF Q:$D(FBERR)
- 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 RL:Y,DELM
- WRITM ;
- Q:$P($G(^FBAAC(J,1,K,1,L,1,M,"FBREJ")),"^",4)=1 ; skip interface rej.
- S QQ=QQ+1,QQ(QQ)=J_"^"_K_"^"_L_"^"_M D SET^FBAACCB
- Q
- STUFF ;
- N FBX
- S FBAAMT=+$P(^FBAAC(J,1,K,1,L,1,M,0),"^",3)
- D POST^FBAARD3 G PROB^FBAARD1:$D(FBERR)
- S FBX=$$DELREJ^FBAARR3("162.03",M_","_L_","_K_","_J_",")
- I 'FBX D
- . W !,"1358 was updated, but error occured while deleting the reject"
- . W !,"flag for line with IENS = "_M_","_L_","_K_","_J_","
- . W !," ",$P(FBX,"^",2)
- . S FBERR=1
- K QQ(HX)
- Q
- LOOP F HX=0:0 S HX=$O(QQ(HX)) Q:HX'>0!($D(FBERR)) S J=$P(QQ(HX),"^",1),K=$P(QQ(HX),"^",2),L=$P(QQ(HX),"^",3),M=$P(QQ(HX),"^",4) D STUFF Q:$D(FBERR)
- W !,"...DONE!" G DELM
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAARD 4062 printed Feb 18, 2025@23:22:46 Page 2
- FBAARD ;AISC/DMK - DELETE REJECTS ENTERED IN ERROR ;4/4/2012
- +1 ;;3.5;FEE BASIS;**114,132**;JAN 30, 1995;Build 17
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
- DO ^%ZIS
- KILL IOP
- +4 SET Q=""
- SET $PIECE(Q,"=",80)="="
- SET UL=""
- SET $PIECE(UL,"-",80)="-"
- SET (CNT,FBAAOUT,FBINTOT)=0
- +5 DO DT^DICRW
- +6 IF '$DATA(^XUSEC("FBAAREJECT",DUZ))
- WRITE !!,$CHAR(7),"Sorry, you must hold the FBAAREJECT flag to use this option!"
- GOTO Q
- BT KILL QQ
- WRITE !!
- SET DIC="^FBAA(161.7,"
- SET DIC(0)="AEQMN"
- SET DIC("S")="I $G(^(""ST""))=""F""&($P(^(0),U,17)]"""")"
- DO ^DIC
- KILL DIC("S")
- if X="^"!(X="")
- GOTO Q
- if Y<0
- GOTO BT
- SET FBN=+Y
- SET B=FBN
- +1 LOCK +^FBAA(161.7,FBN):$GET(DILOCKTM,3)
- +2 IF '$TEST
- WRITE !,"Another user is editing this batch. Try again later."
- GOTO BT
- +3 SET FZ=^FBAA(161.7,FBN,0)
- SET FBTYPE=$PIECE(FZ,"^",3)
- SET FBAAON=$PIECE(FZ,"^",2)
- SET FBAARA=0
- +4 IF FBTYPE="B9"
- IF $PIECE(FZ,"^",15)=""
- SET FBCNH=1
- +5 SET FBAAB=$PIECE(FZ,"^")
- SET FBAAOB=$PIECE(FZ,"^",8)_"-"_FBAAON
- SET FBCOMM="Rejects deleted from batch "_FBAAB
- +6 IF '$SELECT(FBTYPE="B3":$DATA(^FBAAC("AH",B)),FBTYPE="B2":$DATA(^FBAAC("AG",B)),FBTYPE="B5":$DATA(^FBAA(162.1,"AF",B)),FBTYPE="B9":$DATA(^FBAAI("AH",B)),1:0)
- WRITE !!,*7,"No items rejected in this batch!"
- LOCK -^FBAA(161.7,FBN)
- GOTO BT
- +7 SET DA=FBN
- SET DR="0:1;ST"
- WRITE !!
- DO EN^DIQ
- +8 SET FBNUM=$PIECE(^FBAA(161.7,B,0),"^",1)
- SET FBVD=$PIECE(^(0),"^",12)
- SET FBVDUZ=$PIECE(^(0),"^",16)
- ASKLL SET B=FBN
- SET FBNNP=1
- SET DIR(0)="Y"
- SET DIR("A")="Want line items listed"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- if Y
- WRITE @IOF
- if Y
- if FBTYPE="B3"
- DO MORE^FBAARJP
- if FBTYPE="B5"
- DO PMORE^FBAARJP
- if FBTYPE="B2"
- DO TMORE^FBAARJP
- if FBTYPE="B9"
- DO CMORE^FBAARJP
- KILL FBNNP
- RD0 SET DIR(0)="Y"
- SET DIR("A")="Want to delete local rejection codes for the entire Batch"
- SET DIR("B")="NO"
- SET DIR("?")="^D ^FBAARD0"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO Q
- if Y
- GOTO ^FBAARD1
- RD1 SET DIR(0)="Y"
- SET DIR("A")="Want to delete local rejection code for any line items"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- if 'Y
- GOTO Q
- if $DATA(DIRUT)
- GOTO Q
- if FBTYPE="B2"
- DO DELT^FBAARD2
- if FBTYPE="B3"
- DO DELM
- if FBTYPE="B5"
- DO DELP^FBAARD2
- if FBTYPE="B9"
- DO DELC^FBAARD0
- +1 if $DATA(FBERR)
- GOTO Q
- RDD ;
- +1 SET DIC="^FBAA(161.7,"
- SET DA=FBN
- SET DR="0:1;ST"
- WRITE !!
- DO EN^DIQ
- +2 LOCK -^FBAA(161.7,FBN)
- +3 GOTO BT
- Q ; clean-up
- +1 IF $GET(FBN)
- LOCK -^FBAA(161.7,FBN)
- +2 KILL B,J,K,L,M,X,Y,Z,DIC,A,A1,A2,CPTDESC,DIRUT,DR,FBAACB,FBAACPT,FBAAON,FBAAOUT,FBAARA,FBIN,FBINOLD,FBINTOT,FBNUM,FBRR,FBTYPE,FBVD,FBVDUZ,FBVP,FZ,FBN,CNT,Q,P3,P4,UL,VAL,FBERR,FBAAMT,FBAAOB,FBCOMM,FBAAB,V,VID
- +3 KILL FBAC,FBAP,FBDX,FBFD,FBK,FBX,FBPDT,FBSC,FBTD,S,ZS,PRCSCPAN,FBCNH,DUOUT
- +4 QUIT
- DELM ; specify line items rejected in error for batch type B3
- +1 ; select patient
- +2 SET J=$$ASKVET^FBAAUTL1("I $D(^FBAAC(""AH"",B,+Y))")
- +3 if 'J
- QUIT
- +4 KILL QQ
- +5 SET QQ=0
- SET FBAAOUT=""
- WRITE @IOF
- DO HED^FBAACCB
- +6 FOR K=0:0
- SET K=$ORDER(^FBAAC("AH",B,J,K))
- if K'>0!(FBAAOUT)
- QUIT
- FOR L=0:0
- SET L=$ORDER(^FBAAC("AH",B,J,K,L))
- if L'>0!(FBAAOUT)
- QUIT
- FOR M=0:0
- SET M=$ORDER(^FBAAC("AH",B,J,K,L,M))
- if M'>0!(FBAAOUT)
- QUIT
- DO WRITM
- +7 IF QQ=0
- WRITE !,"No local rejects found in batch for this patient!"
- GOTO DELM
- RL1 SET DIR(0)="Y"
- SET DIR("A")="Delete Reject flag for all items for this patient"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- if Y
- GOTO LOOP
- RL SET DIR(0)="N^1:"_QQ
- SET DIR("A")="Delete reject for which line item"
- +1 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- SET HX=X
- +2 IF '$DATA(QQ(HX))
- WRITE !,*7,"You already deleted that one!!"
- GOTO RL
- ASUR SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want to delete reject for item number "_HX
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)!'Y
- GOTO RL
- +1 SET J=$PIECE(QQ(HX),"^",1)
- SET K=$PIECE(QQ(HX),"^",2)
- SET L=$PIECE(QQ(HX),"^",3)
- SET M=$PIECE(QQ(HX),"^",4)
- +2 DO STUFF
- if $DATA(FBERR)
- 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 Y
- GOTO RL
- GOTO DELM
- WRITM ;
- +1 ; skip interface rej.
- if $PIECE($GET(^FBAAC(J,1,K,1,L,1,M,"FBREJ")),"^",4)=1
- QUIT
- +2 SET QQ=QQ+1
- SET QQ(QQ)=J_"^"_K_"^"_L_"^"_M
- DO SET^FBAACCB
- +3 QUIT
- STUFF ;
- +1 NEW FBX
- +2 SET FBAAMT=+$PIECE(^FBAAC(J,1,K,1,L,1,M,0),"^",3)
- +3 DO POST^FBAARD3
- if $DATA(FBERR)
- GOTO PROB^FBAARD1
- +4 SET FBX=$$DELREJ^FBAARR3("162.03",M_","_L_","_K_","_J_",")
- +5 IF 'FBX
- Begin DoDot:1
- +6 WRITE !,"1358 was updated, but error occured while deleting the reject"
- +7 WRITE !,"flag for line with IENS = "_M_","_L_","_K_","_J_","
- +8 WRITE !," ",$PIECE(FBX,"^",2)
- +9 SET FBERR=1
- End DoDot:1
- +10 KILL QQ(HX)
- +11 QUIT
- LOOP FOR HX=0:0
- SET HX=$ORDER(QQ(HX))
- if HX'>0!($DATA(FBERR))
- QUIT
- SET J=$PIECE(QQ(HX),"^",1)
- SET K=$PIECE(QQ(HX),"^",2)
- SET L=$PIECE(QQ(HX),"^",3)
- SET M=$PIECE(QQ(HX),"^",4)
- DO STUFF
- if $DATA(FBERR)
- QUIT
- +1 WRITE !,"...DONE!"
- GOTO DELM
