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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ71 3430 printed Dec 13, 2024@02:04:57 Page 2
XQ71 ;SEA/AMF,MJM - Lookup response to menu prompt ;04/16/2002 13:47
+1 ;;8.0;KERNEL;**154,157**;Jul 10, 1995
CHK ;See if this option is locked, out of order, etc.
+1 SET XQJMP=0
SET XQA=1
SET XQCY=XQY
if '$DATA(XQNOXUTL)
SET XQCY0=XQY0
DO ^XQCHK
IF XQCY<0
SET XQY=-1
+2 QUIT
NO ;Space bar option no longer in the Option File
+1 KILL ^DISV(DUZ,"XQ",XQMN)
SET XQY=-1
+2 ;
OUT ;Exit point: return to XQ
+1 KILL %,%Y,%XQ,XQ,XQ2,XQA,XQA3,XQCY,XQCY0,XQI,XQII,XQIO,XQJ,XQK,XQMN,XQNOAV,XQNOXUTL,XQQ,XQS,XQSAV,XQW,XQX,XQZ
+2 QUIT
+3 ;
U IF XQX'?.ANP
SET XQX="?"
QUIT
+1 ;
UP ;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)
SET XQX=$$UP^XLFSTR(XQX)
+1 QUIT
+2 ;
XBLK FOR
SET XQW=$EXTRACT(XQK,1)
if XQW'=" "
QUIT
SET XQK=$EXTRACT(XQK,2,99)
+1 QUIT
+2 ;
DIC ;Entry point from XQ
+1 SET XQNOAV=0
SET XQUR=$EXTRACT(XQUR,1,27)
SET XQMN=XQDIC
SET XQX=XQUR
if XQX'?.PUN
DO U
SET XQUR=XQX
+2 IF XQX=" "
IF $DATA(^DISV(DUZ,"XQ",XQMN))
SET XQY=^(XQMN)
if '($DATA(^XUTL("XQO",XQDIC,U,XQY))&$DATA(^DIC(19,XQY,0)))
GOTO NO
SET XQY0=^(0)
SET XQNOXUTL=""
DO CHK
if $LENGTH($PIECE(XQY,U,2))
WRITE !,$PIECE(XQY,U,2)
SET XQY=+XQY
IF XQY>0
SET XQUR=""
GOTO W
+3 IF XQY=-1
IF $DATA(XQNOXUTL)
KILL ^DISV(DUZ,"XQ",XQMN),XQNOXUTL
SET XQY=-2
GOTO OUT
+4 ;Remove the "P" this is not a jump
IF $EXTRACT(XQDIC,1)="P"
SET XQDIC=$EXTRACT(XQDIC,2,99)
+5 ;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
+6 IF XQDIC=+XQDIC
LOCK +^XUTL("XQO",XQDIC):5
if $SELECT('$DATA(^XUTL("XQO",XQDIC,0))
DO ^XQSET
LOCK -^XUTL("XQO",XQDIC)
+7 IF $EXTRACT(XQDIC,1)="U"
if $SELECT('$DATA(^XUTL("XQO",XQDIC,0))
DO ^XQSET
+8 SET (XQ,XQS)=0
if XQUR="0"
SET XQUR="0"_$CHAR(1)
IF XQUR="?"
SET X=0
GOTO X
+9 SET X=XQUR
SET XQA3=$SELECT(($EXTRACT(XQDIC,1)="P"):XQUR_U,1:XQUR)
if '$DATA(^XUTL("XQO",XQDIC,XQA3))
GOTO X
SET X=$EXTRACT(XQUR,1,$LENGTH(XQUR)-1)_$CHAR($ASCII($EXTRACT(XQUR,$LENGTH(XQUR)))-1)_"z"
if ($PIECE($ORDER(^XUTL("XQO",XQDIC,XQA3)),U,1)=XQUR)
GOTO X
+10 SET XQSAV=X
+11 SET %XQ=^XUTL("XQO",XQDIC,XQA3)
SET XQY=+%XQ
SET XQY0=$PIECE(^("^",XQY),U,2,99)
DO CHK
SET X=XQSAV
if $LENGTH($PIECE(XQY,U,2))
WRITE " ",$PIECE(XQY0,U,2),$CHAR(7),!,$PIECE(XQY,U,2)
if $LENGTH($PIECE(XQY,U,2))
SET XQNOAV=1
if XQY<1
SET X=$ORDER(^XUTL("XQO",XQDIC,X))
if XQY<1
GOTO X
IF '$PIECE(%XQ,U,2)
WRITE " "
SET XQUR=""
+12 ;
W WRITE $EXTRACT($PIECE(XQY0,U,2),$LENGTH(XQUR)+1,99)
KILL XQ
if (XQMN=+XQMN)
SET ^DISV(DUZ,"XQ",XQMN)=XQY
GOTO OUT
+1 ;
X SET X=$ORDER(^XUTL("XQO",XQDIC,X))
SET XQJ=$SELECT(X="":0,XQUR="?":X'=U,XQUR=("0"_$CHAR(1)):'$LENGTH($PIECE(X,"0",1)),1:'$LENGTH($PIECE(X,XQUR,1)))
+1 IF XQJ
SET XQY=^XUTL("XQO",XQDIC,X)
if '$PIECE(XQY,U,2)
SET XQ("S",+XQY)=""
SET XQY=+XQY
if $DATA(XQ("X",XQY))
GOTO X
SET XQY0=$PIECE(^("^",XQY),U,2,99)
SET XQQ=X
DO CHK
SET X=XQQ
if XQY'>0
GOTO X
SET XQ=XQ+1
SET XQ(XQ)=+XQY_U_$PIECE(XQY0,U,2)_U_XQA_U_$PIECE(XQY,U,2)
SET XQ("X",XQY)=""
if XQ>19
GOTO C
GOTO X
+2 if 'XQ
SET XQY=-1
if XQNOAV
SET XQY=-2
if 'XQ
QUIT
IF XQ=1
IF XQS=0
SET XQY=+XQ(1)
IF XQY>0
SET XQY0=$PIECE(^XUTL("XQO",XQDIC,"^",XQY),U,2,99)
SET XQA=$PIECE(XQ(1),U,3)
if $DATA(XQ("S",XQY))
SET XQUR=""
if '$LENGTH(XQUR)
WRITE " "
GOTO W
+3 IF XQ=1
IF XQS=0
WRITE $EXTRACT($PIECE(XQ(1),U,2),$LENGTH(XQUR)+1,99),$CHAR(7),!,$PIECE(XQ(1),U,4)
SET XQY=-2
GOTO OUT
+4 ;
C FOR XQY=1:1:XQ
WRITE !?4,XQS*20+XQY,?9,$PIECE(XQ(XQY),U,2),?43,$PIECE(XQ(XQY),U,4)
+1 if XQ>19
WRITE !,"TYPE '^' TO STOP, OR"
WRITE !,"CHOOSE ",(XQS*20+1),"-",(XQS*20+XQY),": "
+2 READ XQJ:DTIME
if '$TEST
SET XQJ=U
if $LENGTH(XQJ)>7
GOTO C
IF XQJ?1.7N
if '$DATA(XQ(XQJ-1#20+1))
GOTO C
WRITE " "
SET XQUR=""
SET XQY=+XQ(XQJ-1#20+1)
IF XQY>0
SET XQY0=$PIECE(^XUTL("XQO",XQDIC,"^",XQY),U,2,99)
SET XQA=$PIECE(XQ(XQJ-1#20+1),U,3)
GOTO W
+3 IF XQJ?1.7N
WRITE $CHAR(7),$PIECE(XQ(XQJ-1#20+1),U,4),!
GOTO C
+4 IF $LENGTH(XQJ)>7
GOTO C
+5 IF '$LENGTH(XQJ)
IF XQ>19
KILL XQ
SET XQS=XQS+1
SET XQ=0
GOTO X
+6 if XQJ=U
SET XQJ=""
KILL XQ
SET XQY=-1
SET XQUR=$CHAR(95)
if $LENGTH(XQJ)
SET XQUR=$SELECT($EXTRACT(XQDIC,1)="P":U_XQJ,1:XQJ)
SET XQY=0
GOTO OUT
+7 QUIT
