XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;12/08/09
;;8.0;KERNEL;**80,501,538**;Jul 10, 1995;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
ENASK ;Ask to fix up dirty OPTION/HELP FRAME File
N IX,XUT,J,K,XQFL,X
I '$D(%) W !,$C(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$C(7),! Q
S XQFL=$S(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME")
W !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File? Y// " R X:$S($D(DTIME):DTIME,1:300) I '$T Q
W ! I X="" S X="Y"
I X["?" G SYNTAX
I X["^" S X="^" Q
STRIP I X'="",X'?1A.E S X=$E(X,2,256) G STRIP
S X=$E(X,1) I X="" G SYNTAX
I "Nn"[X S X="N" Q
I "Yy"[X W !,"PLEASE WAIT while I check this out . . . " G REMOVE
SYNTAX W ! I X'["?" W ?11,"I'm sorry, but I don't understand your answer. Please"
W !,"Enter: YES (or press the RETURN key) if you want me to remove from"
W !,?11,"your ",XQFL," File any pointers left over from incompletely"
W !,?11,"deleted ",XQFL,". If such pointers do exist and are not"
W !,?11,"removed, the ",XQFL," File (i.e. the menus) could become"
W !,?11,"messed up by an INIT."
W !!,"Enter: NO or ^ to continue on without effecting the ",XQFL," File."
W ! G ENASK
REMOVE D:%=1 OPFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'XUT W "(no bad pointers)."
E W "now (",XUT," pointer" W:XUT>1 "s" W " fixed)."
W ! S X="Y"
Q
OPFIX ;Kill any dangling pointers in the OPTION File (#19)
N %,IX,J,XQ3
S (IX,XUT)=0 ;XUT=Total Deletions
F S IX=$O(^DIC(19,IX)) Q:'IX W:'(IX#100) ". " S (XQ3,J)=0 D L2 ;Loop through Options
D NPF
Q
L2 ;One Option
I '$D(^DIC(19,IX,10,0)) Q ;Not a Menu
K ^DIC(19,IX,10,"B") ;Rebuild "B" X-ref
F S J=$O(^DIC(19,IX,10,J)) Q:'J D ITEM ;Loop through menu items
S (K,J)=0 F S J=$O(^DIC(19,IX,10,J)) Q:J'>0 S K=J ;K=Last item
S J=^DIC(19,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_XQ3 ;fix counters
Q
;
ITEM ;One Menu item
N DA,DIK
S K=+^DIC(19,IX,10,J,0)
I $D(^DIC(19,K,0)) S XQ3=XQ3+1,^DIC(19,IX,10,"B",K,J)="" Q ;Y=No. of items
W !,"Option ",$P(^DIC(19,IX,0),U,1)," points to missing option ",K
;S XUT=XUT+1 K ^DIC(19,IX,10,J) ;Kill invalid menu item
S XUT=XUT+1,DIK="^DIC(19,DA(1),10,",DA=J,DA(1)=IX D ^DIK ;Trigger Menu-rebuild
Q
;
NPF ;Fix the New Person File Option Pointers
N IX,I2,J,P,DIK,DIE,DR,DA,XUT
S (XUT,IX)=0
F S IX=$O(^VA(200,IX)) Q:'IX D
. S P=+$G(^VA(200,IX,201))
. I P,'$D(^DIC(19,P,0)) D
. . W !,"User: ",$P(^VA(200,IX,0),U),", Primary Menu points to missing option ",P
. . S XUT=XUT+1,DIE="^VA(200,",DA=IX,DR="201///@" D ^DIE
. . Q
. S I2=0
. F S I2=$O(^VA(200,IX,203,I2)) Q:'I2 D
. . S P=+$G(^VA(200,IX,203,I2,0))
. . I P,'$D(^DIC(19,P,0)) D
. . . W !,"User: ",$P(^VA(200,IX,0),U),", Secondary Menu points to missing option ",P
. . . S XUT=XUT+1,DIK="^VA(200,DA(1),203,",DA=I2,DA(1)=IX D ^DIK
. . . Q
. . Q
. S I2=0
. F S I2=$O(^VA(200,IX,19.5,I2)) Q:'I2 D
. . S P=+$G(^VA(200,IX,19.5,I2,0))
. . I P,'$D(^DIC(19,P,0)) D
. . . W !,"User: ",$P(^VA(200,IX,0),U),", Delegated option points to missing option ",P
. . . S XUT=XUT+1,DIK="^VA(200,DA(1),19.5,",DA=I2,DA(1)=IX D ^DIK
. . . Q
. . Q
. Q
I XUT W !,"Menu pointers fixed."
Q
HFFIX ; Fix dangling pointers on help frame file
N %
S (XUT,IX)=0 F S IX=$O(^DIC(9.2,IX)) Q:IX'>0 I $D(^(IX,2)) D HF1,HF2,HF3
Q
HF1 S (Y,J)=0 F S J=$O(^DIC(9.2,IX,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,XUT=XUT+1 K ^DIC(9.2,IX,2,J,0)
Q
HF2 S (K,J)=0 F S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0 S K=J
S J=^DIC(9.2,IX,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y
Q
HF3 S K=":" F S K=$O(^DIC(9.2,IX,2,K)) Q:K="" S J=-1 F S J=$O(^DIC(9.2,IX,2,K,J)) Q:J="" D HF4
Q
HF4 S JJ=0 F S JJ=$O(^DIC(9.2,IX,2,K,J,JJ)) Q:JJ'>0 I '$D(^DIC(9.2,IX,2,JJ,0)) K ^DIC(9.2,IX,2,K,J,JJ)
Q
PFIX ;Kill any dangling pointers in the PROTOCOL File (#101)
N %
S (IX,XUT)=0 ;XUT=Total Deletions
P1 S IX=$O(^ORD(101,IX)) I IX>0 S (Y,J)=0 G P2 ;Loop through protocols
Q
P2 S J=$O(^ORD(101,IX,10,J)) I J>0 G PITEM ;Loop through items
I '$D(^ORD(101,IX,10,0)) G P1
S (K,J)=0 F L=1:1 S J=$O(^ORD(101,IX,10,J)) Q:J'>0 S K=J ;K=Last item
S J=^ORD(101,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
G PXREFS
PITEM S K=+^ORD(101,IX,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items
W !,"Protocol ",$P(^ORD(101,IX,0),U,1)," points to missing protocol ",K
;S XUT=XUT+1 K ^ORD(101,IX,10,J) ;Kill invalid menu item
S XUT=XUT+1,DIK="^ORD(101,IX,10,",DA=J,DA(1)=IX D ^DIK ;Delete invalid menu item
G P2
PXREFS S K=":"
P3 S K=$O(^ORD(101,IX,10,K)) I K="" G P1 ;Loop through cross references
S L=-1
P4 S L=$O(^ORD(101,IX,10,K,L)) I L="" G P3
S J=0
P5 S J=$O(^ORD(101,IX,10,K,L,J)) I J'>0 G P4
I '$D(^ORD(101,IX,10,J,0)) G PKILLXR ;kill xref to invalid item
P6 S M=^ORD(101,IX,10,J,0) I (M=L)!(M[L_"^") G P5
PKILLXR K ^ORD(101,IX,10,K,L,J) I $O(^ORD(101,IX,10,K,L,-1))="" K ^ORD(101,IX,10,K,L)
G P5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ3 5071 printed Dec 13, 2024@02:04:43 Page 2
XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;12/08/09
+1 ;;8.0;KERNEL;**80,501,538**;Jul 10, 1995;Build 1
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
ENASK ;Ask to fix up dirty OPTION/HELP FRAME File
+1 NEW IX,XUT,J,K,XQFL,X
+2 IF '$DATA(%)
WRITE !,$CHAR(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$CHAR(7),!
QUIT
+3 SET XQFL=$SELECT(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME")
+4 WRITE !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File? Y// "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
QUIT
+5 WRITE !
IF X=""
SET X="Y"
+6 IF X["?"
GOTO SYNTAX
+7 IF X["^"
SET X="^"
QUIT
STRIP IF X'=""
IF X'?1A.E
SET X=$EXTRACT(X,2,256)
GOTO STRIP
+1 SET X=$EXTRACT(X,1)
IF X=""
GOTO SYNTAX
+2 IF "Nn"[X
SET X="N"
QUIT
+3 IF "Yy"[X
WRITE !,"PLEASE WAIT while I check this out . . . "
GOTO REMOVE
SYNTAX WRITE !
IF X'["?"
WRITE ?11,"I'm sorry, but I don't understand your answer. Please"
+1 WRITE !,"Enter: YES (or press the RETURN key) if you want me to remove from"
+2 WRITE !,?11,"your ",XQFL," File any pointers left over from incompletely"
+3 WRITE !,?11,"deleted ",XQFL,". If such pointers do exist and are not"
+4 WRITE !,?11,"removed, the ",XQFL," File (i.e. the menus) could become"
+5 WRITE !,?11,"messed up by an INIT."
+6 WRITE !!,"Enter: NO or ^ to continue on without effecting the ",XQFL," File."
+7 WRITE !
GOTO ENASK
REMOVE if %=1
DO OPFIX
if %=2
DO PFIX
if '%
DO HFFIX
WRITE !,"Your ",XQFL," File is OK "
IF 'XUT
WRITE "(no bad pointers)."
+1 IF '$TEST
WRITE "now (",XUT," pointer"
if XUT>1
WRITE "s"
WRITE " fixed)."
+2 WRITE !
SET X="Y"
+3 QUIT
OPFIX ;Kill any dangling pointers in the OPTION File (#19)
+1 NEW %,IX,J,XQ3
+2 ;XUT=Total Deletions
SET (IX,XUT)=0
+3 ;Loop through Options
FOR
SET IX=$ORDER(^DIC(19,IX))
if 'IX
QUIT
if '(IX#100)
WRITE ". "
SET (XQ3,J)=0
DO L2
+4 DO NPF
+5 QUIT
L2 ;One Option
+1 ;Not a Menu
IF '$DATA(^DIC(19,IX,10,0))
QUIT
+2 ;Rebuild "B" X-ref
KILL ^DIC(19,IX,10,"B")
+3 ;Loop through menu items
FOR
SET J=$ORDER(^DIC(19,IX,10,J))
if 'J
QUIT
DO ITEM
+4 ;K=Last item
SET (K,J)=0
FOR
SET J=$ORDER(^DIC(19,IX,10,J))
if J'>0
QUIT
SET K=J
+5 ;fix counters
SET J=^DIC(19,IX,10,0)
SET ^(0)=$PIECE(J,"^",1,2)_"^"_K_"^"_XQ3
+6 QUIT
+7 ;
ITEM ;One Menu item
+1 NEW DA,DIK
+2 SET K=+^DIC(19,IX,10,J,0)
+3 ;Y=No. of items
IF $DATA(^DIC(19,K,0))
SET XQ3=XQ3+1
SET ^DIC(19,IX,10,"B",K,J)=""
QUIT
+4 WRITE !,"Option ",$PIECE(^DIC(19,IX,0),U,1)," points to missing option ",K
+5 ;S XUT=XUT+1 K ^DIC(19,IX,10,J) ;Kill invalid menu item
+6 ;Trigger Menu-rebuild
SET XUT=XUT+1
SET DIK="^DIC(19,DA(1),10,"
SET DA=J
SET DA(1)=IX
DO ^DIK
+7 QUIT
+8 ;
NPF ;Fix the New Person File Option Pointers
+1 NEW IX,I2,J,P,DIK,DIE,DR,DA,XUT
+2 SET (XUT,IX)=0
+3 FOR
SET IX=$ORDER(^VA(200,IX))
if 'IX
QUIT
Begin DoDot:1
+4 SET P=+$GET(^VA(200,IX,201))
+5 IF P
IF '$DATA(^DIC(19,P,0))
Begin DoDot:2
+6 WRITE !,"User: ",$PIECE(^VA(200,IX,0),U),", Primary Menu points to missing option ",P
+7 SET XUT=XUT+1
SET DIE="^VA(200,"
SET DA=IX
SET DR="201///@"
DO ^DIE
+8 QUIT
End DoDot:2
+9 SET I2=0
+10 FOR
SET I2=$ORDER(^VA(200,IX,203,I2))
if 'I2
QUIT
Begin DoDot:2
+11 SET P=+$GET(^VA(200,IX,203,I2,0))
+12 IF P
IF '$DATA(^DIC(19,P,0))
Begin DoDot:3
+13 WRITE !,"User: ",$PIECE(^VA(200,IX,0),U),", Secondary Menu points to missing option ",P
+14 SET XUT=XUT+1
SET DIK="^VA(200,DA(1),203,"
SET DA=I2
SET DA(1)=IX
DO ^DIK
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 SET I2=0
+18 FOR
SET I2=$ORDER(^VA(200,IX,19.5,I2))
if 'I2
QUIT
Begin DoDot:2
+19 SET P=+$GET(^VA(200,IX,19.5,I2,0))
+20 IF P
IF '$DATA(^DIC(19,P,0))
Begin DoDot:3
+21 WRITE !,"User: ",$PIECE(^VA(200,IX,0),U),", Delegated option points to missing option ",P
+22 SET XUT=XUT+1
SET DIK="^VA(200,DA(1),19.5,"
SET DA=I2
SET DA(1)=IX
DO ^DIK
+23 QUIT
End DoDot:3
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 IF XUT
WRITE !,"Menu pointers fixed."
+27 QUIT
HFFIX ; Fix dangling pointers on help frame file
+1 NEW %
+2 SET (XUT,IX)=0
FOR
SET IX=$ORDER(^DIC(9.2,IX))
if IX'>0
QUIT
IF $DATA(^(IX,2))
DO HF1
DO HF2
DO HF3
+3 QUIT
HF1 SET (Y,J)=0
FOR
SET J=$ORDER(^DIC(9.2,IX,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 XUT=XUT+1
KILL ^DIC(9.2,IX,2,J,0)
+1 QUIT
HF2 SET (K,J)=0
FOR
SET J=$ORDER(^DIC(9.2,IX,2,J))
if J'>0
QUIT
SET K=J
+1 SET J=^DIC(9.2,IX,2,0)
SET ^(0)=$PIECE(J,U,1,2)_U_K_U_Y
+2 QUIT
HF3 SET K=":"
FOR
SET K=$ORDER(^DIC(9.2,IX,2,K))
if K=""
QUIT
SET J=-1
FOR
SET J=$ORDER(^DIC(9.2,IX,2,K,J))
if J=""
QUIT
DO HF4
+1 QUIT
HF4 SET JJ=0
FOR
SET JJ=$ORDER(^DIC(9.2,IX,2,K,J,JJ))
if JJ'>0
QUIT
IF '$DATA(^DIC(9.2,IX,2,JJ,0))
KILL ^DIC(9.2,IX,2,K,J,JJ)
+1 QUIT
PFIX ;Kill any dangling pointers in the PROTOCOL File (#101)
+1 NEW %
+2 ;XUT=Total Deletions
SET (IX,XUT)=0
P1 ;Loop through protocols
SET IX=$ORDER(^ORD(101,IX))
IF IX>0
SET (Y,J)=0
GOTO P2
+1 QUIT
P2 ;Loop through items
SET J=$ORDER(^ORD(101,IX,10,J))
IF J>0
GOTO PITEM
+1 IF '$DATA(^ORD(101,IX,10,0))
GOTO P1
+2 ;K=Last item
SET (K,J)=0
FOR L=1:1
SET J=$ORDER(^ORD(101,IX,10,J))
if J'>0
QUIT
SET K=J
+3 ;fix counters
SET J=^ORD(101,IX,10,0)
SET ^(0)=$PIECE(J,"^",1,2)_"^"_K_"^"_Y
+4 GOTO PXREFS
PITEM ;Y=No. of items
SET K=+^ORD(101,IX,10,J,0)
IF $DATA(^ORD(101,K,0))
SET Y=Y+1
GOTO P2
+1 WRITE !,"Protocol ",$PIECE(^ORD(101,IX,0),U,1)," points to missing protocol ",K
+2 ;S XUT=XUT+1 K ^ORD(101,IX,10,J) ;Kill invalid menu item
+3 ;Delete invalid menu item
SET XUT=XUT+1
SET DIK="^ORD(101,IX,10,"
SET DA=J
SET DA(1)=IX
DO ^DIK
+4 GOTO P2
PXREFS SET K=":"
P3 ;Loop through cross references
SET K=$ORDER(^ORD(101,IX,10,K))
IF K=""
GOTO P1
+1 SET L=-1
P4 SET L=$ORDER(^ORD(101,IX,10,K,L))
IF L=""
GOTO P3
+1 SET J=0
P5 SET J=$ORDER(^ORD(101,IX,10,K,L,J))
IF J'>0
GOTO P4
+1 ;kill xref to invalid item
IF '$DATA(^ORD(101,IX,10,J,0))
GOTO PKILLXR
P6 SET M=^ORD(101,IX,10,J,0)
IF (M=L)!(M[L_"^")
GOTO P5
PKILLXR KILL ^ORD(101,IX,10,K,L,J)
IF $ORDER(^ORD(101,IX,10,K,L,-1))=""
KILL ^ORD(101,IX,10,K,L)
+1 GOTO P5
