XQ33 ;SEA/AMF/JLI/MJM,ISD/HGW - REMOVE UNREFERENCED OPTIONS ;02/07/13 08:04
;;8.0;KERNEL;**49,73,46,614**;Jul 10, 1995;Build 12
;Per VHA Directive 2004-038, this routine should not be modified.
;
DUO ; Entry point to delete unreferenced options from the option file.
W !!,*7,"Do you want to delete unreferenced options" S %=2 D YN^DICN Q:%<0!(%=2) I '% W !,"Enter a 'Y' if you want an opportunity to delete orphan options which are not",!,"primary menus, secondary menus, or tasked." G DUO
K ^TMP($J) S IOP="HOME" D ^%ZIS K IOP S XQENT=0
R !!,"Select PACKAGE/OPTION name: ALL// ",X:DTIME S:'$T X=U S DIC=9.4,DIC(0)="EMZ" Q:X[U S:'$L(X) X="ALL"
I X="ALL" S XQS="@z",XQE="zzz" G GET
D ^DIC I Y>0 S XQS=$P(Y(0),U,2),XQE=XQS_"zzz" G GET
S DIC=19,DIC(0)="QEMZ" D ^DIC G:Y<0 DUO S XQE=$P(Y(0),U,1),XQS=$E(XQE,1,$L(XQE)-1)_$C($A($E(XQE,$L(XQE))-1))_"zzz"
GET W !,"Getting the list of unreferenced options..." D LP W ! I '$D(^TMP($J)) W "...NONE FOUND",! G OUT
S XQI=0 F XQII=0:1 S DIC="^DIC(19,",DR="",XQI=$O(^TMP($J,XQI)) Q:XQI'>0 S DA=XQI W @IOF K S D EN^DIQ D DUO1 Q:XQSTOP
G OUT
DUO1 ;
W !!,"Want to delete this option" S %=2,XQSTOP=0 D YN^DICN S:%<0 XQSTOP=1 Q:%<0!(%=2) I '% W !,"Enter a 'Y' if you want to remove this option from the option file" G DUO1
S DIK="^DIC(19," D ^DIK
Q
LP S XQUI=0,XQJ=XQS F S XQJ=$O(^DIC(19,"B",XQJ)) Q:XQJ=""!XQUI!(XQJ]XQE) D LP1
Q
LP1 S XQI=0 F S XQI=$O(^DIC(19,"B",XQJ,XQI)) Q:XQI'>0!XQUI D LP2
Q
LP2 I "BOQSX"[$P(^DIC(19,XQI,0),U,4) K XQFL Q ;Special options
S XQFL="" W:XQENT !,XQJ,?31 I '$D(^DIC(19,"AD",XQI)) W:XQENT "** no parents **" G PRI
K XQFL S (XQK,XQLEN,XQNM)=0
I XQENT F S XQK=$O(^DIC(19,"AD",XQI,XQK)) Q:XQK'>0 I $D(^DIC(19,XQK,0)) S L=$P(^DIC(19,XQK,0),U,1) S:XQLEN+$L(L)+2>34 XQLEN=0 W:'XQLEN&XQNM !?31 W:XQNM&XQLEN ", " W $P(^DIC(19,XQK,0),U,1) S XQLEN=XQLEN+$L(L)+2,XQNM=XQNM+1
PRI ;
I $D(^VA(200,"AP",XQI)) W:XQENT ?65,"-P-" K XQFL ;Primary Menu
I $D(^VA(200,"AD",XQI)) W:XQENT ?70,"-S-" K XQFL ;Secondary Menu
I $D(^DIC(19,XQI,200.9)),^(200.9)["y" W:XQENT&($P(^(200.9),U)["y") ?75,"-T-" K XQFL ;Taskman or don't delete
E I $D(^DIC(19.2,"B",XQI)) W:XQENT ?75,"-T-" K XQFL ;Taskman
I $D(XQFL) S ^TMP($J,XQI)=""
Q
OUT D ^%ZISC
K XQUI,XQJ,XQS,XQE,XQK,XQLEN,XQNM,XQI,I,J,K,C,L,DIC,POP,X,XQDSH,XQENT,XQHDR,XQP,Y,ZISI,ZTDTH,ZTSAVE,ZTRTN,ZTDESC,%A1,S,XQFL
K %Y,A,D0,D1,DA,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DR,DX,XQSTOP
Q
LIST ; Entry point to list unreferenced options from the OPTION file (#19).
; ZEXCEPT: XUAXQE,XUAXQS ;global within this routine
W !!,"LIST UNREFERENCED OPTIONS",!!,"Print unreferenced options for a selected package."
S IOP="HOME" D ^%ZIS K IOP
R !!,"Select PACKAGE/OPTION name: ALL// ",X:DTIME S:'$T X=U S DIC=9.4,DIC(0)="EMZ" Q:X[U S:'$L(X) X="ALL"
I X="ALL" S XUAXQS="@z",XUAXQE="zzz" G QUEUE
D ^DIC I Y>0 S XUAXQS=$P(Y(0),U,2),XUAXQE=XUAXQS_"zzz" G QUEUE
S DIC=19,DIC(0)="QEMZ"
D ^DIC G:Y<0 EXIT
S XUAXQE=$P(Y(0),U,1),XUAXQS=$E(XUAXQE,1,$L(XUAXQE)-1)_$C($A($E(XUAXQE,$L(XUAXQE))-1))_"zzz"
QUEUE ;
S %ZIS="MQ" K IOP,ZTIO,ZTSAVE D ^%ZIS G EXIT:POP
I IO'=IO(0) S ZTSAVE("XUA*")="",ZTRTN="START^XQ33",ZTDESC="List Unreferenced Options" D ^%ZTLOAD,^%ZISC,EXIT Q
START ;
N XUATDY,XUAHDR,XUANAME,XUAIEN
S U="^"
S Y=DT D DD^%DT S XUATDY=Y
S XUAHDR(1)="LIST UNREFERENCED OPTIONS "_XUATDY
S XUAHDR(2)="Option Name Menu Text"
S XUAHDR(3)=$$REPEAT^XLFSTR("-",80)
K ^TMP($J)
D GETO
D PRINT
D EXIT
Q
GETO ; Gets the unreferenced option
; ZEXCEPT: XUAFLAG,XUAIEN,XUANAME,XUAXQS ;global within this routine
W !,"Getting the list of unreferenced options..."
; Build the list
S XUANAME=XUAXQS
F S XUANAME=$O(^DIC(19,"B",XUANAME)) Q:XUANAME=""!(XUANAME]XUAXQE) D
.S XUAIEN=0
.F S XUAIEN=$O(^DIC(19,"B",XUANAME,XUAIEN)) Q:XUAIEN'>0 D
..I "BOQSX"[$P($G(^DIC(19,XUAIEN,0)),U,4) K XUAFLAG Q
..S XUAFLAG="DATA"
..I $D(^DIC(19,"AD",XUAIEN)) K XUAFLAG ;Menu Item
..I $D(^VA(200,"AP",XUAIEN)) K XUAFLAG ;Primary Menu
..I $D(^VA(200,"AD",XUAIEN)) K XUAFLAG ;Secondary Menu
..I $D(^DIC(19,XUAIEN,200.9)),^(200.9)["y" K XUAFLAG ;Taskman or don't delete
..E I $D(^DIC(19.2,"B",XUAIEN)) K XUAFLAG ;Taskman
..I $D(XUAFLAG) S ^TMP($J,XUANAME)=XUAIEN
Q
PRINT ; Print the list
; ZEXCEPT: I,IOF,IOSL,IOST,X,XUAIEN,XUANAME ;global within this routine
N END,XUAPAGE,XUALINE,XUATEXT
S END=0,XUAPAGE=1
D HEAD
I '$D(^TMP($J)) W "...NONE FOUND",! Q
S XUANAME=""
F S XUANAME=$O(^TMP($J,XUANAME)) Q:XUANAME=""!END D
.S XUAIEN=^TMP($J,XUANAME)
.S XUATEXT=$P($G(^DIC(19,XUAIEN,0)),U,2)
.W !,XUANAME,?32,$E(XUATEXT,1,47)
.S XUALINE=XUALINE+1
.I XUALINE=IOSL D
..I $E(IOST,1,2)'="C-" D
...W @IOF
...S XUAPAGE=XUAPAGE+1 D HEAD
..I $E(IOST,1,2)="C-" D
...W !,"Press RETURN to continue or '^' to exit: "
...R X:DTIME
...S END='$T!(X="^") Q:END
...S XUAPAGE=XUAPAGE+1 D HEAD
I $E(IOST,1,2)="C-" D
.S XUALINE=XUALINE+1
.F I=XUALINE:1:IOSL W !
.W !,"Press RETURN to exit: "
.R X:DTIME
Q
HEAD ;
; ZEXCEPT: XUAHDR,XUALINE,XUAPAGE ;used within this routine
W !,XUAHDR(1)," PAGE ",XUAPAGE,!,XUAHDR(2),!,XUAHDR(3)
S XUALINE=4
Q
EXIT ;
D ^%ZISC
K XUAFLAG
K I,J,K,C,L,DIC,POP,X,Y,ZISI,ZTDTH,ZTSAVE,ZTRTN,ZTDESC,%A1,S
K %Y,A,D0,D1,DA,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DR,DX
Q
XQ33 ;SEA/AMF/JLI/MJM,ISD/HGW - REMOVE UNREFERENCED OPTIONS ;02/07/13 08:04
+1 ;;8.0;KERNEL;**49,73,46,614**;Jul 10, 1995;Build 12
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
DUO ; Entry point to delete unreferenced options from the option file.
+1 WRITE !!,*7,"Do you want to delete unreferenced options"
SET %=2
DO YN^DICN
IF %<0!(%=2)
QUIT
IF '%
WRITE !,"Enter a 'Y' if you want an opportunity to delete orphan options which are not",!,"primary menus, secondary menus, or tasked."
GOTO DUO
+2 KILL ^TMP($JOB)
SET IOP="HOME"
DO ^%ZIS
KILL IOP
SET XQENT=0
+3 READ !!,"Select PACKAGE/OPTION name: ALL// ",X:DTIME
IF '$TEST
SET X=U
SET DIC=9.4
SET DIC(0)="EMZ"
IF X[U
QUIT
IF '$LENGTH(X)
SET X="ALL"
+4 IF X="ALL"
SET XQS="@z"
SET XQE="zzz"
GOTO GET
+5 DO ^DIC
IF Y>0
SET XQS=$PIECE(Y(0),U,2)
SET XQE=XQS_"zzz"
GOTO GET
+6 SET DIC=19
SET DIC(0)="QEMZ"
DO ^DIC
IF Y<0
GOTO DUO
SET XQE=$PIECE(Y(0),U,1)
SET XQS=$EXTRACT(XQE,1,$LENGTH(XQE)-1)_$CHAR($ASCII($EXTRACT(XQE,$LENGTH(XQE))-1))_"zzz"
GET WRITE !,"Getting the list of unreferenced options..."
DO LP
WRITE !
IF '$DATA(^TMP($JOB))
WRITE "...NONE FOUND",!
GOTO OUT
+1 SET XQI=0
FOR XQII=0:1
SET DIC="^DIC(19,"
SET DR=""
SET XQI=$ORDER(^TMP($JOB,XQI))
IF XQI'>0
QUIT
SET DA=XQI
WRITE @IOF
KILL S
DO EN^DIQ
DO DUO1
IF XQSTOP
QUIT
+2 GOTO OUT
DUO1 ;
+1 WRITE !!,"Want to delete this option"
SET %=2
SET XQSTOP=0
DO YN^DICN
IF %<0
SET XQSTOP=1
IF %<0!(%=2)
QUIT
IF '%
WRITE !,"Enter a 'Y' if you want to remove this option from the option file"
GOTO DUO1
+2 SET DIK="^DIC(19,"
DO ^DIK
+3 QUIT
LP SET XQUI=0
SET XQJ=XQS
FOR
SET XQJ=$ORDER(^DIC(19,"B",XQJ))
IF XQJ=""!XQUI!(XQJ]XQE)
QUIT
DO LP1
+1 QUIT
LP1 SET XQI=0
FOR
SET XQI=$ORDER(^DIC(19,"B",XQJ,XQI))
IF XQI'>0!XQUI
QUIT
DO LP2
+1 QUIT
LP2 ;Special options
IF "BOQSX"[$PIECE(^DIC(19,XQI,0),U,4)
KILL XQFL
QUIT
+1 SET XQFL=""
IF XQENT
WRITE !,XQJ,?31
IF '$DATA(^DIC(19,"AD",XQI))
IF XQENT
WRITE "** no parents **"
GOTO PRI
+2 KILL XQFL
SET (XQK,XQLEN,XQNM)=0
+3 IF XQENT
FOR
SET XQK=$ORDER(^DIC(19,"AD",XQI,XQK))
IF XQK'>0
QUIT
IF $DATA(^DIC(19,XQK,0))
SET L=$PIECE(^DIC(19,XQK,0),U,1)
IF XQLEN+$LENGTH(L)+2>34
SET XQLEN=0
IF 'XQLEN&XQNM
WRITE !?31
IF XQNM&XQLEN
WRITE ", "
WRITE $PIECE(^DIC(19,XQK,0),U,1)
SET XQLEN=XQLEN+$LENGTH(L)+2
SET XQNM=XQNM+1
PRI ;
+1 ;Primary Menu
IF $DATA(^VA(200,"AP",XQI))
IF XQENT
WRITE ?65,"-P-"
KILL XQFL
+2 ;Secondary Menu
IF $DATA(^VA(200,"AD",XQI))
IF XQENT
WRITE ?70,"-S-"
KILL XQFL
+3 ;Taskman or don't delete
IF $DATA(^DIC(19,XQI,200.9))
IF ^(200.9)["y"
IF XQENT&($PIECE(^(200.9),U)["y")
WRITE ?75,"-T-"
KILL XQFL
+4 ;Taskman
IF '$TEST
IF $DATA(^DIC(19.2,"B",XQI))
IF XQENT
WRITE ?75,"-T-"
KILL XQFL
+5 IF $DATA(XQFL)
SET ^TMP($JOB,XQI)=""
+6 QUIT
OUT DO ^%ZISC
+1 KILL XQUI,XQJ,XQS,XQE,XQK,XQLEN,XQNM,XQI,I,J,K,C,L,DIC,POP,X,XQDSH,XQENT,XQHDR,XQP,Y,ZISI,ZTDTH,ZTSAVE,ZTRTN,ZTDESC,%A1,S,XQFL
+2 KILL %Y,A,D0,D1,DA,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DR,DX,XQSTOP
+3 QUIT
LIST ; Entry point to list unreferenced options from the OPTION file (#19).
+1 ; ZEXCEPT: XUAXQE,XUAXQS ;global within this routine
+2 WRITE !!,"LIST UNREFERENCED OPTIONS",!!,"Print unreferenced options for a selected package."
+3 SET IOP="HOME"
DO ^%ZIS
KILL IOP
+4 READ !!,"Select PACKAGE/OPTION name: ALL// ",X:DTIME
IF '$TEST
SET X=U
SET DIC=9.4
SET DIC(0)="EMZ"
IF X[U
QUIT
IF '$LENGTH(X)
SET X="ALL"
+5 IF X="ALL"
SET XUAXQS="@z"
SET XUAXQE="zzz"
GOTO QUEUE
+6 DO ^DIC
IF Y>0
SET XUAXQS=$PIECE(Y(0),U,2)
SET XUAXQE=XUAXQS_"zzz"
GOTO QUEUE
+7 SET DIC=19
SET DIC(0)="QEMZ"
+8 DO ^DIC
IF Y<0
GOTO EXIT
+9 SET XUAXQE=$PIECE(Y(0),U,1)
SET XUAXQS=$EXTRACT(XUAXQE,1,$LENGTH(XUAXQE)-1)_$CHAR($ASCII($EXTRACT(XUAXQE,$LENGTH(XUAXQE))-1))_"zzz"
QUEUE ;
+1 SET %ZIS="MQ"
KILL IOP,ZTIO,ZTSAVE
DO ^%ZIS
IF POP
GOTO EXIT
+2 IF IO'=IO(0)
SET ZTSAVE("XUA*")=""
SET ZTRTN="START^XQ33"
SET ZTDESC="List Unreferenced Options"
DO ^%ZTLOAD
DO ^%ZISC
DO EXIT
QUIT
START ;
+1 NEW XUATDY,XUAHDR,XUANAME,XUAIEN
+2 SET U="^"
+3 SET Y=DT
DO DD^%DT
SET XUATDY=Y
+4 SET XUAHDR(1)="LIST UNREFERENCED OPTIONS "_XUATDY
+5 SET XUAHDR(2)="Option Name Menu Text"
+6 SET XUAHDR(3)=$$REPEAT^XLFSTR("-",80)
+7 KILL ^TMP($JOB)
+8 DO GETO
+9 DO PRINT
+10 DO EXIT
+11 QUIT
GETO ; Gets the unreferenced option
+1 ; ZEXCEPT: XUAFLAG,XUAIEN,XUANAME,XUAXQS ;global within this routine
+2 WRITE !,"Getting the list of unreferenced options..."
+3 ; Build the list
+4 SET XUANAME=XUAXQS
+5 FOR
SET XUANAME=$ORDER(^DIC(19,"B",XUANAME))
IF XUANAME=""!(XUANAME]XUAXQE)
QUIT
Begin DoDot:1
+6 SET XUAIEN=0
+7 FOR
SET XUAIEN=$ORDER(^DIC(19,"B",XUANAME,XUAIEN))
IF XUAIEN'>0
QUIT
Begin DoDot:2
+8 IF "BOQSX"[$PIECE($GET(^DIC(19,XUAIEN,0)),U,4)
KILL XUAFLAG
QUIT
+9 SET XUAFLAG="DATA"
+10 ;Menu Item
IF $DATA(^DIC(19,"AD",XUAIEN))
KILL XUAFLAG
+11 ;Primary Menu
IF $DATA(^VA(200,"AP",XUAIEN))
KILL XUAFLAG
+12 ;Secondary Menu
IF $DATA(^VA(200,"AD",XUAIEN))
KILL XUAFLAG
+13 ;Taskman or don't delete
IF $DATA(^DIC(19,XUAIEN,200.9))
IF ^(200.9)["y"
KILL XUAFLAG
+14 ;Taskman
IF '$TEST
IF $DATA(^DIC(19.2,"B",XUAIEN))
KILL XUAFLAG
+15 IF $DATA(XUAFLAG)
SET ^TMP($JOB,XUANAME)=XUAIEN
End DoDot:2
End DoDot:1
+16 QUIT
PRINT ; Print the list
+1 ; ZEXCEPT: I,IOF,IOSL,IOST,X,XUAIEN,XUANAME ;global within this routine
+2 NEW END,XUAPAGE,XUALINE,XUATEXT
+3 SET END=0
SET XUAPAGE=1
+4 DO HEAD
+5 IF '$DATA(^TMP($JOB))
WRITE "...NONE FOUND",!
QUIT
+6 SET XUANAME=""
+7 FOR
SET XUANAME=$ORDER(^TMP($JOB,XUANAME))
IF XUANAME=""!END
QUIT
Begin DoDot:1
+8 SET XUAIEN=^TMP($JOB,XUANAME)
+9 SET XUATEXT=$PIECE($GET(^DIC(19,XUAIEN,0)),U,2)
+10 WRITE !,XUANAME,?32,$EXTRACT(XUATEXT,1,47)
+11 SET XUALINE=XUALINE+1
+12 IF XUALINE=IOSL
Begin DoDot:2
+13 IF $EXTRACT(IOST,1,2)'="C-"
Begin DoDot:3
+14 WRITE @IOF
+15 SET XUAPAGE=XUAPAGE+1
DO HEAD
End DoDot:3
+16 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:3
+17 WRITE !,"Press RETURN to continue or '^' to exit: "
+18 READ X:DTIME
+19 SET END='$TEST!(X="^")
IF END
QUIT
+20 SET XUAPAGE=XUAPAGE+1
DO HEAD
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+22 SET XUALINE=XUALINE+1
+23 FOR I=XUALINE:1:IOSL
WRITE !
+24 WRITE !,"Press RETURN to exit: "
+25 READ X:DTIME
End DoDot:1
+26 QUIT
HEAD ;
+1 ; ZEXCEPT: XUAHDR,XUALINE,XUAPAGE ;used within this routine
+2 WRITE !,XUAHDR(1)," PAGE ",XUAPAGE,!,XUAHDR(2),!,XUAHDR(3)
+3 SET XUALINE=4
+4 QUIT
EXIT ;
+1 DO ^%ZISC
+2 KILL XUAFLAG
+3 KILL I,J,K,C,L,DIC,POP,X,Y,ZISI,ZTDTH,ZTSAVE,ZTRTN,ZTDESC,%A1,S
+4 KILL %Y,A,D0,D1,DA,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DR,DX
+5 QUIT
