- 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 2
- ;;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
- 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 2
- +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