XQ33.m

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