source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m@ 631

Last change on this file since 631 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1XQCHK ; SEA/MJM - Check security on option # XQCY ;5/20/08
2 ;;8.0;KERNEL;**47,110,149,303,427,503**;Jul 10, 1995;Build 2
3 ;;"Per VHA Directive 2004-038, this routine should not be modified".
4 ;
5 Q:'$D(XQCY)!(XQCY<1) S:'$D(XQJMP) XQJMP=0
6 I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0)
7 I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0 S XQCY0=XQY0,XQY0=XQSAV
8CHK I XQCY0="" S XQCY=-1 G OUT
9 I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT
10 N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT ; add this line to check all Locks
11 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
12 N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT ; add this line to check all Reversed Locks
13 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
14 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
15 G:$P(XQCY0,U,10)'["y" OUT
16 S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%="" I IOS=% G OUT
17 S XQCY=-5 G OUT
18 Q
19 ;
20OUT K %,%XQI,XQCY0,%Y,XQZ
21 Q
22 ;
23JMP ;Check all options in jump path in %XQJP returned as "" if not OK
24 S XQJMP=1
25 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=""
26 K %XQCI,XQCY,XQCY0
27 Q
28 ;
29SET ;Produce the same XQY0 as SET1^XQ7 without the synonym
30 I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q
31S1 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)
32 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)
33 I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99)
34 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)
35 K %,%XQI
36 Q
37 ;
38MES ;Messages for rejected options from a call to XQCHK
39 W $C(7)
40 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)
41 I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked."
42 I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it."
43 I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now."
44 I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device."
45 Q
46 ;
47OP ;Find out what option or protocol is in charge right now
48 ;Returns option or protocol name and text in XQOPT
49 S U="^",%XQ=0
50 I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2)
51 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)
52 I '$D(XQOPT) S XQOPT="-1^Unknown"
53 K %XQ,%XQ1
54 Q
55 ;
56OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for
57 ;Protocol, Option, or Unknown. 2: The Option or Protocol's name. 3:
58 ;3: Text name of the Protocol or Option. For example:
59 ;
60 ; O^EVE^System Manager's Menu
61 ;
62 N %,%XQ,%XQ1
63 S U="^",%XQ=0
64 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)
65 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)
66 I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available"
67 Q %
68 ;
69ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option
70 Q $$ACCESS^XQCHK3(%XQUSR,%XQOP)
71 ;
72OPACCES ;Entry point for the option that checks to see if a user has
73 ;access to a particular option by calling the above function.
74 D OPACCES^XQCHK3
75 Q
76 ;
77KEYSET(XQU) ;Collect users keys and set them into ^TMP($J)
78 N %,XQI
79 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),%)=""
80 Q
Note: See TracBrowser for help on using the repository browser.