PRC186P ;FW/RB-PRE INSTALL PRC*186 TO PURGE DUPLICATE FILE 443 X-REF ENTRIES ;4-26-94/3:45 PM
V ;;5.1;IFCAP;**186**;Oct 20, 2000;Build 10
;Per VA Directive 6402, this routine should not be modified.
Q
;PRC*5.1*186 Delete all duplicate File 443, 'AC' x-ref entries if
; 'AC' status not equal to node 0 current status and
; and duplicate entry exists. Also, purge all File
; 443, 'AC' entries with no 0 node.
;
START K ^XTMP("PRC186P")
D NOW^%DTC S PRCSTART=%
S ^XTMP("PRC186P","START COMPILE")=PRCSTART
S ^XTMP("PRC186P","END COMPILE")="RUNNING"
S ^XTMP("PRC186P",0)=$$FMADD^XLFDT(PRCSTART,180)_"^"_PRCSTART
M ^XTMP("PRC186P",99,443)=^PRC(443)
S U="^",PRCSTS="",(PRCT,PRCT1,PRCT2,PRCT3,PRCT4,PRCT5,PRCT6,PRCTT)=0
1 S PRCSTS=$O(^PRC(443,"AC",PRCSTS)),PRCIEN=0 G 9:PRCSTS=""
2 S PRCIEN=$O(^PRC(443,"AC",PRCSTS,PRCIEN)),PRCT=0 G 1:'PRCIEN S PRCTT=PRCTT+1
I $D(^XTMP("PRC186P",2,PRCIEN,PRCSTS)) G 2
S PRCR0=$G(^PRC(443,PRCIEN,0)) I PRCR0="" D G 2
. S ^XTMP("PRC186P",1,PRCIEN,PRCSTS)="O"_U_$P(PRCR0,U,7),PRCT1=PRCT1+1 W !,"MISSING 0 NODE: ",PRCSTS,",",PRCIEN
. K ^PRC(443,"AC",PRCSTS,PRCIEN) ;**********1
I PRCR0'="",$P(PRCR0,U,7)'=PRCSTS S PRCBACK=0 D G:PRCBACK 2
. W !,PRCIEN," AC DELETED FOR NOT MATCH ZERO NODE ",PRCSTS,"/",$P(PRCR0,U,7) K ^PRC(443,"AC",PRCSTS,PRCIEN) ;*******************2
. S ^XTMP("PRC186P",1,PRCIEN,PRCSTS)="MM"_U_$P(PRCR0,U,7),PRCT5=PRCT5+1,PRCBACK=1
. I '$D(^PRC(443,"AC",$P(PRCR0,U,7),PRCIEN)) D
.. W !,PRCIEN," 0 NODE SET TO CORRECT 'AC' X-REF DEFINED FOR ",$P(PRCR0,U,7) S ^PRC(443,"AC",$P(PRCR0,U,7),PRCIEN)="" ;*******************3
.. S ^XTMP("PRC186P",1,PRCIEN,PRCSTS)="ND"_U_PRCR0,PRCT6=PRCT6+1,PRCBACK=1
F PRCI=PRCSTS+1:1:99 I $D(^PRC(443,"AC",PRCI,PRCIEN)) D
. S PRCR=$G(^PRC(443,PRCIEN,0)) I PRCR="" D
.. Q:$D(^XTMP("PRC186P",1,PRCIEN,PRCI))
.. S ^XTMP("PRC186P",1,PRCIEN,PRCI)="D"_U_$P(PRCR,U,7),PRCT2=PRCT2+1
.. K ^PRC(443,"AC",PRCI,PRCIEN) ;************4
. S:PRCT=0 ^XTMP("PRC186P",2,PRCIEN,PRCSTS)=$P(PRCR,U,7),PRCT=1
. S ^XTMP("PRC186P",2,PRCIEN,PRCI)=$P(PRCR,U,7),PRCT4=PRCT4+1
I PRCT=1 S PRCT3=PRCT3+1,PRCA=0 F PRCJ=1:1 S PRCA=$O(^XTMP("PRC186P",2,PRCIEN,PRCA)) Q:PRCA="" D
. I PRCJ=1 D
.. W !!,PRCIEN W:$D(^XTMP("PRC186P",1,PRCIEN)) "(NULL)" W ?15,$P($G(^PRCS(410,PRCIEN,10)),U,4),?25,PRCA,"/",^XTMP("PRC186P",2,PRCIEN,PRCA)
.. I PRCA'=$P($G(^PRC(443,PRCIEN,0)),U,7) W "(*)" K ^PRC(443,"AC",PRCA,PRCIEN) ;*************5
. I PRCJ>1 D
.. W ", ",PRCA,"/",^XTMP("PRC186P",2,PRCIEN,PRCA) I PRCA'=$P($G(^PRC(443,PRCIEN,0)),U,7) W "(*)"
.. K ^PRC(443,"AC",PRCA,PRCIEN) ;****************6
G 2
9 W !!!,"TOTAL 443 'AC' X-REF: ",PRCTT,!!,"MASTER PRCIEN MISSING 0 NODE: ",PRCT1,!!,"DUPE PRCIEN MISSING 0 NODE: ",PRCT2
W !!,"TOTAL INDIVIDUAL DUPLICATES: ",PRCT3,!!,"TOTAL DUPLICATES: ",PRCT4
W !!,"TOTAL 'AC' STATUS NOT MATCH 0 NODE: ",PRCT5,!!,"TOTAL 'AC' STATUS NOT DEFINED, 'AC' X-REF SET: ",PRCT6
D NOW^%DTC S PRCRMEND=%
S ^XTMP("PRC186P","END PURGE DUPES")=PRCRMEND
S ^XTMP("PRC186P","TOTALS")=PRCTT_U_PRCT1_U_PRCT2_U_PRCT3_U_PRCT4_U_PRCT5_U_PRCT6
K %,PRCSTART,PRCRMEND,PRCSTS,PRCT,PRCT1,PRCT2,PRCT3,PRCT4,PRCT5,PRCT6,PRCTT,PRCIEN,PRCR0,PRCR,PRCI,PRCJ,PRCBACK,PRCA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC186P 3253 printed Sep 23, 2025@19:35:33 Page 2
PRC186P ;FW/RB-PRE INSTALL PRC*186 TO PURGE DUPLICATE FILE 443 X-REF ENTRIES ;4-26-94/3:45 PM
V ;;5.1;IFCAP;**186**;Oct 20, 2000;Build 10
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 QUIT
+3 ;PRC*5.1*186 Delete all duplicate File 443, 'AC' x-ref entries if
+4 ; 'AC' status not equal to node 0 current status and
+5 ; and duplicate entry exists. Also, purge all File
+6 ; 443, 'AC' entries with no 0 node.
+7 ;
START KILL ^XTMP("PRC186P")
+1 DO NOW^%DTC
SET PRCSTART=%
+2 SET ^XTMP("PRC186P","START COMPILE")=PRCSTART
+3 SET ^XTMP("PRC186P","END COMPILE")="RUNNING"
+4 SET ^XTMP("PRC186P",0)=$$FMADD^XLFDT(PRCSTART,180)_"^"_PRCSTART
+5 MERGE ^XTMP("PRC186P",99,443)=^PRC(443)
+6 SET U="^"
SET PRCSTS=""
SET (PRCT,PRCT1,PRCT2,PRCT3,PRCT4,PRCT5,PRCT6,PRCTT)=0
1 SET PRCSTS=$ORDER(^PRC(443,"AC",PRCSTS))
SET PRCIEN=0
if PRCSTS=""
GOTO 9
2 SET PRCIEN=$ORDER(^PRC(443,"AC",PRCSTS,PRCIEN))
SET PRCT=0
if 'PRCIEN
GOTO 1
SET PRCTT=PRCTT+1
+1 IF $DATA(^XTMP("PRC186P",2,PRCIEN,PRCSTS))
GOTO 2
+2 SET PRCR0=$GET(^PRC(443,PRCIEN,0))
IF PRCR0=""
Begin DoDot:1
+3 SET ^XTMP("PRC186P",1,PRCIEN,PRCSTS)="O"_U_$PIECE(PRCR0,U,7)
SET PRCT1=PRCT1+1
WRITE !,"MISSING 0 NODE: ",PRCSTS,",",PRCIEN
+4 ;**********1
KILL ^PRC(443,"AC",PRCSTS,PRCIEN)
End DoDot:1
GOTO 2
+5 IF PRCR0'=""
IF $PIECE(PRCR0,U,7)'=PRCSTS
SET PRCBACK=0
Begin DoDot:1
+6 ;*******************2
WRITE !,PRCIEN," AC DELETED FOR NOT MATCH ZERO NODE ",PRCSTS,"/",$PIECE(PRCR0,U,7)
KILL ^PRC(443,"AC",PRCSTS,PRCIEN)
+7 SET ^XTMP("PRC186P",1,PRCIEN,PRCSTS)="MM"_U_$PIECE(PRCR0,U,7)
SET PRCT5=PRCT5+1
SET PRCBACK=1
+8 IF '$DATA(^PRC(443,"AC",$PIECE(PRCR0,U,7),PRCIEN))
Begin DoDot:2
+9 ;*******************3
WRITE !,PRCIEN," 0 NODE SET TO CORRECT 'AC' X-REF DEFINED FOR ",$PIECE(PRCR0,U,7)
SET ^PRC(443,"AC",$PIECE(PRCR0,U,7),PRCIEN)=""
+10 SET ^XTMP("PRC186P",1,PRCIEN,PRCSTS)="ND"_U_PRCR0
SET PRCT6=PRCT6+1
SET PRCBACK=1
End DoDot:2
End DoDot:1
if PRCBACK
GOTO 2
+11 FOR PRCI=PRCSTS+1:1:99
IF $DATA(^PRC(443,"AC",PRCI,PRCIEN))
Begin DoDot:1
+12 SET PRCR=$GET(^PRC(443,PRCIEN,0))
IF PRCR=""
Begin DoDot:2
+13 if $DATA(^XTMP("PRC186P",1,PRCIEN,PRCI))
QUIT
+14 SET ^XTMP("PRC186P",1,PRCIEN,PRCI)="D"_U_$PIECE(PRCR,U,7)
SET PRCT2=PRCT2+1
+15 ;************4
KILL ^PRC(443,"AC",PRCI,PRCIEN)
End DoDot:2
+16 if PRCT=0
SET ^XTMP("PRC186P",2,PRCIEN,PRCSTS)=$PIECE(PRCR,U,7)
SET PRCT=1
+17 SET ^XTMP("PRC186P",2,PRCIEN,PRCI)=$PIECE(PRCR,U,7)
SET PRCT4=PRCT4+1
End DoDot:1
+18 IF PRCT=1
SET PRCT3=PRCT3+1
SET PRCA=0
FOR PRCJ=1:1
SET PRCA=$ORDER(^XTMP("PRC186P",2,PRCIEN,PRCA))
if PRCA=""
QUIT
Begin DoDot:1
+19 IF PRCJ=1
Begin DoDot:2
+20 WRITE !!,PRCIEN
if $DATA(^XTMP("PRC186P",1,PRCIEN))
WRITE "(NULL)"
WRITE ?15,$PIECE($GET(^PRCS(410,PRCIEN,10)),U,4),?25,PRCA,"/",^XTMP("PRC186P",2,PRCIEN,PRCA)
+21 ;*************5
IF PRCA'=$PIECE($GET(^PRC(443,PRCIEN,0)),U,7)
WRITE "(*)"
KILL ^PRC(443,"AC",PRCA,PRCIEN)
End DoDot:2
+22 IF PRCJ>1
Begin DoDot:2
+23 WRITE ", ",PRCA,"/",^XTMP("PRC186P",2,PRCIEN,PRCA)
IF PRCA'=$PIECE($GET(^PRC(443,PRCIEN,0)),U,7)
WRITE "(*)"
+24 ;****************6
KILL ^PRC(443,"AC",PRCA,PRCIEN)
End DoDot:2
End DoDot:1
+25 GOTO 2
9 WRITE !!!,"TOTAL 443 'AC' X-REF: ",PRCTT,!!,"MASTER PRCIEN MISSING 0 NODE: ",PRCT1,!!,"DUPE PRCIEN MISSING 0 NODE: ",PRCT2
+1 WRITE !!,"TOTAL INDIVIDUAL DUPLICATES: ",PRCT3,!!,"TOTAL DUPLICATES: ",PRCT4
+2 WRITE !!,"TOTAL 'AC' STATUS NOT MATCH 0 NODE: ",PRCT5,!!,"TOTAL 'AC' STATUS NOT DEFINED, 'AC' X-REF SET: ",PRCT6
+3 DO NOW^%DTC
SET PRCRMEND=%
+4 SET ^XTMP("PRC186P","END PURGE DUPES")=PRCRMEND
+5 SET ^XTMP("PRC186P","TOTALS")=PRCTT_U_PRCT1_U_PRCT2_U_PRCT3_U_PRCT4_U_PRCT5_U_PRCT6
+6 KILL %,PRCSTART,PRCRMEND,PRCSTS,PRCT,PRCT1,PRCT2,PRCT3,PRCT4,PRCT5,PRCT6,PRCTT,PRCIEN,PRCR0,PRCR,PRCI,PRCJ,PRCBACK,PRCA
+7 QUIT
