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
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 ---[H[J[2J[HXQ55 5526 printed Apr 09, 2024@21:17:37 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
+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
