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

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

initial load of WorldVistAEHR
File size: 7.6 KB
Line 
1XQ75 ;SEA/AMF,LUKE,JLI - Lookup response for jumps ;09/17/2002 12:51
2 ;;8.0;KERNEL;**47,46,157,253**;Jul 10, 1995
3 ;Enter at S with XQUR. Exit with XQY set to the chosen option #,
4 ;with array of possibilities in XQ(XQ):XQY^menu txt [name]^XQPSM
5 ;XQXT(XQXT) similarly built, holds exact matches
6 ;XQY=-1 (no option found), or XQY=-2 (jumps shut down).
7 ;
8X ;Unless exact match is found, find all possibilities in any XQDIC
9 S XQO=$O(^XUTL("XQO",XQDIC,XQO)) Q:'$S(XQO="":0,XQUR="?":XQO'="^",XQUR=0_$C(1):'$L($P(XQO,"0",1)),1:'$L($P(XQO,XQUR,1)))
10 S XQYY=^XUTL("XQO",XQDIC,XQO) S XQY=+XQYY G:$D(XQ("X",+XQY)) X S %=$G(^XUTL("XQO",XQDIC,"^",+XQY)) G:%="" X S XQY0=$P(%,U,2,99)
11 S XQCY=XQY,XQCY0=XQY0 D ^XQCHK I XQCY<0 S XQY=0 G X
12 S:'$P(XQYY,U,2) XQ("S",+XQY)=$P(XQO,U)
13 I XQUR=$P(XQO,U),'XQS S XQXT=XQXT+1,XQXT(XQXT)=+XQY_U_$P(XQY0,U,2)_" ["_$P(XQY0,U)_"] "_U_$S($D(XQUD):XQUD_",",1:"")_XQDIC,XQXT("X",XQY)="" S:'$P(XQYY,U,2) XQXT("S",+XQY)=$P(XQO,U)
14 S XQ=XQ+1,XQ1=XQ1+1,XQ(XQ)=+XQY_U_$P(XQY0,U,2)_" ["_$P(XQY0,U)_"] "_U_$S($D(XQUD):XQUD_",",1:"")_XQDIC,XQ("X",XQY)=""
15 I XQ1>19,'XQXT D C
16 Q:XQY<0!(XQUR="") G X
17 Q
18 ;
19C ;Display a screen-load of 19 possibilities and ask for a choice
20 ;I $G(XQXFLG("GUI")) D Q
21 ;.D LIST^XQGS1(XQ)
22 ;.S XQUR=""
23 ;.Q:XQY<0
24 ;.S %="" F S %=$O(XQ(%)) Q:%=""!(%'=+%) I XQY=+XQ(%) S XQPSM=$P(XQ(%),U,3)
25 ;.Q
26 S:XQ1<1 XQ1=XQ W ! F XQI=1:1:XQ1 S XQJ=XQS*20+XQI W !?4,XQJ,?9,$P(XQ(XQJ),U,2) I $D(XQ("S",+XQ(XQJ))) W ?43," (",XQ("S",+XQ(XQJ)),")"
27ASK W !!,"Type '^' to stop, or choose a number from 1 to ",XQ," :"
28 R XQJ:DTIME S:'$T XQJ=U W:XQJ["?" !!,"**> Choose an item from this list by selecting its corresponding number,",!?5,"or type a '^' to return to your menu.",! G:XQJ["?" ASK
29 I XQJ=U S XQY=-1,XQ=0 Q
30 I XQJ'?1N.N,$L(XQJ),XQJ'=U W $C(7)," ??",! G ASK
31 I XQJ?1N.N G C:'$D(XQ(XQJ)) D Q:$D(XQ(+XQJ))
32 .N %,XQD,XQP,Y
33 .S %=XQ(XQJ),Y=+% I Y>0 D
34 ..S XQP=$P(%,U,3),XQD=$S($L(XQP,",")>1:$P(XQP,",",$L(XQP,",")),1:XQP)
35 ..S XQY0=$G(^XUTL("XQO",XQD,"^",Y)),XQY0=$P(XQY0,U,2,99)
36 ..I XQY0="" K XQ(XQJ) S XQ=XQ-1,XQJ="" Q
37 .I $L(XQJ),$D(XQ(XQJ)) S XQY=Y,XQDIC=XQD,XQPSM=XQP,XQUR="" W " " Q
38 .Q
39 I XQJ?1N.N W $C(7),$P(XQ(XQJ-1#20+1),U,4),! G C
40 I '$L(XQJ),XQ1'<20 S XQS=XQS+1,XQ1=0 Q
41 I '$L(XQJ),XQ1<20 S XQY=-1,XQ=0 Q
42 I '$D(XQ(XQJ)) G C
43 K XQ S XQY=$S(XQJ=U:-3,XQJ="":-3,1:-1),XQUR=$C(95) S:XQJ=U XQJ="",XQY=-1 S:$L(XQJ) XQUR=$S($E(XQDIC,1)="P":U_XQJ,1:XQJ),XQY=0 Q
44 Q
45 ;
46S ;Entry from XQ: Search primary, common, and secondary menus for XQUR
47 I XQUR'?.ANP W $C(7) S XQY=-1 Q
48 I XQPSM'="PXU" S XQDIC=$S($D(XQPSM):$P(XQPSM,"P",2),$D(XQDIC):XQDIC,1:XQY)
49 E S XQDIC="PXU"
50 I '$D(XQTT) S XQTT=$G(^XUTL("XQ",$J,"T")) I XQTT="" S XQTT=1
51 ;S:'$D(XQDIC) XQDIC=XQY S XQSV=XQY_U_XQDIC_U_XQY0
52 S XQJ="",XQJMP=1,(XQ,XQ1,XQS,XQXT,XQY)=0
53 S XQO=$E(XQUR,1,30) I XQUR'?.PUN S XQO=$$UP^XLFSTR(XQO) ;F XQI=1:1 Q:XQO?.NUP S XQO1=$A(XQO,XQI) I XQO1<123,XQO1>96 S XQO=$E(XQO,1,XQI-1)_$C(XQO1-32)_$E(XQO,XQI+1,255)
54 S XQUR=XQO,(XQO,XQO1)=$E(XQUR,1,$L(XQUR)-1)_$C($A($E(XQUR,$L(XQUR)))-1)_"z"
55 I '$D(^XUTL("XQ",$J,"XQM")) S ^("XQM")=+^VA(200,DUZ,201)
56 ;I '$D(^XUTL("XQ",$J,"XQW")) S ^("XQW")=$P(^VA(200,DUZ,201),U,2)
57 I $D(XQJS),XQJS G OUT
58 ;
59 ;Check the Primary Menu first
60 S XQDIC="P"_^XUTL("XQ",$J,"XQM")
61 ;If there's no master copy in ^DIC(19,"AXQ"), nothing to do.
62 I '$D(^DIC(19,"AXQ",XQDIC,0)) D REACT^XQ84(DUZ) S XQY=-1 G OUT
63 I '$D(^XUTL("XQO",XQDIC,0)) S XQSAVE=XQPSM,XQPSM=XQDIC D MERGE^XQ12 S XQPSM=XQSAVE
64 S XQXUTL=$G(^XUTL("XQO",XQDIC,0)),XQDIC19=^DIC(19,"AXQ",XQDIC,0)
65 I XQXUTL="" S XQXUTL=XQDIC19
66 S %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2) I %>30 S XQSAVE=XQPSM,XQPSM=XQDIC D MERGE^XQ12 S XQPSM=XQSAVE
67 ;If tree is not there or out of date, remerge it
68 D X G:XQY<0 OUT G:XQUR="" W
69 ;
70 ;Look in XUCOMMAND
71 S XQDIC="PXU"
72 ;I $S('$D(^XUTL("XQO",XQDIC,0)):1,^XUTL("XQO",XQDIC,0)'=^DIC(19,"AXQ",XQDIC,0):1,1:0) D MGPXU^XQ12
73 I '$D(^XUTL("XQO",XQDIC,0)) D MGPXU^XQ12
74 S XQXUTL=$G(^XUTL("XQO",XQDIC,0)),XQDIC19=^DIC(19,"AXQ",XQDIC,0)
75 I XQXUTL="" S XQXUTL=XQDIC19
76 S %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2) I %>30 D MGPXU^XQ12
77 S XQO=XQO1 D X G:XQY<0 OUT G:XQUR="" W
78 ;
79 ;Check the top level of the Secondaries
80 S XQDIC="U"_DUZ,XQO=XQO1 D:$S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^VA(200,DUZ,203.1)):1,1:^VA(200,DUZ,203.1)'=$P(^XUTL("XQO",XQDIC,0),U,2)) ^XQSET I '$D(^XUTL("XQO",XQDIC,0)),'XQXT D C G:XQY<0 OUT G:XQUR="" W
81 D X G:XQY<0 OUT G:XQUR="" W
82 ;
83 ;Check each secondary in depth
84 F XQK=0:0 Q:XQY<0!(XQUR="") S XQUD="U"_DUZ,XQK=$O(^XUTL("XQO",XQUD,U,XQK)) Q:XQK="" D
85 .S XQCY=XQK D ^XQCHK I XQCY>0,$P(^XUTL("XQO",XQUD,U,XQK),U,5)="M" D
86 ..N XQSAVE
87 ..S XQST=XQK,XQDIC="P"_XQK,XQO=XQO1
88 ..I '$D(^DIC(19,"AXQ","P0")) D
89 ...I '$D(^XUTL("XQO",XQDIC,0)) S XQSAVE=XQPSM D MERGE^XQ12 S XQPSM=XQSAVE
90 ...S XQXUTL=$G(^XUTL("XQO",XQDIC,0)),XQDIC19=$G(^DIC(19,"AXQ",XQDIC,0))
91 ...Q:XQDIC19="" ;Nothing to merge, probably a new scondary
92 ...I XQXUTL="" S XQXUTL=XQDIC19
93 ...S %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2) I %>30 S XQSAVE=XQPSM,XQPSM=XQDIC D MERGE^XQ12 S XQPSM=XQSAVE
94 ...Q
95 ..D X Q:XQY<0!(XQUR="")
96 ..Q
97 .Q
98 G:XQY<0 OUT
99 G:XQUR="" W
100 ;
101 I XQXT K XQ S (XQ,XQ1)=XQXT F XQI=1:1:XQ S XQ(XQI)=XQXT(XQI),%=+XQ(XQI),XQ("X",%)="" I $D(XQXT("S",%)) S XQ("S",%)=XQXT("S",%)
102 ;
103 I XQ=1,XQS=0 D
104 .N X
105 .S %=XQ(1),XQY=+%,XQPSM=$P(%,U,3)
106 .S XQDIC=$S($L(XQPSM,",")>1:$P(XQPSM,",",$L(XQPSM,",")),1:XQPSM)
107 .S X=$G(^XUTL("XQO",XQDIC,U,XQY))
108 .I X="" S X=$G(^DIC(19,"AXQ",XQDIC,U,XQY))
109 .Q:X=""
110 .S XQY0=$P(X,U,2,99),XQSFLG=""
111 .Q
112 I $D(XQSFLG) K XQSFLG G W
113 ;
114 I XQ>0,'$D(XQ(XQS*20+1)) S XQY=-1 G OUT
115 D:XQ>0 C G:XQY<0 OUT I XQ=0 S XQY=-1 G OUT
116 ;
117W ;Write out remaining text and return to XQ
118 ;G:$D(XQXFLG("GUI")) OUT
119 I $D(XQ("S",+XQY)),XQUR=$E(XQ("S",+XQY),1,$L(XQUR)) W $E(XQ("S",+XQY),$L(XQUR)+1,99)," ",$P(XQY0,U,2)
120 E W $E($P(XQY0,U,2),$L(XQUR)+1,99) W:$D(XQ("S",+XQY)) " (",XQ("S",+XQY),")"
121 ;
122OUT ;Exit here
123 K XQ
124 N % S XQ=""
125 I XQY>0,$D(^XUTL("XQO",XQDIC,"^",+XQY,0)) D
126 .S %=$G(^XUTL("XQO",XQDIC,"^",+XQY,0)) I %="" D
127 ..H 1 ;Micro surgery must have it wait a sec
128 ..S %=$G(^XUTL("XQO",XQDIC,"^",+XQY,0))
129 ..Q
130 .Q:%=""
131 .S:%>0 XQ=+%
132 .F XQI=1:1:XQ D
133 ..S %=$G(^XUTL("XQO",XQDIC,"^",XQY,0,XQI)) I %="" D
134 ...H 1
135 ...S %=$G(^XUTL("XQO",XQDIC,"^",XQY,0,XQI))
136 ...Q
137 ..I %]"" S XQ(XQI)=$P(%,U)
138 ..Q
139 .Q
140 I XQ="" S XQ=0
141 ;I XQY=-1,'$D(XQHLP) W $C(7)," ??" S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99),XQUR=""
142 ;
143 K %,I,J,X,XQ1,XQAP,XQCY,XQCY0,XQDIC19,XQI,XQJ,XQJMP,XQK,XQO,XQO1,XQS,XQST,XQUD,XQXT,XQXUTL,XQYY,Y
144 K XQ
145 Q
146 ;
147FIND(XQDIC) ;The expected 0th node in ^XUTL is not here
148 I '$D(XQDIC) Q 0
149 N %,XQT1,XQT2
150 S %=$G(^DIC(19,"AXQ",XQDIC,0))
151 I '$L(%) Q 0
152 I $D(^XTMP("XQO","NOFIND",XQDIC)) D
153 .N XQT1,XQT2,XQFLG
154 .S XQT1=$H,XQFLG=0
155 .S XQT2=$G(^XTMP("XQO","NOFIND",XQDIC))
156 .I '$L(XQT2) Q
157 .I XQT2>XQT1 K ^XTMP("XQO","NOFIND",XQDIC) Q
158 .I XQT1>XQT2!($P(XQT1,",",2)-$P(XQT2,",",2)>.300) D
159 ..K ^XTMP("XQO","NOFIND",XQDIC)
160 ..I XQDIC="PXU" S XQFLG=1 D MGPXU^XQ12
161 ..I 'XQFLG D MERGE^XQ12
162 ..Q
163 .Q
164 I '$D(^XTMP("XQO","NOFIND",XQDIC)) S ^(XQDIC)=$H
165 Q %
166 ;
167P ;Entry point for '"' jump to XUCOMMAND options
168 I XQUR'?.ANP!(XQUR[U) W $C(7)," ??" S XQY=-1 Q
169 S XQO=XQUR I XQUR'?.PUN S XQO=$$UP^XLFSTR(XQO) ;F XQI=1:1 Q:XQO?.NUP S XQO1=$A(XQO,XQI) I XQO1<123,XQO1>96 S XQO=$E(XQO,1,XQI-1)_$C(XQO1-32)_$E(XQO,XQI+1,255)
170 S XQUR=XQO ;,XQSV=XQY_U_XQDIC_U_XQY0
171 S XQJ="",XQJMP=1,(XQ,XQ1,XQS,XQXT,XQY)=0
172 S (XQO,XQO1)=$E(XQUR,1,$L(XQUR)-1)_$C($A($E(XQUR,$L(XQUR)))-1)_"z"
173 S XQDIC="PXU" D X G:XQY<0 OUT G:XQUR="" W
174 I XQXT K XQ S XQ=XQXT F XQI=1:1:XQ S XQ(XQI)=XQXT(XQI),%=+XQ(XQI),XQ("X",%)="" I $D(XQXT("S",%)) S XQ("S",%)=XQXT("S",%)
175 I XQ=1,XQS=0 S %=XQ(1),XQY=+%,XQPSM=$P(%,U,3),XQDIC=$S($L(XQPSM,",")>1:$P(XQPSM,",",$L(XQPSM,",")),1:XQPSM),XQY0=$P(^XUTL("XQO",XQDIC,U,XQY),U,2,99) G OUT
176 D:XQ>0 C G:XQY<0 OUT I XQ=0&('XQXT) S XQY=-1 G OUT
177 G OUT
Note: See TracBrowser for help on using the repository browser.