XQCHK ; SEA/MJM - Check security on option # XQCY ;4/28/11
;;8.0;KERNEL;**47,110,149,303,427,503,570**;Jul 10, 1995;Build 3
;;"Per VHA Directive 2004-038, this routine should not be modified".
;
Q:'$D(XQCY)!(XQCY<1) S:'$D(XQJMP) XQJMP=0
I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0)
I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0 S XQCY0=XQY0,XQY0=XQSAV
CHK I XQCY0="" S XQCY=-1 G OUT
;I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT ;remove 570
N XQRT S XQRT=$$CHKOOO^XQCHK2(XQCY0) I +XQRT=1 S XQCY=-1 G OUT ;add this line to check if the option is set Out Of Order - BT/570
N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT ; add this line to check all Locks
;I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%="" I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT ; remove 570
N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT ; add this line to check all Reversed Locks
;I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%="" I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT ; remove 570
I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S X=% D XQO^XQ92 I X="" S XQCY=-4 G OUT
G:$P(XQCY0,U,10)'["y" OUT
S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%="" I IOS=% G OUT
S XQCY=-5 G OUT
Q
;
OUT K %,%XQI,XQCY0,%Y,XQZ
Q
;
JMP ;Check all options in jump path in %XQJP returned as "" if not OK
S XQJMP=1
F %XQCI=1:1 S XQCY=$P(%XQJP,",",%XQCI) Q:XQCY="" S XQCY0=$G(^XUTL("XQO",XQDIC,"^",XQCY)),XQCY0=$P(XQCY0,U,2,99) D CHK S:XQCY<0 %XQJP=""
K %XQCI,XQCY,XQCY0
Q
;
SET ;Produce the same XQY0 as SET1^XQ7 without the synonym
I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q
S1 Q:XQY'>0 S XQY0=^DIC(19,+XQY,0),XQY0=$P(XQY0,U,1,2)_U_$S($P(XQY0,U,3)]"":1,1:"")_U_$P(XQY0,U,4)_U_U_$P(XQY0,U,6,99)
S %="" I $D(^DIC(19,+XQY,3.91)) F %XQI=0:0 S %XQI=$O(^DIC(19,+XQY,3.91,%XQI)) Q:%XQI=""!(%XQI'=+%XQI) I ^(%XQI,0)]"" S %=$S(%'="":%_";",1:"")_$P(^(0),U,1)_$P(^(0),U,2)
I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99)
I $P(XQY0,U,16),$D(^DIC(19,XQY,3)) S %=$P(^(3),U) I %'="" S XQY0=$P(XQY0,U,1,15)_U_%_U_$P(XQY0,U,17,99)
K %,%XQI
Q
;
MES ;Messages for rejected options from a call to XQCHK
W $C(7)
I XQCY=-1 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$P(^DIC(19,XQY,0),U,3)
I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked."
I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it."
I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now."
I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device."
Q
;
OP ;Find out what option or protocol is in charge right now
;Returns option or protocol name and text in XQOPT
S U="^",%XQ=0
I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2)
I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),XQOPT=$P(%XQ1,U)_U_$P(%XQ1,U,2)
I '$D(XQOPT) S XQOPT="-1^Unknown"
K %XQ,%XQ1
Q
;
OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for
;Protocol, Option, or Unknown. 2: The Option or Protocol's name. 3:
;3: Text name of the Protocol or Option. For example:
;
; O^EVE^System Manager's Menu
;
N %,%XQ,%XQ1
S U="^",%XQ=0
I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),%="P"_U_$P(%XQ,U)_U_$P(%XQ,U,2)
I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),%="O"_U_$P(%XQ1,U)_U_$P(%XQ1,U,2)
I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available"
Q %
;
ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option
Q $$ACCESS^XQCHK3(%XQUSR,%XQOP)
;
OPACCES ;Entry point for the option that checks to see if a user has
;access to a particular option by calling the above function.
D OPACCES^XQCHK3
Q
;
KEYSET(XQU) ;Collect users keys and set them into ^TMP($J)
N %,XQI
S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%="" S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U),%)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQCHK 4230 printed Dec 13, 2024@02:05:33 Page 2
XQCHK ; SEA/MJM - Check security on option # XQCY ;4/28/11
+1 ;;8.0;KERNEL;**47,110,149,303,427,503,570**;Jul 10, 1995;Build 3
+2 ;;"Per VHA Directive 2004-038, this routine should not be modified".
+3 ;
+4 if '$DATA(XQCY)!(XQCY<1)
QUIT
if '$DATA(XQJMP)
SET XQJMP=0
+5 IF '$DATA(XQY0)
SET XQY0=^DIC(19,+XQCY,0)
+6 IF '$DATA(XQCY0)
SET XQSAV=XQY0
SET XQY=XQCY
DO SET
if XQCY<0
QUIT
SET XQCY0=XQY0
SET XQY0=XQSAV
CHK IF XQCY0=""
SET XQCY=-1
GOTO OUT
+1 ;I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT ;remove 570
+2 ;add this line to check if the option is set Out Of Order - BT/570
NEW XQRT
SET XQRT=$$CHKOOO^XQCHK2(XQCY0)
IF +XQRT=1
SET XQCY=-1
GOTO OUT
+3 ; add this line to check all Locks
NEW XQRT
SET XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ)
IF +XQRT
SET XQCY=-2
GOTO OUT
+4 ;I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%="" I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT ; remove 570
+5 ; add this line to check all Reversed Locks
NEW XQRT
SET XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ)
IF +XQRT
SET XQCY=-3
GOTO OUT
+6 ;I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%="" I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT ; remove 570
+7 IF $LENGTH($PIECE(XQCY0,U,9))
SET XQZ=$PIECE(XQCY0,U,9)
DO ^XQDATE
SET X=%
DO XQO^XQ92
IF X=""
SET XQCY=-4
GOTO OUT
+8 if $PIECE(XQCY0,U,10)'["y"
GOTO OUT
+9 SET %=0
FOR %XQI=1:1
SET %=$ORDER(^DIC(19,XQCY,3.96,%,0))
if %=""
QUIT
IF IOS=%
GOTO OUT
+10 SET XQCY=-5
GOTO OUT
+11 QUIT
+12 ;
OUT KILL %,%XQI,XQCY0,%Y,XQZ
+1 QUIT
+2 ;
JMP ;Check all options in jump path in %XQJP returned as "" if not OK
+1 SET XQJMP=1
+2 FOR %XQCI=1:1
SET XQCY=$PIECE(%XQJP,",",%XQCI)
if XQCY=""
QUIT
SET XQCY0=$GET(^XUTL("XQO",XQDIC,"^",XQCY))
SET XQCY0=$PIECE(XQCY0,U,2,99)
DO CHK
if XQCY<0
SET %XQJP=""
+3 KILL %XQCI,XQCY,XQCY0
+4 QUIT
+5 ;
SET ;Produce the same XQY0 as SET1^XQ7 without the synonym
+1 IF '$DATA(^DIC(19,+XQY,0))
SET XQY=-1
QUIT
S1 if XQY'>0
QUIT
SET XQY0=^DIC(19,+XQY,0)
SET XQY0=$PIECE(XQY0,U,1,2)_U_$SELECT($PIECE(XQY0,U,3)]"":1,1:"")_U_$PIECE(XQY0,U,4)_U_U_$PIECE(XQY0,U,6,99)
+1 SET %=""
IF $DATA(^DIC(19,+XQY,3.91))
FOR %XQI=0:0
SET %XQI=$ORDER(^DIC(19,+XQY,3.91,%XQI))
if %XQI=""!(%XQI'=+%XQI)
QUIT
IF ^(%XQI,0)]""
SET %=$SELECT(%'="":%_";",1:"")_$PIECE(^(0),U,1)_$PIECE(^(0),U,2)
+2 IF %]""
SET XQY0=$PIECE(XQY0,U,1,8)_U_%_U_$PIECE(XQY0,U,10,99)
+3 IF $PIECE(XQY0,U,16)
IF $DATA(^DIC(19,XQY,3))
SET %=$PIECE(^(3),U)
IF %'=""
SET XQY0=$PIECE(XQY0,U,1,15)_U_%_U_$PIECE(XQY0,U,17,99)
+4 KILL %,%XQI
+5 QUIT
+6 ;
MES ;Messages for rejected options from a call to XQCHK
+1 WRITE $CHAR(7)
+2 IF XQCY=-1
WRITE !!?5,"==> Sorry, ",$SELECT($DATA(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$PIECE(^DIC(19,XQY,0),U,3)
+3 IF XQCY=-2
WRITE !!?5,"==> Sorry, ",$SELECT($DATA(XQPRMN):"your Primary Menu",1:"this option")," is locked."
+4 IF XQCY=-3
WRITE !!?5,"==> Sorry, ",$SELECT($DATA(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it."
+5 IF XQCY=-4
WRITE !!?5,"==> Sorry, ",$SELECT($DATA(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now."
+6 IF XQCY=-5
WRITE !!?5,"==> Sorry, ",$SELECT($DATA(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device."
+7 QUIT
+8 ;
OP ;Find out what option or protocol is in charge right now
+1 ;Returns option or protocol name and text in XQOPT
+2 SET U="^"
SET %XQ=0
+3 IF $DATA(XQORNOD)
SET %XQ=+XQORNOD
SET %XQ1=U_$PIECE(XQORNOD,";",2)
SET %XQ=@(%XQ1_%XQ_",0)")
SET XQOPT=$PIECE(%XQ,U)_U_$PIECE(%XQ,U,2)
+4 IF '$DATA(XQORNOD)
SET %XQ=$SELECT($DATA(XQY)#2:XQY,1:0)
IF %XQ
SET %XQ1=^DIC(19,+%XQ,0)
SET XQOPT=$PIECE(%XQ1,U)_U_$PIECE(%XQ1,U,2)
+5 IF '$DATA(XQOPT)
SET XQOPT="-1^Unknown"
+6 KILL %XQ,%XQ1
+7 QUIT
+8 ;
OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for
+1 ;Protocol, Option, or Unknown. 2: The Option or Protocol's name. 3:
+2 ;3: Text name of the Protocol or Option. For example:
+3 ;
+4 ; O^EVE^System Manager's Menu
+5 ;
+6 NEW %,%XQ,%XQ1
+7 SET U="^"
SET %XQ=0
+8 IF $DATA(XQORNOD)
SET %XQ=+XQORNOD
SET %XQ1=U_$PIECE(XQORNOD,";",2)
SET %XQ=@(%XQ1_%XQ_",0)")
SET %="P"_U_$PIECE(%XQ,U)_U_$PIECE(%XQ,U,2)
+9 IF '$DATA(XQORNOD)
SET %XQ=$SELECT($DATA(XQY)#2:XQY,1:0)
IF %XQ
SET %XQ1=^DIC(19,+%XQ,0)
SET %="O"_U_$PIECE(%XQ1,U)_U_$PIECE(%XQ1,U,2)
+10 IF '$DATA(%)
SET %="U"_U_"Unknown"_U_"No option or protocol data available"
+11 QUIT %
+12 ;
ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option
+1 QUIT $$ACCESS^XQCHK3(%XQUSR,%XQOP)
+2 ;
OPACCES ;Entry point for the option that checks to see if a user has
+1 ;access to a particular option by calling the above function.
+2 DO OPACCES^XQCHK3
+3 QUIT
+4 ;
KEYSET(XQU) ;Collect users keys and set them into ^TMP($J)
+1 NEW %,XQI
+2 SET %=0
FOR XQI=0:1
SET %=$ORDER(^VA(200,XQU,51,"B",%))
if %=""
QUIT
if $DATA(^DIC(19.1,%,0))
SET ^TMP($JOB,$PIECE(^DIC(19.1,%,0),U),%)=""
+3 QUIT
