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@ 1087

XQ75 ;SEA/AMF,LUKE,JLI - Lookup response for jumps ;09/17/2002  12:51
 ;;8.0;KERNEL;**47,46,157,253**;Jul 10, 1995
 ;Enter at S with XQUR. Exit with XQY set to the chosen option #,
 ;with array of possibilities in XQ(XQ):XQY^menu txt [name]^XQPSM
 ;XQXT(XQXT) similarly built, holds exact matches
 ;XQY=-1 (no option found), or XQY=-2 (jumps shut down).
 ;
X ;Unless exact match is found, find all possibilities in any XQDIC
 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)))
 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)
 S XQCY=XQY,XQCY0=XQY0 D ^XQCHK I XQCY<0 S XQY=0 G X
 S:'$P(XQYY,U,2) XQ("S",+XQY)=$P(XQO,U)
 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)
 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)=""
 I XQ1>19,'XQXT D C
 Q:XQY<0!(XQUR="")  G X
 Q
 ;
C ;Display a screen-load of 19 possibilities and ask for a choice
 ;I $G(XQXFLG("GUI")) D  Q
 ;.D LIST^XQGS1(XQ)
 ;.S XQUR=""
 ;.Q:XQY<0
 ;.S %="" F  S %=$O(XQ(%)) Q:%=""!(%'=+%)  I XQY=+XQ(%) S XQPSM=$P(XQ(%),U,3)
 ;.Q
 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)),")"
ASK W !!,"Type '^' to stop, or choose a number from 1 to ",XQ," :"
 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
 I XQJ=U S XQY=-1,XQ=0 Q
 I XQJ'?1N.N,$L(XQJ),XQJ'=U W $C(7),"  ??",! G ASK
 I XQJ?1N.N G C:'$D(XQ(XQJ)) D  Q:$D(XQ(+XQJ))
 .N %,XQD,XQP,Y
 .S %=XQ(XQJ),Y=+% I Y>0 D
 ..S XQP=$P(%,U,3),XQD=$S($L(XQP,",")>1:$P(XQP,",",$L(XQP,",")),1:XQP)
 ..S XQY0=$G(^XUTL("XQO",XQD,"^",Y)),XQY0=$P(XQY0,U,2,99)
 ..I XQY0="" K XQ(XQJ) S XQ=XQ-1,XQJ="" Q
 .I $L(XQJ),$D(XQ(XQJ)) S XQY=Y,XQDIC=XQD,XQPSM=XQP,XQUR="" W "  " Q
 .Q
 I XQJ?1N.N W $C(7),$P(XQ(XQJ-1#20+1),U,4),! G C
 I '$L(XQJ),XQ1'<20 S XQS=XQS+1,XQ1=0 Q
 I '$L(XQJ),XQ1<20 S XQY=-1,XQ=0 Q
 I '$D(XQ(XQJ)) G C
 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
 Q
 ;
S ;Entry from XQ: Search primary, common, and secondary menus for XQUR
 I XQUR'?.ANP W $C(7) S XQY=-1 Q
 I XQPSM'="PXU" S XQDIC=$S($D(XQPSM):$P(XQPSM,"P",2),$D(XQDIC):XQDIC,1:XQY)
 E  S XQDIC="PXU"
 I '$D(XQTT) S XQTT=$G(^XUTL("XQ",$J,"T")) I XQTT="" S XQTT=1
 ;S:'$D(XQDIC) XQDIC=XQY S XQSV=XQY_U_XQDIC_U_XQY0
 S XQJ="",XQJMP=1,(XQ,XQ1,XQS,XQXT,XQY)=0
 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)
 S XQUR=XQO,(XQO,XQO1)=$E(XQUR,1,$L(XQUR)-1)_$C($A($E(XQUR,$L(XQUR)))-1)_"z"
 I '$D(^XUTL("XQ",$J,"XQM")) S ^("XQM")=+^VA(200,DUZ,201)
 ;I '$D(^XUTL("XQ",$J,"XQW")) S ^("XQW")=$P(^VA(200,DUZ,201),U,2)
 I $D(XQJS),XQJS G OUT
 ;
 ;Check the Primary Menu first
 S XQDIC="P"_^XUTL("XQ",$J,"XQM")
 ;If there's no master copy in ^DIC(19,"AXQ"), nothing to do.
 I '$D(^DIC(19,"AXQ",XQDIC,0)) D REACT^XQ84(DUZ) S XQY=-1 G OUT
 I '$D(^XUTL("XQO",XQDIC,0)) S XQSAVE=XQPSM,XQPSM=XQDIC D MERGE^XQ12 S XQPSM=XQSAVE
 S XQXUTL=$G(^XUTL("XQO",XQDIC,0)),XQDIC19=^DIC(19,"AXQ",XQDIC,0)
 I XQXUTL="" S XQXUTL=XQDIC19
 S %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2) I %>30 S XQSAVE=XQPSM,XQPSM=XQDIC D MERGE^XQ12 S XQPSM=XQSAVE
 ;If tree is not there or out of date, remerge it
 D X G:XQY<0 OUT G:XQUR="" W
 ;
 ;Look in XUCOMMAND
 S XQDIC="PXU"
 ;I $S('$D(^XUTL("XQO",XQDIC,0)):1,^XUTL("XQO",XQDIC,0)'=^DIC(19,"AXQ",XQDIC,0):1,1:0) D MGPXU^XQ12
 I '$D(^XUTL("XQO",XQDIC,0)) D MGPXU^XQ12
 S XQXUTL=$G(^XUTL("XQO",XQDIC,0)),XQDIC19=^DIC(19,"AXQ",XQDIC,0)
 I XQXUTL="" S XQXUTL=XQDIC19
 S %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2) I %>30 D MGPXU^XQ12
 S XQO=XQO1 D X G:XQY<0 OUT G:XQUR="" W
 ;
 ;Check the top level of the Secondaries
 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
 D X G:XQY<0 OUT G:XQUR="" W
 ;
 ;Check each secondary in depth
 F XQK=0:0 Q:XQY<0!(XQUR="")  S XQUD="U"_DUZ,XQK=$O(^XUTL("XQO",XQUD,U,XQK)) Q:XQK=""  D
 .S XQCY=XQK D ^XQCHK I XQCY>0,$P(^XUTL("XQO",XQUD,U,XQK),U,5)="M" D
 ..N XQSAVE
 ..S XQST=XQK,XQDIC="P"_XQK,XQO=XQO1
 ..I '$D(^DIC(19,"AXQ","P0")) D
 ...I '$D(^XUTL("XQO",XQDIC,0)) S XQSAVE=XQPSM D MERGE^XQ12 S XQPSM=XQSAVE
 ...S XQXUTL=$G(^XUTL("XQO",XQDIC,0)),XQDIC19=$G(^DIC(19,"AXQ",XQDIC,0))
 ...Q:XQDIC19=""  ;Nothing to merge, probably a new scondary
 ...I XQXUTL="" S XQXUTL=XQDIC19
 ...S %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2) I %>30 S XQSAVE=XQPSM,XQPSM=XQDIC D MERGE^XQ12 S XQPSM=XQSAVE
 ...Q
 ..D X Q:XQY<0!(XQUR="")
 ..Q
 .Q
 G:XQY<0 OUT
 G:XQUR="" W
 ;
 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",%)
 ;
 I XQ=1,XQS=0 D
 .N X
 .S %=XQ(1),XQY=+%,XQPSM=$P(%,U,3)
 .S XQDIC=$S($L(XQPSM,",")>1:$P(XQPSM,",",$L(XQPSM,",")),1:XQPSM)
 .S X=$G(^XUTL("XQO",XQDIC,U,XQY))
 .I X="" S X=$G(^DIC(19,"AXQ",XQDIC,U,XQY))
 .Q:X=""
 .S XQY0=$P(X,U,2,99),XQSFLG=""
 .Q
 I $D(XQSFLG) K XQSFLG G W
 ;
 I XQ>0,'$D(XQ(XQS*20+1)) S XQY=-1 G OUT
 D:XQ>0 C G:XQY<0 OUT I XQ=0 S XQY=-1 G OUT
 ;
W ;Write out remaining text and return to XQ
 ;G:$D(XQXFLG("GUI")) OUT
 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)
 E  W $E($P(XQY0,U,2),$L(XQUR)+1,99) W:$D(XQ("S",+XQY)) "   (",XQ("S",+XQY),")"
 ;
OUT ;Exit here
 K XQ
 N % S XQ=""
 I XQY>0,$D(^XUTL("XQO",XQDIC,"^",+XQY,0)) D
 .S %=$G(^XUTL("XQO",XQDIC,"^",+XQY,0)) I %="" D
 ..H 1 ;Micro surgery must have it wait a sec
 ..S %=$G(^XUTL("XQO",XQDIC,"^",+XQY,0))
 ..Q
 .Q:%=""
 .S:%>0 XQ=+%
 .F XQI=1:1:XQ D
 ..S %=$G(^XUTL("XQO",XQDIC,"^",XQY,0,XQI)) I %="" D
 ...H 1
 ...S %=$G(^XUTL("XQO",XQDIC,"^",XQY,0,XQI))
 ...Q
 ..I %]"" S XQ(XQI)=$P(%,U)
 ..Q
 .Q
 I XQ="" S XQ=0
 ;I XQY=-1,'$D(XQHLP) W $C(7),"  ??" S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99),XQUR=""
 ;
 K %,I,J,X,XQ1,XQAP,XQCY,XQCY0,XQDIC19,XQI,XQJ,XQJMP,XQK,XQO,XQO1,XQS,XQST,XQUD,XQXT,XQXUTL,XQYY,Y
 K XQ
 Q
 ;
FIND(XQDIC) ;The expected 0th node in ^XUTL is not here
 I '$D(XQDIC) Q 0
 N %,XQT1,XQT2
 S %=$G(^DIC(19,"AXQ",XQDIC,0))
 I '$L(%) Q 0
 I $D(^XTMP("XQO","NOFIND",XQDIC)) D
 .N XQT1,XQT2,XQFLG
 .S XQT1=$H,XQFLG=0
 .S XQT2=$G(^XTMP("XQO","NOFIND",XQDIC))
 .I '$L(XQT2) Q
 .I XQT2>XQT1 K ^XTMP("XQO","NOFIND",XQDIC) Q
 .I XQT1>XQT2!($P(XQT1,",",2)-$P(XQT2,",",2)>.300) D
 ..K ^XTMP("XQO","NOFIND",XQDIC)
 ..I XQDIC="PXU" S XQFLG=1 D MGPXU^XQ12
 ..I 'XQFLG D MERGE^XQ12
 ..Q
 .Q
 I '$D(^XTMP("XQO","NOFIND",XQDIC)) S ^(XQDIC)=$H
 Q %
 ;
P ;Entry point for '"' jump to XUCOMMAND options
 I XQUR'?.ANP!(XQUR[U) W $C(7)," ??" S XQY=-1 Q
 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)
 S XQUR=XQO ;,XQSV=XQY_U_XQDIC_U_XQY0
 S XQJ="",XQJMP=1,(XQ,XQ1,XQS,XQXT,XQY)=0
 S (XQO,XQO1)=$E(XQUR,1,$L(XQUR)-1)_$C($A($E(XQUR,$L(XQUR)))-1)_"z"
 S XQDIC="PXU" D X G:XQY<0 OUT G:XQUR="" W
 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",%)
 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
 D:XQ>0 C G:XQY<0 OUT I XQ=0&('XQXT) S XQY=-1 G OUT
 G OUT