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/XQ74.m@ 1166

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

initial load of FOIAVistA 6/30/08 version

File size: 2.8 KB
Line 
1XQ74 ;SEA/MJM - Phantom Jump processor ; ;4/26/91 3:18 PM
2 ;;8.0;KERNEL;;Jul 10, 1995
3 Q:'$D(XQMM("J")) I '$L(XQMM("J")) K XQMM("J") G M2^XQ
4 I +XQMM("J")=-1 G RESET
5 ;
6 S XQSV=XQY_U_XQDIC_U_XQY0,XQMMX=XQMM("J"),XQMMK=$P(XQMMX,";",1) K XQMM("J")
7 I XQMMK'=+XQMMK S:$D(X) XQMMS=X D SET,CONVERT S:$D(XQMMS) X=XQMMS
8 S:$P(XQMMX,";",2)'="" XQMM("J")=$P(XQMMX,";",2,99)
9 K XQMMS,XQMMX
10 ;
11LEGAL ;See if this a legal option for this user
12 S XQPSM="P"_^XUTL("XQ",$J,"XQM") I $D(^XUTL("XQO",XQPSM,"^",XQMMK)) S XQDIC=XQPSM D SETJ G ^XQ72
13 S XQPSM="PXU" I $D(^XUTL("XQO",XQPSM,"^",XQMMK)) S XQDIC=XQPSM D SETJ G ^XQ72
14 S XQPSM="U"_DUZ D:$S('$D(^XUTL("XQO",XQPSM,0)):1,'$D(^VA(200,DUZ,203.1)):1,1:^VA(200,DUZ,203.1)'=$P(^XUTL("XQO",XQPSM,0),U,2)) ^XQSET
15 I $D(^XUTL("XQO",XQPSM,"^",XQMMK)) S XQDIC=XQPSM D SETJ G ^XQ72
16 F XQI=0:0 S XQI=$O(^XUTL("XQO",XQPSM,U,XQI)) Q:XQI="" S XQUD="P"_XQI I $P(^(XQI),U,5)="M",$D(^XUTL("XQO",XQUD,U,XQMMK)) S XQPSM="U"_DUZ_","_XQUD D SETJ G ^XQ72
17 W !!,"*** WARNING ***",!!,"Background jump requested to option '",$P(^DIC(19,+XQMMK,0),U,2),"'",!,"You do not have access to this option. Notify your computer",!,"representative."
18 G OUT
19 ;
20SET ;Save the "XQ" stack in XQMM("OLD")
21 I ^XUTL("XQ",$J,"T")>1 S XQMM("OLD")=^XUTL("XQ",$J,"T")_U F XQI=2:1:^("T") S XQMM("OLD")=XQMM("OLD")_$P(^(XQI),U,1)_U
22 S XQMMSAV=XQDIC_U_XQPSM_U_+XQY_U_XQY0
23 ;I XQRB S X="XQRBJ",DIC(0)="XFMZ",DIC=19 D ^DIC S ^XUTL("XQ",$J,2)=+Y_U_XQDIC_U_^DIC(19,+Y,0),^XUTL("XQ",$J,"T")=1,XQST=3
24 Q
25 ;
26SETJ ;Set up the variables for a jump
27 S XQY=+XQMMK,XQY0=$S($D(^XUTL("XQO",XQDIC,"^",XQY))#2:$P(^(XQY),U,2,99),1:"") I XQY0="" D S1^XQCHK
28 S:$P(XQY0,U,4)="M" XQMMF=""
29 K XQA,XQI,XQK,XQMMK,XQUD
30 Q
31 ;
32CONVERT ;Convert option names to their internal #'s an add -1 for return
33 S DIC=19,DIC(0)="XFZM",XQMMY=""
34 F XQI=1:1 S X=$P(XQMMX,";",XQI) Q:X="" D ^DIC D:Y<0 MESS1 S:Y>0 XQMMY=XQMMY_+Y_";"
35 S XQMMK=$P(XQMMY,";",1),XQMMX=XQMMY_"-1"
36 K DIC,X,XQI,XQJ,XQMMY,Y
37 Q
38 ;
39MESS1 W !!,"*** WARNING ***",!!,"Background jump to option '",X,"'",!," requested, but this option does not exist on this system." G RESET
40 ;
41ERR ;Error message for locks, out-of-order, etc.
42 S:$D(XQMMK) XQY=+XQMMK
43 W !!?10,"*** WARNING ***",!!,"Illegal jump requested to option '",$P(^DIC(19,+XQY,0),U,2),"'",!,XQNO,!,XQNO1
44 ;
45RESET ;Reset ^XUTL to what it was before we started
46 I '$D(XQMM("OLD"))!('$D(XQMMSAV)) S ^XUTL("XQ",$J,"T")=1,(XQY,XQDIC)=^("XQM"),XQY0=^DIC(19,+XQY,0) G OUT
47 S XQDIC=$P(XQMMSAV,U,1),XQPSM=$P(XQMMSAV,U,2),XQY=$P(XQMMSAV,U,3),XQY0=$P(XQMMSAV,U,4,99)
48 S ^XUTL("XQ",$J,"T")=$P(XQMM("OLD"),U,1)
49 F XQI=2:1:^XUTL("XQ",$J,"T") S XQJ=$P(XQMM("OLD"),U,XQI) Q:XQJ="" S XQK=$S(XQJ["P":"P",1:"U"),^XUTL("XQ",$J,XQI)=XQJ_^XUTL("XQO",XQK_$P(XQJ,XQK,2),"^",+XQJ)
50 ;
51OUT K XQA,XQD,XQI,XQJ,XQK,XQMM("J"),XQMM("OLD"),XQMMSAV,XQNO,XQNO1,XQRBJ,XQST,XQZ
52 G M^XQ
53 Q
Note: See TracBrowser for help on using the repository browser.