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/XQ71.m@ 1765

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

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1XQ71 ;SEA/AMF,MJM - Lookup response to menu prompt ;04/16/2002 13:47
2 ;;8.0;KERNEL;**154,157**;Jul 10, 1995
3CHK ;See if this option is locked, out of order, etc.
4 S XQJMP=0,XQA=1,XQCY=XQY S:'$D(XQNOXUTL) XQCY0=XQY0 D ^XQCHK I XQCY<0 S XQY=-1
5 Q
6NO ;Space bar option no longer in the Option File
7 K ^DISV(DUZ,"XQ",XQMN) S XQY=-1
8 ;
9OUT ;Exit point: return to XQ
10 K %,%Y,%XQ,XQ,XQ2,XQA,XQA3,XQCY,XQCY0,XQI,XQII,XQIO,XQJ,XQK,XQMN,XQNOAV,XQNOXUTL,XQQ,XQS,XQSAV,XQW,XQX,XQZ
11 Q
12 ;
13U I XQX'?.ANP S XQX="?" Q
14 ;
15UP 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)
16 Q
17 ;
18XBLK F S XQW=$E(XQK,1) Q:XQW'=" " S XQK=$E(XQK,2,99)
19 Q
20 ;
21DIC ;Entry point from XQ
22 S XQNOAV=0,XQUR=$E(XQUR,1,27),XQMN=XQDIC,XQX=XQUR D U:XQX'?.PUN S XQUR=XQX
23 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
24 I XQY=-1,$D(XQNOXUTL) K ^DISV(DUZ,"XQ",XQMN),XQNOXUTL S XQY=-2 G OUT
25 I $E(XQDIC,1)="P" S XQDIC=$E(XQDIC,2,99) ;Remove the "P" this is not a jump
26 ;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
27 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)
28 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
29 S (XQ,XQS)=0 S:XQUR="0" XQUR="0"_$C(1) I XQUR="?" S X=0 G X
30 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
31 S XQSAV=X
32 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=""
33 ;
34W W $E($P(XQY0,U,2),$L(XQUR)+1,99) K XQ S:(XQMN=+XQMN) ^DISV(DUZ,"XQ",XQMN)=XQY G OUT
35 ;
36X 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)))
37 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
38 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
39 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
40 ;
41C F XQY=1:1:XQ W !?4,XQS*20+XQY,?9,$P(XQ(XQY),U,2),?43,$P(XQ(XQY),U,4)
42 W:XQ>19 !,"TYPE '^' TO STOP, OR" W !,"CHOOSE ",(XQS*20+1),"-",(XQS*20+XQY),": "
43 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
44 I XQJ?1.7N W $C(7),$P(XQ(XQJ-1#20+1),U,4),! G C
45 I $L(XQJ)>7 G C
46 I '$L(XQJ),XQ>19 K XQ S XQS=XQS+1,XQ=0 G X
47 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
48 Q
Note: See TracBrowser for help on using the repository browser.