- FBAAMPG1 ;AISC/DMK/CMR-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.
- S:'$D(DTIME) DTIME=999 I '$D(DT) S %DT="",X=T D ^%DT S DT=Y K X,Y
- I '$D(^FBAA(161.25,"AD")),'$D(^FBAA(161.26,"AD")),'$D(^FBAA(161.96,"AD")) G END
- S (CNT,MCNT,ICNT)=0
- F I=0:0 S I=$O(^FBAA(161.26,"AD",I)) Q:I'>0!(I>DT) 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>DT) 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 DELIA S ICNT=ICNT+1
- F I=0:0 S I=$O(^FBAA(161.25,"AD",I)) Q:I'>0!(I>DT) 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
- . I $D(^FBAA(161.95,IVA,0)) Q ; its OK so quit
- . S DA=I D DELIA S ICNT=ICNT+1 ; kill it
- . Q
- ;
- BULLET S XMB(1)=CNT,XMB(2)=MCNT,XMB(3)=ICNT,XMB="FBAA PURGE TRANSMITTED MRA'S",XMDUZ=$S($G(DUZ):DUZ,1:.5) D ^XMB
- 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
- DELIA S DIK="^FBAA(161.96," D ^DIK Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAMPG1 1843 printed Feb 18, 2025@23:22:14 Page 2
- FBAAMPG1 ;AISC/DMK/CMR-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.
- +3 if '$DATA(DTIME)
- SET DTIME=999
- IF '$DATA(DT)
- SET %DT=""
- SET X=T
- DO ^%DT
- SET DT=Y
- KILL X,Y
- +4 IF '$DATA(^FBAA(161.25,"AD"))
- IF '$DATA(^FBAA(161.26,"AD"))
- IF '$DATA(^FBAA(161.96,"AD"))
- GOTO END
- +5 SET (CNT,MCNT,ICNT)=0
- +6 FOR I=0:0
- SET I=$ORDER(^FBAA(161.26,"AD",I))
- if I'>0!(I>DT)
- 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
- +7 FOR I=0:0
- SET I=$ORDER(^FBAA(161.96,"AD",I))
- if I'>0!(I>DT)
- 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 DELIA
- SET ICNT=ICNT+1
- +8 FOR I=0:0
- SET I=$ORDER(^FBAA(161.25,"AD",I))
- if I'>0!(I>DT)
- 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
- +9 SET DA=K
- DO DELVEN
- SET MCNT=MCNT+1
- End DoDot:1
- +10 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
- +11 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
- +12 ;
- +13 ; check pending IPAC MRAs and remove any records that have bad IPAC vendor agreement pointers
- +14 FOR I=0:0
- SET I=$ORDER(^FBAA(161.96,"AS","P",I))
- if 'I
- QUIT
- Begin DoDot:1
- +15 NEW IVA
- +16 ; IPAC vendor agreement ptr
- SET IVA=+$PIECE($GET(^FBAA(161.96,I,0)),U,2)
- +17 ; its OK so quit
- IF $DATA(^FBAA(161.95,IVA,0))
- QUIT
- +18 ; kill it
- SET DA=I
- DO DELIA
- SET ICNT=ICNT+1
- +19 QUIT
- End DoDot:1
- +20 ;
- BULLET SET XMB(1)=CNT
- SET XMB(2)=MCNT
- SET XMB(3)=ICNT
- SET XMB="FBAA PURGE TRANSMITTED MRA'S"
- SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
- DO ^XMB
- 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
- DELIA SET DIK="^FBAA(161.96,"
- DO ^DIK
- QUIT
