- 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 Jan 18, 2025@03:06:45 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