FBAAMPRG ;AISC/DMK-PURGE TRANSMITTED MRA'S ;5/24/1999
;;3.5;FEE BASIS;**18,123**;JAN 30, 1995;Build 51
;;Per VA Directive 6402, this routine should not be modified.
ASK W !! S %DT("A")="Purge Veteran, IPAC and Vendor MRA's transmitted PRIOR to: ",%DT="AEXP",%DT(0)=-DT D ^%DT K %DT G END:X="^"!(X=""),ASK:Y<0 S FBAAPD=Y
N DA,DIK
I '$D(^FBAA(161.25,"AD")),'$D(^FBAA(161.26,"AD")),'$D(^FBAA(161.96,"AD")) W !!,*7,"No transmitted MRA's currently on file!",! G END
S (CNT,MCNT,ICNT)=0 W !,?25,"Deleting....",!
F I=0:0 S I=$O(^FBAA(161.26,"AD",I)) Q:I'>0!(I>FBAAPD) F J=0:0 S J=$O(^FBAA(161.26,"AD",I,J)) Q:J'>0 I $D(^FBAA(161.26,J,0)) S DA=J D DELVET S CNT=CNT+1
F I=0:0 S I=$O(^FBAA(161.96,"AD",I)) Q:I'>0!(I>FBAAPD) F J=0:0 S J=$O(^FBAA(161.96,"AD",I,J)) Q:J'>0 I $D(^FBAA(161.96,J,0)) S DA=J D DELIPAC S ICNT=ICNT+1
F I=0:0 S I=$O(^FBAA(161.25,"AD",I)) Q:I'>0!(I>FBAAPD) F J="O","P" F K=0:0 S K=$O(^FBAA(161.25,"AD",I,J,K)) Q:K'>0 I $D(^FBAA(161.25,K,0)),($S($P(^(0),"^",3)="C":0,$P(^(0),"^",2)="C":0,$P(^(0),"^",3)="N":0,$P(^(0),"^",2)="N":0,1:1)) D
.S DA=K D DELVEN S MCNT=MCNT+1
F I="O","P" F J=0:0 S J=$O(^FBAA(161.25,"AE",I,J)) Q:'J I $D(^FBAA(161.25,J,0)),'$D(^FBAAV(J,0)) S DA=J D DELVEN S MCNT=MCNT+1
F I=0:0 S I=$O(^FBAA(161.26,"AC","P",I)) Q:'I I $D(^FBAA(161.26,I,0)) S J=+$P(^(0),"^",3) I '$D(^FBAAA(+^FBAA(161.26,I,0),1,J,0)) S DA=I D DELVET S CNT=CNT+1
;
; check pending IPAC MRAs and remove any records that have bad IPAC vendor agreement pointers
F I=0:0 S I=$O(^FBAA(161.96,"AS","P",I)) Q:'I D
. N IVA
. S IVA=$P($G(^FBAA(161.96,I,0)),U,2) ; IPAC vendor agreement ptr
. Q:IVA="" ; MRA record for a delete
. I $D(^FBAA(161.95,IVA,0)) Q ; its OK so quit
. S DA=I D DELIPAC S ICNT=ICNT+1 ; kill it
. Q
;
W !!,?16,"Total Veteran MRA's deleted: ",CNT,!,?16,"Total Vendor MRA's deleted: ",MCNT,!,?16,"Total IPAC MRA's deleted: ",ICNT,!
END K F,I,J,K,CNT,MCNT,FBAAPD,X,Y,ICNT Q
;
DELVET S DIK="^FBAA(161.26," D ^DIK Q
DELVEN S DIK="^FBAA(161.25," D ^DIK Q
DELIPAC S DIK="^FBAA(161.96," D ^DIK Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAMPRG 2129 printed Apr 09, 2024@21:00:24 Page 2
FBAAMPRG ;AISC/DMK-PURGE TRANSMITTED MRA'S ;5/24/1999
+1 ;;3.5;FEE BASIS;**18,123**;JAN 30, 1995;Build 51
+2 ;;Per VA Directive 6402, this routine should not be modified.
ASK WRITE !!
SET %DT("A")="Purge Veteran, IPAC and Vendor MRA's transmitted PRIOR to: "
SET %DT="AEXP"
SET %DT(0)=-DT
DO ^%DT
KILL %DT
if X="^"!(X="")
GOTO END
if Y<0
GOTO ASK
SET FBAAPD=Y
+1 NEW DA,DIK
+2 IF '$DATA(^FBAA(161.25,"AD"))
IF '$DATA(^FBAA(161.26,"AD"))
IF '$DATA(^FBAA(161.96,"AD"))
WRITE !!,*7,"No transmitted MRA's currently on file!",!
GOTO END
+3 SET (CNT,MCNT,ICNT)=0
WRITE !,?25,"Deleting....",!
+4 FOR I=0:0
SET I=$ORDER(^FBAA(161.26,"AD",I))
if I'>0!(I>FBAAPD)
QUIT
FOR J=0:0
SET J=$ORDER(^FBAA(161.26,"AD",I,J))
if J'>0
QUIT
IF $DATA(^FBAA(161.26,J,0))
SET DA=J
DO DELVET
SET CNT=CNT+1
+5 FOR I=0:0
SET I=$ORDER(^FBAA(161.96,"AD",I))
if I'>0!(I>FBAAPD)
QUIT
FOR J=0:0
SET J=$ORDER(^FBAA(161.96,"AD",I,J))
if J'>0
QUIT
IF $DATA(^FBAA(161.96,J,0))
SET DA=J
DO DELIPAC
SET ICNT=ICNT+1
+6 FOR I=0:0
SET I=$ORDER(^FBAA(161.25,"AD",I))
if I'>0!(I>FBAAPD)
QUIT
FOR J="O","P"
FOR K=0:0
SET K=$ORDER(^FBAA(161.25,"AD",I,J,K))
if K'>0
QUIT
IF $DATA(^FBAA(161.25,K,0))
IF ($SELECT($PIECE(^(0),"^",3)="C":0,$PIECE(^(0),"^",2)="C":0,$PIECE(^(0),"^",3)="N":0,$PIECE(^(0),"^",2)="N":0,1:1))
Begin DoDot:1
+7 SET DA=K
DO DELVEN
SET MCNT=MCNT+1
End DoDot:1
+8 FOR I="O","P"
FOR J=0:0
SET J=$ORDER(^FBAA(161.25,"AE",I,J))
if 'J
QUIT
IF $DATA(^FBAA(161.25,J,0))
IF '$DATA(^FBAAV(J,0))
SET DA=J
DO DELVEN
SET MCNT=MCNT+1
+9 FOR I=0:0
SET I=$ORDER(^FBAA(161.26,"AC","P",I))
if 'I
QUIT
IF $DATA(^FBAA(161.26,I,0))
SET J=+$PIECE(^(0),"^",3)
IF '$DATA(^FBAAA(+^FBAA(161.26,I,0),1,J,0))
SET DA=I
DO DELVET
SET CNT=CNT+1
+10 ;
+11 ; check pending IPAC MRAs and remove any records that have bad IPAC vendor agreement pointers
+12 FOR I=0:0
SET I=$ORDER(^FBAA(161.96,"AS","P",I))
if 'I
QUIT
Begin DoDot:1
+13 NEW IVA
+14 ; IPAC vendor agreement ptr
SET IVA=$PIECE($GET(^FBAA(161.96,I,0)),U,2)
+15 ; MRA record for a delete
if IVA=""
QUIT
+16 ; its OK so quit
IF $DATA(^FBAA(161.95,IVA,0))
QUIT
+17 ; kill it
SET DA=I
DO DELIPAC
SET ICNT=ICNT+1
+18 QUIT
End DoDot:1
+19 ;
+20 WRITE !!,?16,"Total Veteran MRA's deleted: ",CNT,!,?16,"Total Vendor MRA's deleted: ",MCNT,!,?16,"Total IPAC MRA's deleted: ",ICNT,!
END KILL F,I,J,K,CNT,MCNT,FBAAPD,X,Y,ICNT
QUIT
+1 ;
DELVET SET DIK="^FBAA(161.26,"
DO ^DIK
QUIT
DELVEN SET DIK="^FBAA(161.25,"
DO ^DIK
QUIT
DELIPAC SET DIK="^FBAA(161.96,"
DO ^DIK
QUIT
