XBDANGLE ;IHS/SET/GTH - Q'ABLE CLEANUP DANGLING POINTERS OPTION HELP FRAME PROTOCOL FILES ; [ 10/29/2002 7:42 AM ]
;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cleanup dangling pointers.
;
; This utility can be scheduled to run via TaskMan.
;
; Actions are delivered to XUPROG key holders via MailMan.
;
; You can also run this interactively, but you'll still
; get the MailMan note, even after the interactive run.
;
; Thanks to the VA for the original interactive routine, XQ3.
;
D INIT
D OFIX,HFFIX,PFIX
D MAIL
D EXIT
Q
;
; ----------------------------------------------------------
;
OFIX ;Kill any dangling pointers in the OPTION File (#19)
NEW I,J,K,L,M,X,Y
S (I,X)=0 ;X=Total Deletions
L1 ;
S I=$O(^DIC(19,I))
I I>0 S (Y,J)=0 G L2 ;Loop through menus
D RSLT(X_" pointer"_$S(X=1:"",1:"s")_" fixed in your OPTION file.")
Q
;
L2 ;
S J=$O(^DIC(19,I,10,J))
I J>0 G ITEM ;Loop through menu items
I '$D(^DIC(19,I,10,0)) G L1
S (K,J)=0
F L=1:1 S J=$O(^DIC(19,I,10,J)) Q:J'>0 S K=J ;K=Last item
S J=^DIC(19,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
G XREFS
;
ITEM ;
S K=+^DIC(19,I,10,J,0)
I $D(^DIC(19,K,0)) S Y=Y+1 G L2 ;Y=No. of items
D RSLT("Option "_$P(^DIC(19,I,0),U,1)_" points to missing option "_K)
S X=X+1
KILL ^DIC(19,I,10,J) ;Kill invalid menu item
G L2
;
XREFS ;
S K=":"
L3 ;
S K=$O(^DIC(19,I,10,K))
I K="" G L1 ;Loop through cross references
S L=-1
L4 ;
S L=$O(^DIC(19,I,10,K,L))
I L="" G L3
S J=0
L5 ;
S J=$O(^DIC(19,I,10,K,L,J))
I J'>0 G L4
I '$D(^DIC(19,I,10,J,0)) G KILLXR ;kill xref to invalid item
L6 ;
S M=^DIC(19,I,10,J,0)
I (M=L)!(M[L_"^") G L5
KILLXR ;
KILL ^DIC(19,I,10,K,L,J)
I $O(^DIC(19,I,10,K,L,-1))="" KILL ^DIC(19,I,10,K,L)
G L5
;
; ----------------------------------------------------------
;
HFFIX ; Fix dangling pointers on help frame file
NEW I,J,K,L,X,Y
S (X,I)=0
F S I=$O(^DIC(9.2,I)) Q:I'>0 I $D(^(I,2)) D HF1,HF2,HF3
D RSLT(X_" pointer"_$S(X=1:"",1:"s")_" fixed in your HELP FRAME file.")
Q
;
HF1 ;
S (Y,J)=0
F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,X=X+1 K ^DIC(9.2,I,2,J,0)
Q
;
HF2 ;
S (K,J)=0
F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 S K=J
S J=^DIC(9.2,I,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y
Q
;
HF3 ;
S K=":"
F S K=$O(^DIC(9.2,I,2,K)) Q:K="" S J=-1 F S J=$O(^DIC(9.2,I,2,K,J)) Q:J="" D HF4
Q
;
HF4 ;
S L=0
F S L=$O(^DIC(9.2,I,2,K,J,L)) Q:L'>0 I '$D(^DIC(9.2,I,2,L,0)) K ^DIC(9.2,I,2,K,J,L)
Q
;
; ----------------------------------------------------------
;
PFIX ;Kill any dangling pointers in the PROTOCOL File (#101)
NEW I,J,K,L,M,X,Y
S (I,X)=0 ;X=Total Deletions
P1 ;
S I=$O(^ORD(101,I))
I I>0 S (Y,J)=0 G P2 ;Loop through protocols
D RSLT(X_" pointer"_$S(X=1:"",1:"s")_" fixed in your PROTOCOL file.")
Q
;
P2 ;
S J=$O(^ORD(101,I,10,J))
I J>0 G PITEM ;Loop through items
I '$D(^ORD(101,I,10,0)) G P1
S (K,J)=0
F L=1:1 S J=$O(^ORD(101,I,10,J)) Q:J'>0 S K=J ;K=Last item
S J=^ORD(101,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
G PXREFS
;
PITEM ;
S K=+^ORD(101,I,10,J,0)
I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items
D RSLT("Protocol "_$P(^ORD(101,I,0),U,1)_" points to missing option "_K)
S X=X+1
KILL ^ORD(101,I,10,J) ;Kill invalid menu item
G P2
;
PXREFS ;
S K=":"
P3 ;
S K=$O(^ORD(101,I,10,K))
I K="" G P1 ;Loop through cross references
S L=-1
P4 ;
S L=$O(^ORD(101,I,10,K,L))
I L="" G P3
S J=0
P5 ;
S J=$O(^ORD(101,I,10,K,L,J))
I J'>0 G P4
I '$D(^ORD(101,I,10,J,0)) G PKILLXR ;kill xref to invalid item
P6 ;
S M=^ORD(101,I,10,J,0)
I (M=L)!(M[L_"^") G P5
PKILLXR ;
KILL ^ORD(101,I,10,K,L,J)
I $O(^ORD(101,I,10,K,L,-1))="" KILL ^ORD(101,I,10,K,L)
G P5
;
RSLT(%) S ^(0)=$G(^TMP("XBDANGLE",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
;
;
INIT ; Set up.
NEW XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("XBDANGLE",$J)
Q
;
MAIL ; Send a note to local programmers 'bout these results.
S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""XBDANGLE"",$J,",XMY(DUZ)=""
F %="XUPROGMODE" D SINGLE(%)
D ^XMD
Q
;
EXIT ;
KILL ^TMP("XBDANGLE",$J)
I $D(ZTQUEUED) S ZTREQ="@" Q
Q
;
SINGLE(K) ; Get holders of a single key K.
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
XBDANGLE ;IHS/SET/GTH - Q'ABLE CLEANUP DANGLING POINTERS OPTION HELP FRAME PROTOCOL FILES ; [ 10/29/2002 7:42 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
+2 ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cleanup dangling pointers.
+3 ;
+4 ; This utility can be scheduled to run via TaskMan.
+5 ;
+6 ; Actions are delivered to XUPROG key holders via MailMan.
+7 ;
+8 ; You can also run this interactively, but you'll still
+9 ; get the MailMan note, even after the interactive run.
+10 ;
+11 ; Thanks to the VA for the original interactive routine, XQ3.
+12 ;
+13 DO INIT
+14 DO OFIX
DO HFFIX
DO PFIX
+15 DO MAIL
+16 DO EXIT
+17 QUIT
+18 ;
+19 ; ----------------------------------------------------------
+20 ;
OFIX ;Kill any dangling pointers in the OPTION File (#19)
+1 NEW I,J,K,L,M,X,Y
+2 ;X=Total Deletions
SET (I,X)=0
L1 ;
+1 SET I=$ORDER(^DIC(19,I))
+2 ;Loop through menus
IF I>0
SET (Y,J)=0
GOTO L2
+3 DO RSLT(X_" pointer"_$SELECT(X=1:"",1:"s")_" fixed in your OPTION file.")
+4 QUIT
+5 ;
L2 ;
+1 SET J=$ORDER(^DIC(19,I,10,J))
+2 ;Loop through menu items
IF J>0
GOTO ITEM
+3 IF '$DATA(^DIC(19,I,10,0))
GOTO L1
+4 SET (K,J)=0
+5 ;K=Last item
FOR L=1:1
SET J=$ORDER(^DIC(19,I,10,J))
IF J'>0
QUIT
SET K=J
+6 ;fix counters
SET J=^DIC(19,I,10,0)
SET ^(0)=$PIECE(J,"^",1,2)_"^"_K_"^"_Y
+7 GOTO XREFS
+8 ;
ITEM ;
+1 SET K=+^DIC(19,I,10,J,0)
+2 ;Y=No. of items
IF $DATA(^DIC(19,K,0))
SET Y=Y+1
GOTO L2
+3 DO RSLT("Option "_$PIECE(^DIC(19,I,0),U,1)_" points to missing option "_K)
+4 SET X=X+1
+5 ;Kill invalid menu item
KILL ^DIC(19,I,10,J)
+6 GOTO L2
+7 ;
XREFS ;
+1 SET K=":"
L3 ;
+1 SET K=$ORDER(^DIC(19,I,10,K))
+2 ;Loop through cross references
IF K=""
GOTO L1
+3 SET L=-1
L4 ;
+1 SET L=$ORDER(^DIC(19,I,10,K,L))
+2 IF L=""
GOTO L3
+3 SET J=0
L5 ;
+1 SET J=$ORDER(^DIC(19,I,10,K,L,J))
+2 IF J'>0
GOTO L4
+3 ;kill xref to invalid item
IF '$DATA(^DIC(19,I,10,J,0))
GOTO KILLXR
L6 ;
+1 SET M=^DIC(19,I,10,J,0)
+2 IF (M=L)!(M[L_"^")
GOTO L5
KILLXR ;
+1 KILL ^DIC(19,I,10,K,L,J)
+2 IF $ORDER(^DIC(19,I,10,K,L,-1))=""
KILL ^DIC(19,I,10,K,L)
+3 GOTO L5
+4 ;
+5 ; ----------------------------------------------------------
+6 ;
HFFIX ; Fix dangling pointers on help frame file
+1 NEW I,J,K,L,X,Y
+2 SET (X,I)=0
+3 FOR
SET I=$ORDER(^DIC(9.2,I))
IF I'>0
QUIT
IF $DATA(^(I,2))
DO HF1
DO HF2
DO HF3
+4 DO RSLT(X_" pointer"_$SELECT(X=1:"",1:"s")_" fixed in your HELP FRAME file.")
+5 QUIT
+6 ;
HF1 ;
+1 SET (Y,J)=0
+2 FOR
SET J=$ORDER(^DIC(9.2,I,2,J))
IF J'>0
QUIT
IF $DATA(^(J,0))
SET K=$PIECE(^(0),U,2)
SET Y=Y+1
IF $LENGTH(K)
IF '$DATA(^DIC(9.2,K))
SET Y=Y-1
SET X=X+1
KILL ^DIC(9.2,I,2,J,0)
+3 QUIT
+4 ;
HF2 ;
+1 SET (K,J)=0
+2 FOR
SET J=$ORDER(^DIC(9.2,I,2,J))
IF J'>0
QUIT
SET K=J
+3 SET J=^DIC(9.2,I,2,0)
SET ^(0)=$PIECE(J,U,1,2)_U_K_U_Y
+4 QUIT
+5 ;
HF3 ;
+1 SET K=":"
+2 FOR
SET K=$ORDER(^DIC(9.2,I,2,K))
IF K=""
QUIT
SET J=-1
FOR
SET J=$ORDER(^DIC(9.2,I,2,K,J))
IF J=""
QUIT
DO HF4
+3 QUIT
+4 ;
HF4 ;
+1 SET L=0
+2 FOR
SET L=$ORDER(^DIC(9.2,I,2,K,J,L))
IF L'>0
QUIT
IF '$DATA(^DIC(9.2,I,2,L,0))
KILL ^DIC(9.2,I,2,K,J,L)
+3 QUIT
+4 ;
+5 ; ----------------------------------------------------------
+6 ;
PFIX ;Kill any dangling pointers in the PROTOCOL File (#101)
+1 NEW I,J,K,L,M,X,Y
+2 ;X=Total Deletions
SET (I,X)=0
P1 ;
+1 SET I=$ORDER(^ORD(101,I))
+2 ;Loop through protocols
IF I>0
SET (Y,J)=0
GOTO P2
+3 DO RSLT(X_" pointer"_$SELECT(X=1:"",1:"s")_" fixed in your PROTOCOL file.")
+4 QUIT
+5 ;
P2 ;
+1 SET J=$ORDER(^ORD(101,I,10,J))
+2 ;Loop through items
IF J>0
GOTO PITEM
+3 IF '$DATA(^ORD(101,I,10,0))
GOTO P1
+4 SET (K,J)=0
+5 ;K=Last item
FOR L=1:1
SET J=$ORDER(^ORD(101,I,10,J))
IF J'>0
QUIT
SET K=J
+6 ;fix counters
SET J=^ORD(101,I,10,0)
SET ^(0)=$PIECE(J,"^",1,2)_"^"_K_"^"_Y
+7 GOTO PXREFS
+8 ;
PITEM ;
+1 SET K=+^ORD(101,I,10,J,0)
+2 ;Y=No. of items
IF $DATA(^ORD(101,K,0))
SET Y=Y+1
GOTO P2
+3 DO RSLT("Protocol "_$PIECE(^ORD(101,I,0),U,1)_" points to missing option "_K)
+4 SET X=X+1
+5 ;Kill invalid menu item
KILL ^ORD(101,I,10,J)
+6 GOTO P2
+7 ;
PXREFS ;
+1 SET K=":"
P3 ;
+1 SET K=$ORDER(^ORD(101,I,10,K))
+2 ;Loop through cross references
IF K=""
GOTO P1
+3 SET L=-1
P4 ;
+1 SET L=$ORDER(^ORD(101,I,10,K,L))
+2 IF L=""
GOTO P3
+3 SET J=0
P5 ;
+1 SET J=$ORDER(^ORD(101,I,10,K,L,J))
+2 IF J'>0
GOTO P4
+3 ;kill xref to invalid item
IF '$DATA(^ORD(101,I,10,J,0))
GOTO PKILLXR
P6 ;
+1 SET M=^ORD(101,I,10,J,0)
+2 IF (M=L)!(M[L_"^")
GOTO P5
PKILLXR ;
+1 KILL ^ORD(101,I,10,K,L,J)
+2 IF $ORDER(^ORD(101,I,10,K,L,-1))=""
KILL ^ORD(101,I,10,K,L)
+3 GOTO P5
+4 ;
RSLT(%) SET ^(0)=$GET(^TMP("XBDANGLE",$JOB,0))+1
SET ^(^(0))=%
IF '$DATA(ZTQUEUED)
WRITE !,%
QUIT
+1 ;
+2 ;
INIT ; Set up.
+1 NEW XMSUB,XMDUZ,XMTEXT,XMY
+2 KILL ^TMP("XBDANGLE",$JOB)
+3 QUIT
+4 ;
MAIL ; Send a note to local programmers 'bout these results.
+1 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",4,99)
SET XMDUZ=$GET(DUZ,.5)
SET XMTEXT="^TMP(""XBDANGLE"",$J,"
SET XMY(DUZ)=""
+2 FOR %="XUPROGMODE"
DO SINGLE(%)
+3 DO ^XMD
+4 QUIT
+5 ;
EXIT ;
+1 KILL ^TMP("XBDANGLE",$JOB)
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 QUIT
+4 ;
SINGLE(K) ; Get holders of a single key K.
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
+6 ;
