XQ55.m

XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION;

 ;;8.0;KERNEL;**140,342,483,508**;Jul 10, 1995;Build 1

 ;;Per VHA Directive 2004-038, this routine should not be modified

INIT ;

 S XQDSH="-------------------------------------------------------------------------------"

 D ^XQDATE S XQDT=%Y

OPT W ! S DIC=19,DIC(0)="AEQM" D ^DIC G:Y=-1 OUT S XQOPT=+Y

MPAT W !!,"Show menu paths" S %=2 D YN^DICN G:%<0 OUT S XQMP=2-% I '% W !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option." G MPAT

 K ^TMP($J),XQR,XQP

 S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"'  ["_$P(K,U,1)_"]",XQSCD=0,XQCOM=0,XQNOPRNT=0

LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1

 G LOOP2

 Q

TREE S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0  S K=X(L) G:$D(XQR(K)) TREE S XQR(K)=""

TREE1 ;

 S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3)

 D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE

 Q:L=1  K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE

 Q

SETGLO ;

 S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_","

 S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_","

 S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_","

 S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV

 Q

LOOP2 ;

 S XQPA(0)=0,XQP=0 F  S XQP=$O(^TMP($J,XQP)) Q:XQP=""  S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS

 D USERS1 I XQNOPRNT G MUS ; 080115 - add in options from the common menu

 G LOOP3

USERS ;

 S XQU=0 F  S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0  I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU

 Q

USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu

 N XUCOMMON

 S XUCOMMON=$O(^DIC(19,"B","XUCOMMAND",0))

 S XQP=0 F  S XQP=$O(^TMP($J,XQP)) Q:XQP=""  S XQN=^TMP($J,XQP,0) F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  I $P($P(^TMP($J,XQP,J),U,2),",")=XUCOMMON D

 . D  Q:'Y

 . . W !,"***"

 . . W !,"*** This option is available from the 'SYSTEM COMMAND OPTIONS'  ***"

 . . W !,"*** (XUCOMMAND) menu available to all active users unless       ***"

 . . W !,"*** protected by a KEY - DO YOU REALLY WANT THE ENTIRE LIST     ***"

 . . W !,"*** OF THESE USERS???                                           ***",!

 . . N DIR S DIR(0)="Y" D ^DIR S:'Y XQNOPRNT=1 Q:'Y

 . . Q

 . S XQU=0,XQPS="(C)" F  S XQU=$O(^VA(200,XQU)) Q:XQU'>0  I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU),$$KEYCHECK() S II=1 D SETU

 Q

 ;

EACHU ;

 S II=1

 F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  I $$KEYCHECK() D SETU ; 080115

 Q

 ;

KEYCHECK() ; 080115 extracted common code

 ; returns 1 if user has access to the option, 0 if the user does not have access

 S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1

 I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0

 S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1

 I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0

 Q XQGO

 ;

SETU ;

 S XQPA=$P(^TMP($J,XQP,J),U,2)

 I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I

 S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 S:XQPS="(C)" XQPA=XQPA_"(C)",XQCOM=1 ; 080115

 S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA

 Q

LOOP3 ;

 I $O(^TMP($J,0,0))="" W !!,"** NO USERS CAN ACCESS THIS OPTION **" G OUT

 S %ZIS="MFQ" D ^%ZIS G OUT:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^XQ55",ZTDESC="OPTION ACCESS BY USER",ZTSAVE("XQ*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE,ZTDESC G OUT

 ;

DQ ;Entry point for queued job

 U IO

 S:'XQMP XQPA(0)=-4 S XQPG=0,XQUI=0 D NEWPG G:XQUI MUS

 S XQU=0 F  S XQU=$O(^TMP($J,0,XQU)) Q:XQU=""  D PRTU G:XQUI MUS

 D:XQMP MENUPAT G MUS

NEWPG ;

 S X="" I XQPG,$E(IOST,1)="C" D CON S XQUI=(X="^") Q:XQUI

 D HDR Q

CON ;

 W !!,"Press return to continue or '^' to escape " R X:DTIME S:'$T X=U

 Q

HDR ;

 W @IOF S XQPG=XQPG+1

 W "Page ",XQPG,?62,XQDT,!! S XQTAB=(76-$L(XQHDR))/2 W ?XQTAB,XQHDR

 W !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU" W:XQMP ?63,"PATH(S)"

 W !,$E(XQDSH,1,25),?27,$E(XQDSH,1,8),?37,$E(XQDSH,1,$S(XQMP:24,1:40)) W:XQMP ?63,$E(XQDSH,1,14)

 Q

PRTU ;

 I $Y>(IOSL-XQPA(0)-8) D:XQMP MENUPAT D NEWPG Q:XQUI

 S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) W !,$E($P(XQU,U,1),1,27),?27,K

 I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) W ?37,$E($P(^(0),U,1),1,24)

 I XQMP D

 .W ?63,""

 .S JJ=$O(^TMP($J,0,XQU,"A"),-1)

 .F II=1:1:JJ W $G(^TMP($J,0,XQU,II)) I II'=JJ W ","

 I 'XQMP D

 .S II=0 F  S II=$O(^TMP($J,0,XQU,II)) Q:II'>0  D

 ..I ^TMP($J,0,XQU,II)["(S)" W "  (Secondary menu)" S II="A"

 Q

MENUPAT ;

 W !!,$E(XQDSH,1,27),"     MENU PATH(S)     ",$E(XQDSH,1,29),!

 F I=1:1:XQPA(0) S K=XQPA(0,I) W !,I,".",?4 F N=1:1 Q:'$L($P(K,",",N))  W:N>1 " ... " W $P(^DIC(19,$P(K,",",N),0),U,1)

 I XQSCD W !,"(S) - secondary menu pathway"

 I XQCOM W !,"(C) - SYSTEM COMMAND OPTIONS (XUCOMMAND) menu pathway"

 Q

MUS G:X="^" OUT I $G(XQPG),$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT

 I $D(ZTSK) K ^%ZTSK(ZTSK)

OUT ;

 D ^%ZISC

KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX

 K DIC,I,II,JJ,L,POP,Y,XQNOPRNT I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XQ55   5526     printed  Mar 13, 2025@21:09:44                                                                                                                                                                                                        Page 2

XQ55      ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION;

 +1       ;;8.0;KERNEL;**140,342,483,508**;Jul 10, 1995;Build 1

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified

INIT      ;

 +1        SET XQDSH="-------------------------------------------------------------------------------"

 +2        DO ^XQDATE

           SET XQDT=%Y

OPT        WRITE !

           SET DIC=19

           SET DIC(0)="AEQM"

           DO ^DIC

           if Y=-1

               GOTO OUT

           SET XQOPT=+Y

MPAT       WRITE !!,"Show menu paths"

           SET %=2

           DO YN^DICN

           if %<0

               GOTO OUT

           SET XQMP=2-%

           IF '%

               WRITE !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option."

               GOTO MPAT

 +1        KILL ^TMP($JOB),XQR,XQP

 +2        SET K=^DIC(19,XQOPT,0)

           SET XQHDR="Access to '"_$PIECE(K,U,2)_"'  ["_$PIECE(K,U,1)_"]"

           SET XQSCD=0

           SET XQCOM=0

           SET XQNOPRNT=0

LOOP1      SET K=XQOPT

           SET (L,X(0))=0

           SET XQD=K

           KILL XQR,XQA,XQK,XQRV

           SET XQR(K)=""

           IF '$LENGTH($PIECE(^DIC(19,K,0),U,3))

               DO TREE1

 +1        GOTO LOOP2

 +2        QUIT 

TREE       SET X(L)=$ORDER(^DIC(19,"AD",XQD,X(L)))

           if X(L)'>0

               QUIT 

           SET K=X(L)

           if $DATA(XQR(K))

               GOTO TREE

           SET XQR(K)=""

TREE1     ;

 +1        SET Y(0)=^DIC(19,K,0)

           if $LENGTH($PIECE(Y(0),U,3))

               GOTO TREE

           if $LENGTH($PIECE(Y(0),U,6))

               SET XQK(L)=$PIECE(Y(0),U,6)

           SET XQA(L)=K

           IF $PIECE(Y(0),U,16)

               SET XQRV(L)=^DIC(19,K,3)

 +2        DO SETGLO

           SET L=L+1

           SET X(L)=0

           SET (XQD,XQD(L))=K

           DO TREE

 +3        if L=1

               QUIT 

           KILL XQR(XQD(L))

           SET L=L-1

           KILL XQA(L),XQK(L),XQRV(L)

           SET XQD=XQD(L)

           GOTO TREE

 +4        QUIT 

SETGLO    ;

 +1        SET XQK=""

           FOR I=L:-1:0

               IF $DATA(XQK(I))

                   IF $LENGTH(XQK(I))

                       SET XQK=XQK_XQK(I)_","

 +2        SET XQRV=""

           FOR I=L:-1:0

               IF $DATA(XQRV(I))

                   IF $LENGTH(XQRV(I))

                       SET XQRV=XQRV_XQRV(I)_","

 +3        SET XQA=""

           FOR I=L:-1:1

               IF $DATA(XQA(I))

                   SET XQA=XQA_XQA(I)_","

 +4        SET XQA=XQA_XQOPT

           SET J=0

           if $DATA(^TMP($JOB,K,0))

               SET J=^(0)

           SET J=J+1

           SET ^(0)=J

           SET ^TMP($JOB,K,J)=XQK_U_XQA_U_XQRV

 +5        QUIT 

LOOP2     ;

 +1        SET XQPA(0)=0

           SET XQP=0

           FOR 

               SET XQP=$ORDER(^TMP($JOB,XQP))

               if XQP=""

                   QUIT 

               SET XQN=^TMP($JOB,XQP,0)

               SET XQPS="AP"

               DO USERS

               SET XQPS="AD"

               DO USERS

 +2       ; 080115 - add in options from the common menu

           DO USERS1

           IF XQNOPRNT

               GOTO MUS

 +3        GOTO LOOP3

USERS     ;

 +1        SET XQU=0

           FOR 

               SET XQU=$ORDER(^VA(200,XQPS,XQP,XQU))

               if XQU'>0

                   QUIT 

               IF $DATA(^VA(200,XQU,.1))

                   IF +$$ACTIVE^XUSER(XQU)

                       DO EACHU

 +2        QUIT 

USERS1    ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu

 +1        NEW XUCOMMON

 +2        SET XUCOMMON=$ORDER(^DIC(19,"B","XUCOMMAND",0))

 +3        SET XQP=0

           FOR 

               SET XQP=$ORDER(^TMP($JOB,XQP))

               if XQP=""

                   QUIT 

               SET XQN=^TMP($JOB,XQP,0)

               FOR J=1:1:XQN

                   if '$DATA(^TMP($JOB,XQP,J))

                       QUIT 

                   IF $PIECE($PIECE(^TMP($JOB,XQP,J),U,2),",")=XUCOMMON

                       Begin DoDot:1

 +4                        Begin DoDot:2

 +5                            WRITE !,"***"

 +6                            WRITE !,"*** This option is available from the 'SYSTEM COMMAND OPTIONS'  ***"

 +7                            WRITE !,"*** (XUCOMMAND) menu available to all active users unless       ***"

 +8                            WRITE !,"*** protected by a KEY - DO YOU REALLY WANT THE ENTIRE LIST     ***"

 +9                            WRITE !,"*** OF THESE USERS???                                           ***",!

 +10                           NEW DIR

                               SET DIR(0)="Y"

                               DO ^DIR

                               if 'Y

                                   SET XQNOPRNT=1

                               if 'Y

                                   QUIT 

 +11                           QUIT 

                           End DoDot:2

                           if 'Y

                               QUIT 

 +12                       SET XQU=0

                           SET XQPS="(C)"

                           FOR 

                               SET XQU=$ORDER(^VA(200,XQU))

                               if XQU'>0

                                   QUIT 

                               IF $DATA(^VA(200,XQU,.1))

                                   IF +$$ACTIVE^XUSER(XQU)

                                       IF $$KEYCHECK()

                                           SET II=1

                                           DO SETU

                       End DoDot:1

 +13       QUIT 

 +14      ;

EACHU     ;

 +1        SET II=1

 +2       ; 080115

           FOR J=1:1:XQN

               if '$DATA(^TMP($JOB,XQP,J))

                   QUIT 

               IF $$KEYCHECK()

                   DO SETU

 +3        QUIT 

 +4       ;

KEYCHECK() ; 080115 extracted common code

 +1       ; returns 1 if user has access to the option, 0 if the user does not have access

 +2        SET XQK=$PIECE(^TMP($JOB,XQP,J),U,1)

           SET XX=$LENGTH(XQK,",")-1

           SET XQGO=1

 +3        IF XX

               FOR X=1:1:XX

                   SET Y=$PIECE(XQK,",",X)

                   IF Y'=""

                       IF ('$DATA(^XUSEC(Y,XQU)))

                           SET XQGO=0

 +4        SET XQK=$PIECE(^TMP($JOB,XQP,J),U,3)

           SET XX=$LENGTH(XQK,",")-1

 +5        IF XX

               FOR X=1:1:XX

                   SET Y=$PIECE(XQK,",",X)

                   IF Y'=""

                       IF ($DATA(^XUSEC(Y,XQU)))

                           SET XQGO=0

 +6        QUIT XQGO

 +7       ;

SETU      ;

 +1        SET XQPA=$PIECE(^TMP($JOB,XQP,J),U,2)

 +2        IF '$DATA(XQPA(XQPA))

               SET I=XQPA(0)+1

               SET XQPA(0)=I

               SET XQPA(0,I)=XQPA

               SET XQPA(XQPA)=I

 +3       ; 080115

           SET XQPA=XQPA(XQPA)

           if XQPS="AD"

               SET XQPA=XQPA_"(S)"

               SET XQSCD=1

           if XQPS="(C)"

               SET XQPA=XQPA_"(C)"

               SET XQCOM=1

 +4        SET I=$PIECE(^VA(200,XQU,0),U,1)_U_XQU

           if $DATA(^TMP($JOB,0,I))

               SET II=$ORDER(^TMP($JOB,0,I,"A"),-1)+1

           SET ^TMP($JOB,0,I,II)=XQPA

 +5        QUIT 

LOOP3     ;

 +1        IF $ORDER(^TMP($JOB,0,0))=""

               WRITE !!,"** NO USERS CAN ACCESS THIS OPTION **"

               GOTO OUT

 +2        SET %ZIS="MFQ"

           DO ^%ZIS

           if POP

               GOTO OUT

           IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTRTN="DQ^XQ55"

               SET ZTDESC="OPTION ACCESS BY USER"

               SET ZTSAVE("XQ*")=""

               SET ZTSAVE("^TMP($J,")=""

               DO ^%ZTLOAD

               KILL ZTSK,ZTRTN,ZTSAVE,ZTDESC

               GOTO OUT

 +3       ;

DQ        ;Entry point for queued job

 +1        USE IO

 +2        if 'XQMP

               SET XQPA(0)=-4

           SET XQPG=0

           SET XQUI=0

           DO NEWPG

           if XQUI

               GOTO MUS

 +3        SET XQU=0

           FOR 

               SET XQU=$ORDER(^TMP($JOB,0,XQU))

               if XQU=""

                   QUIT 

               DO PRTU

               if XQUI

                   GOTO MUS

 +4        if XQMP

               DO MENUPAT

           GOTO MUS

NEWPG     ;

 +1        SET X=""

           IF XQPG

               IF $EXTRACT(IOST,1)="C"

                   DO CON

                   SET XQUI=(X="^")

                   if XQUI

                       QUIT 

 +2        DO HDR

           QUIT 

CON       ;

 +1        WRITE !!,"Press return to continue or '^' to escape "

           READ X:DTIME

           if '$TEST

               SET X=U

 +2        QUIT 

HDR       ;

 +1        WRITE @IOF

           SET XQPG=XQPG+1

 +2        WRITE "Page ",XQPG,?62,XQDT,!!

           SET XQTAB=(76-$LENGTH(XQHDR))/2

           WRITE ?XQTAB,XQHDR

 +3        WRITE !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU"

           if XQMP

               WRITE ?63,"PATH(S)"

 +4        WRITE !,$EXTRACT(XQDSH,1,25),?27,$EXTRACT(XQDSH,1,8),?37,$EXTRACT(XQDSH,1,$SELECT(XQMP:24,1:40))

           if XQMP

               WRITE ?63,$EXTRACT(XQDSH,1,14)

 +5        QUIT 

PRTU      ;

 +1        IF $Y>(IOSL-XQPA(0)-8)

               if XQMP

                   DO MENUPAT

               DO NEWPG

               if XQUI

                   QUIT 

 +2        SET J=$PIECE(XQU,U,2)

           SET K=""

           if $DATA(^VA(200,J,1.1))

               SET K=$PIECE(^(1.1),"^")

           if $LENGTH(K)

               SET K=$EXTRACT(K,4,5)_"/"_$EXTRACT(K,6,7)_"/"_$EXTRACT(K,2,3)

           WRITE !,$EXTRACT($PIECE(XQU,U,1),1,27),?27,K

 +3        IF $DATA(^VA(200,J,201))

               SET K=+^(201)

               IF K>0

                   IF $DATA(^DIC(19,K,0))

                       WRITE ?37,$EXTRACT($PIECE(^(0),U,1),1,24)

 +4        IF XQMP

               Begin DoDot:1

 +5                WRITE ?63,""

 +6                SET JJ=$ORDER(^TMP($JOB,0,XQU,"A"),-1)

 +7                FOR II=1:1:JJ

                       WRITE $GET(^TMP($JOB,0,XQU,II))

                       IF II'=JJ

                           WRITE ","

               End DoDot:1

 +8        IF 'XQMP

               Begin DoDot:1

 +9                SET II=0

                   FOR 

                       SET II=$ORDER(^TMP($JOB,0,XQU,II))

                       if II'>0

                           QUIT 

                       Begin DoDot:2

 +10                       IF ^TMP($JOB,0,XQU,II)["(S)"

                               WRITE "  (Secondary menu)"

                               SET II="A"

                       End DoDot:2

               End DoDot:1

 +11       QUIT 

MENUPAT   ;

 +1        WRITE !!,$EXTRACT(XQDSH,1,27),"     MENU PATH(S)     ",$EXTRACT(XQDSH,1,29),!

 +2        FOR I=1:1:XQPA(0)

               SET K=XQPA(0,I)

               WRITE !,I,".",?4

               FOR N=1:1

                   if '$LENGTH($PIECE(K,",",N))

                       QUIT 

                   if N>1

                       WRITE " ... "

                   WRITE $PIECE(^DIC(19,$PIECE(K,",",N),0),U,1)

 +3        IF XQSCD

               WRITE !,"(S) - secondary menu pathway"

 +4        IF XQCOM

               WRITE !,"(C) - SYSTEM COMMAND OPTIONS (XUCOMMAND) menu pathway"

 +5        QUIT 

MUS        if X="^"

               GOTO OUT

           IF $GET(XQPG)

               IF $EXTRACT(IOST,1)="C"

                   WRITE !!,"Press return when finished viewing "

                   READ X:DTIME

                   WRITE @IOF

                   GOTO OUT

 +1        IF $DATA(ZTSK)

               KILL ^%ZTSK(ZTSK)

OUT       ;

 +1        DO ^%ZISC

KILL       KILL XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX

 +1        KILL DIC,I,II,JJ,L,POP,Y,XQNOPRNT

           IF $DATA(ZTQUEUED)

               IF $DATA(ZTSK)

                   IF ZTSK>0

                       KILL ^%ZTSK(ZTSK)

 +2        QUIT