49 lines
3.3 KiB
Mathematica
49 lines
3.3 KiB
Mathematica
XQ71 ;SEA/AMF,MJM - Lookup response to menu prompt ;04/16/2002 13:47
|
|
;;8.0;KERNEL;**154,157**;Jul 10, 1995
|
|
CHK ;See if this option is locked, out of order, etc.
|
|
S XQJMP=0,XQA=1,XQCY=XQY S:'$D(XQNOXUTL) XQCY0=XQY0 D ^XQCHK I XQCY<0 S XQY=-1
|
|
Q
|
|
NO ;Space bar option no longer in the Option File
|
|
K ^DISV(DUZ,"XQ",XQMN) S XQY=-1
|
|
;
|
|
OUT ;Exit point: return to XQ
|
|
K %,%Y,%XQ,XQ,XQ2,XQA,XQA3,XQCY,XQCY0,XQI,XQII,XQIO,XQJ,XQK,XQMN,XQNOAV,XQNOXUTL,XQQ,XQS,XQSAV,XQW,XQX,XQZ
|
|
Q
|
|
;
|
|
U I XQX'?.ANP S XQX="?" Q
|
|
;
|
|
UP S XQX=$$UP^XLFSTR(XQX) ;F XQZ=1:1 Q:XQX?.NUP S XQW=$A(XQX,XQZ) I XQW<123,XQW>96 S XQX=$E(XQX,1,XQZ-1)_$C(XQW-32)_$E(XQX,XQZ+1,255)
|
|
Q
|
|
;
|
|
XBLK F S XQW=$E(XQK,1) Q:XQW'=" " S XQK=$E(XQK,2,99)
|
|
Q
|
|
;
|
|
DIC ;Entry point from XQ
|
|
S XQNOAV=0,XQUR=$E(XQUR,1,27),XQMN=XQDIC,XQX=XQUR D U:XQX'?.PUN S XQUR=XQX
|
|
I XQX=" ",$D(^DISV(DUZ,"XQ",XQMN)) S XQY=^(XQMN) G:'($D(^XUTL("XQO",XQDIC,U,XQY))&$D(^DIC(19,XQY,0))) NO S XQY0=^(0),XQNOXUTL="" D CHK W:$L($P(XQY,U,2)) !,$P(XQY,U,2) S XQY=+XQY I XQY>0 S XQUR="" G W
|
|
I XQY=-1,$D(XQNOXUTL) K ^DISV(DUZ,"XQ",XQMN),XQNOXUTL S XQY=-2 G OUT
|
|
I $E(XQDIC,1)="P" S XQDIC=$E(XQDIC,2,99) ;Remove the "P" this is not a jump
|
|
;I $S($D(^XUTL("XQO","P0")):1,'$D(^XUTL("XQO",XQDIC,0)):1,'$D(^DIC(19,$E(XQDIC,2,99),99.1)):1,1:0) D PMO^XQ8 S XQY=-2 G OUT
|
|
I XQDIC=+XQDIC L +^XUTL("XQO",XQDIC):5 D:$S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^DIC(19,XQDIC,99)):1,1:^DIC(19,XQDIC,99)'=$P(^XUTL("XQO",XQDIC,0),U,2)) ^XQSET L -^XUTL("XQO",XQDIC)
|
|
I $E(XQDIC,1)="U" 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
|
|
S (XQ,XQS)=0 S:XQUR="0" XQUR="0"_$C(1) I XQUR="?" S X=0 G X
|
|
S X=XQUR,XQA3=$S(($E(XQDIC,1)="P"):XQUR_U,1:XQUR) G:'$D(^XUTL("XQO",XQDIC,XQA3)) X S X=$E(XQUR,1,$L(XQUR)-1)_$C($A($E(XQUR,$L(XQUR)))-1)_"z" G:($P($O(^XUTL("XQO",XQDIC,XQA3)),U,1)=XQUR) X
|
|
S XQSAV=X
|
|
S %XQ=^XUTL("XQO",XQDIC,XQA3),XQY=+%XQ,XQY0=$P(^("^",XQY),U,2,99) D CHK S X=XQSAV W:$L($P(XQY,U,2)) " ",$P(XQY0,U,2),$C(7),!,$P(XQY,U,2) S:$L($P(XQY,U,2)) XQNOAV=1 S:XQY<1 X=$O(^XUTL("XQO",XQDIC,X)) G X:XQY<1 I '$P(%XQ,U,2) W " " S XQUR=""
|
|
;
|
|
W W $E($P(XQY0,U,2),$L(XQUR)+1,99) K XQ S:(XQMN=+XQMN) ^DISV(DUZ,"XQ",XQMN)=XQY G OUT
|
|
;
|
|
X S X=$O(^XUTL("XQO",XQDIC,X)) S XQJ=$S(X="":0,XQUR="?":X'=U,XQUR=("0"_$C(1)):'$L($P(X,"0",1)),1:'$L($P(X,XQUR,1)))
|
|
I XQJ S XQY=^XUTL("XQO",XQDIC,X) S:'$P(XQY,U,2) XQ("S",+XQY)="" S XQY=+XQY G:$D(XQ("X",XQY)) X S XQY0=$P(^("^",XQY),U,2,99) S XQQ=X D CHK S X=XQQ G:XQY'>0 X S XQ=XQ+1,XQ(XQ)=+XQY_U_$P(XQY0,U,2)_U_XQA_U_$P(XQY,U,2),XQ("X",XQY)="" G:XQ>19 C G X
|
|
S:'XQ XQY=-1 S:XQNOAV XQY=-2 Q:'XQ I XQ=1,XQS=0 S XQY=+XQ(1) I XQY>0 S XQY0=$P(^XUTL("XQO",XQDIC,"^",XQY),U,2,99),XQA=$P(XQ(1),U,3) S:$D(XQ("S",XQY)) XQUR="" W:'$L(XQUR) " " G W
|
|
I XQ=1,XQS=0 W $E($P(XQ(1),U,2),$L(XQUR)+1,99),$C(7),!,$P(XQ(1),U,4) S XQY=-2 G OUT
|
|
;
|
|
C F XQY=1:1:XQ W !?4,XQS*20+XQY,?9,$P(XQ(XQY),U,2),?43,$P(XQ(XQY),U,4)
|
|
W:XQ>19 !,"TYPE '^' TO STOP, OR" W !,"CHOOSE ",(XQS*20+1),"-",(XQS*20+XQY),": "
|
|
R XQJ:DTIME S:'$T XQJ=U G:$L(XQJ)>7 C I XQJ?1.7N G C:'$D(XQ(XQJ-1#20+1)) W " " S XQUR="",XQY=+XQ(XQJ-1#20+1) I XQY>0 S XQY0=$P(^XUTL("XQO",XQDIC,"^",XQY),U,2,99),XQA=$P(XQ(XQJ-1#20+1),U,3) G W
|
|
I XQJ?1.7N W $C(7),$P(XQ(XQJ-1#20+1),U,4),! G C
|
|
I $L(XQJ)>7 G C
|
|
I '$L(XQJ),XQ>19 K XQ S XQS=XQS+1,XQ=0 G X
|
|
S:XQJ=U XQJ="" K XQ S XQY=-1,XQUR=$C(95) S:$L(XQJ) XQUR=$S($E(XQDIC,1)="P":U_XQJ,1:XQJ),XQY=0 G OUT
|
|
Q
|