XQ75 ;SEA/AMF,LUKE,JLI,BT - Lookup response for jumps ;6/14/2011
;;8.0;KERNEL;**47,46,157,253,553,570**;Jul 10, 1995;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified
;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)!'$$CHCKTM(XQY) 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
;
CHCKTM(XQIEN) ;check Restriction time/date
N X,Y
S Y=+$G(XQIEN) I Y'>0 Q 0
D NEXT^XQ92 I X'<$$NOW^XLFDT,$G(%XQOP)=3.91 Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ75 8168 printed Oct 16, 2024@18:05:50 Page 2
XQ75 ;SEA/AMF,LUKE,JLI,BT - Lookup response for jumps ;6/14/2011
+1 ;;8.0;KERNEL;**47,46,157,253,553,570**;Jul 10, 1995;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+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 ;
X ;Unless exact match is found, find all possibilities in any XQDIC
+1 SET XQO=$ORDER(^XUTL("XQO",XQDIC,XQO))
if '$SELECT(XQO=""
QUIT
+2 SET XQYY=^XUTL("XQO",XQDIC,XQO)
SET XQY=+XQYY
if $DATA(XQ("X",+XQY))
GOTO X
SET %=$GET(^XUTL("XQO",XQDIC,"^",+XQY))
if %=""
GOTO X
SET XQY0=$PIECE(%,U,2,99)
+3 SET XQCY=XQY
SET XQCY0=XQY0
DO ^XQCHK
IF (XQCY<0)!'$$CHCKTM(XQY)
SET XQY=0
GOTO X
+4 if '$PIECE(XQYY,U,2)
SET XQ("S",+XQY)=$PIECE(XQO,U)
+5 IF XQUR=$PIECE(XQO,U)
IF 'XQS
SET XQXT=XQXT+1
SET XQXT(XQXT)=+XQY_U_$PIECE(XQY0,U,2)_" ["_$PIECE(XQY0,U)_"] "_U_$SELECT($DATA(XQUD):XQUD_",",1:"")_XQDIC
SET XQXT("X",XQY)=""
if '$PIECE(XQYY,U,2)
SET XQXT("S",+XQY)=$PIECE(XQO,U)
+6 SET XQ=XQ+1
SET XQ1=XQ1+1
SET XQ(XQ)=+XQY_U_$PIECE(XQY0,U,2)_" ["_$PIECE(XQY0,U)_"] "_U_$SELECT($DATA(XQUD):XQUD_",",1:"")_XQDIC
SET XQ("X",XQY)=""
+7 IF XQ1>19
IF 'XQXT
DO C
+8 if XQY<0!(XQUR="")
QUIT
GOTO X
+9 QUIT
+10 ;
C ;Display a screen-load of 19 possibilities and ask for a choice
+1 ;I $G(XQXFLG("GUI")) D Q
+2 ;.D LIST^XQGS1(XQ)
+3 ;.S XQUR=""
+4 ;.Q:XQY<0
+5 ;.S %="" F S %=$O(XQ(%)) Q:%=""!(%'=+%) I XQY=+XQ(%) S XQPSM=$P(XQ(%),U,3)
+6 ;.Q
+7 if XQ1<1
SET XQ1=XQ
WRITE !
FOR XQI=1:1:XQ1
SET XQJ=XQS*20+XQI
WRITE !?4,XQJ,?9,$PIECE(XQ(XQJ),U,2)
IF $DATA(XQ("S",+XQ(XQJ)))
WRITE ?43," (",XQ("S",+XQ(XQJ)),")"
ASK WRITE !!,"Type '^' to stop, or choose a number from 1 to ",XQ," :"
+1 READ XQJ:DTIME
if '$TEST
SET XQJ=U
if XQJ["?"
WRITE !!,"**> Choose an item from this list by selecting its corresponding number,",!?5,"or type a '^' to return to your menu.",!
if XQJ["?"
GOTO ASK
+2 IF XQJ=U
SET XQY=-1
SET XQ=0
QUIT
+3 IF XQJ'?1N.N
IF $LENGTH(XQJ)
IF XQJ'=U
WRITE $CHAR(7)," ??",!
GOTO ASK
+4 IF XQJ?1N.N
if '$DATA(XQ(XQJ))
GOTO C
Begin DoDot:1
+5 NEW %,XQD,XQP,Y
+6 SET %=XQ(XQJ)
SET Y=+%
IF Y>0
Begin DoDot:2
+7 SET XQP=$PIECE(%,U,3)
SET XQD=$SELECT($LENGTH(XQP,",")>1:$PIECE(XQP,",",$LENGTH(XQP,",")),1:XQP)
+8 SET XQY0=$GET(^XUTL("XQO",XQD,"^",Y))
SET XQY0=$PIECE(XQY0,U,2,99)
+9 IF XQY0=""
KILL XQ(XQJ)
SET XQ=XQ-1
SET XQJ=""
QUIT
End DoDot:2
+10 IF $LENGTH(XQJ)
IF $DATA(XQ(XQJ))
SET XQY=Y
SET XQDIC=XQD
SET XQPSM=XQP
SET XQUR=""
WRITE " "
QUIT
+11 QUIT
End DoDot:1
if $DATA(XQ(+XQJ))
QUIT
+12 IF XQJ?1N.N
WRITE $CHAR(7),$PIECE(XQ(XQJ-1#20+1),U,4),!
GOTO C
+13 IF '$LENGTH(XQJ)
IF XQ1'<20
SET XQS=XQS+1
SET XQ1=0
QUIT
+14 IF '$LENGTH(XQJ)
IF XQ1<20
SET XQY=-1
SET XQ=0
QUIT
+15 IF '$DATA(XQ(XQJ))
GOTO C
+16 KILL XQ
SET XQY=$SELECT(XQJ=U:-3,XQJ="":-3,1:-1)
SET XQUR=$CHAR(95)
if XQJ=U
SET XQJ=""
SET XQY=-1
if $LENGTH(XQJ)
SET XQUR=$SELECT($EXTRACT(XQDIC,1)="P":U_XQJ,1:XQJ)
SET XQY=0
QUIT
+17 QUIT
+18 ;
S ;Entry from XQ: Search primary, common, and secondary menus for XQUR
+1 IF XQUR'?.ANP
WRITE $CHAR(7)
SET XQY=-1
QUIT
+2 IF XQPSM'="PXU"
SET XQDIC=$SELECT($DATA(XQPSM):$PIECE(XQPSM,"P",2),$DATA(XQDIC):XQDIC,1:XQY)
+3 IF '$TEST
SET XQDIC="PXU"
+4 IF '$DATA(XQTT)
SET XQTT=$GET(^XUTL("XQ",$JOB,"T"))
IF XQTT=""
SET XQTT=1
+5 ;S:'$D(XQDIC) XQDIC=XQY S XQSV=XQY_U_XQDIC_U_XQY0
+6 SET XQJ=""
SET XQJMP=1
SET (XQ,XQ1,XQS,XQXT,XQY)=0
+7 ;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)
SET XQO=$EXTRACT(XQUR,1,30)
IF XQUR'?.PUN
SET XQO=$$UP^XLFSTR(XQO)
+8 SET XQUR=XQO
SET (XQO,XQO1)=$EXTRACT(XQUR,1,$LENGTH(XQUR)-1)_$CHAR($ASCII($EXTRACT(XQUR,$LENGTH(XQUR)))-1)_"z"
+9 IF '$DATA(^XUTL("XQ",$JOB,"XQM"))
SET ^("XQM")=+^VA(200,DUZ,201)
+10 ;I '$D(^XUTL("XQ",$J,"XQW")) S ^("XQW")=$P(^VA(200,DUZ,201),U,2)
+11 IF $DATA(XQJS)
IF XQJS
GOTO OUT
+12 ;
+13 ;Check the Primary Menu first
+14 SET XQDIC="P"_^XUTL("XQ",$JOB,"XQM")
+15 ;If there's no master copy in ^DIC(19,"AXQ"), nothing to do.
+16 IF '$DATA(^DIC(19,"AXQ",XQDIC,0))
DO REACT^XQ84(DUZ)
SET XQY=-1
GOTO OUT
+17 IF '$DATA(^XUTL("XQO",XQDIC,0))
SET XQSAVE=XQPSM
SET XQPSM=XQDIC
DO MERGE^XQ12
SET XQPSM=XQSAVE
+18 SET XQXUTL=$GET(^XUTL("XQO",XQDIC,0))
SET XQDIC19=^DIC(19,"AXQ",XQDIC,0)
+19 IF XQXUTL=""
SET XQXUTL=XQDIC19
+20 SET %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2)
IF %>30
SET XQSAVE=XQPSM
SET XQPSM=XQDIC
DO MERGE^XQ12
SET XQPSM=XQSAVE
+21 ;If tree is not there or out of date, remerge it
+22 DO X
if XQY<0
GOTO OUT
if XQUR=""
GOTO W
+23 ;
+24 ;Look in XUCOMMAND
+25 SET XQDIC="PXU"
+26 ;I $S('$D(^XUTL("XQO",XQDIC,0)):1,^XUTL("XQO",XQDIC,0)'=^DIC(19,"AXQ",XQDIC,0):1,1:0) D MGPXU^XQ12
+27 IF '$DATA(^XUTL("XQO",XQDIC,0))
DO MGPXU^XQ12
+28 SET XQXUTL=$GET(^XUTL("XQO",XQDIC,0))
SET XQDIC19=^DIC(19,"AXQ",XQDIC,0)
+29 IF XQXUTL=""
SET XQXUTL=XQDIC19
+30 SET %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2)
IF %>30
DO MGPXU^XQ12
+31 SET XQO=XQO1
DO X
if XQY<0
GOTO OUT
if XQUR=""
GOTO W
+32 ;
+33 ;Check the top level of the Secondaries
+34 SET XQDIC="U"_DUZ
SET XQO=XQO1
if $SELECT('$DATA(^XUTL("XQO",XQDIC,0))
DO ^XQSET
IF '$DATA(^XUTL("XQO",XQDIC,0))
IF 'XQXT
DO C
if XQY<0
GOTO OUT
if XQUR=""
GOTO W
+35 DO X
if XQY<0
GOTO OUT
if XQUR=""
GOTO W
+36 ;
+37 ;Check each secondary in depth
+38 FOR XQK=0:0
if XQY<0!(XQUR="")
QUIT
SET XQUD="U"_DUZ
SET XQK=$ORDER(^XUTL("XQO",XQUD,U,XQK))
if XQK=""
QUIT
Begin DoDot:1
+39 SET XQCY=XQK
DO ^XQCHK
IF XQCY>0
IF $PIECE(^XUTL("XQO",XQUD,U,XQK),U,5)="M"
Begin DoDot:2
+40 NEW XQSAVE
+41 SET XQST=XQK
SET XQDIC="P"_XQK
SET XQO=XQO1
+42 IF '$DATA(^DIC(19,"AXQ","P0"))
Begin DoDot:3
+43 IF '$DATA(^XUTL("XQO",XQDIC,0))
SET XQSAVE=XQPSM
DO MERGE^XQ12
SET XQPSM=XQSAVE
+44 SET XQXUTL=$GET(^XUTL("XQO",XQDIC,0))
SET XQDIC19=$GET(^DIC(19,"AXQ",XQDIC,0))
+45 ;Nothing to merge, probably a new scondary
if XQDIC19=""
QUIT
+46 IF XQXUTL=""
SET XQXUTL=XQDIC19
+47 SET %=$$HDIFF^XLFDT(XQDIC19,XQXUTL,2)
IF %>30
SET XQSAVE=XQPSM
SET XQPSM=XQDIC
DO MERGE^XQ12
SET XQPSM=XQSAVE
+48 QUIT
End DoDot:3
+49 DO X
if XQY<0!(XQUR="")
QUIT
+50 QUIT
End DoDot:2
+51 QUIT
End DoDot:1
+52 if XQY<0
GOTO OUT
+53 if XQUR=""
GOTO W
+54 ;
+55 IF XQXT
KILL XQ
SET (XQ,XQ1)=XQXT
FOR XQI=1:1:XQ
SET XQ(XQI)=XQXT(XQI)
SET %=+XQ(XQI)
SET XQ("X",%)=""
IF $DATA(XQXT("S",%))
SET XQ("S",%)=XQXT("S",%)
+56 ;
+57 IF XQ=1
IF XQS=0
Begin DoDot:1
+58 NEW X
+59 SET %=XQ(1)
SET XQY=+%
SET XQPSM=$PIECE(%,U,3)
+60 SET XQDIC=$SELECT($LENGTH(XQPSM,",")>1:$PIECE(XQPSM,",",$LENGTH(XQPSM,",")),1:XQPSM)
+61 SET X=$GET(^XUTL("XQO",XQDIC,U,XQY))
+62 IF X=""
SET X=$GET(^DIC(19,"AXQ",XQDIC,U,XQY))
+63 if X=""
QUIT
+64 SET XQY0=$PIECE(X,U,2,99)
SET XQSFLG=""
+65 QUIT
End DoDot:1
+66 IF $DATA(XQSFLG)
KILL XQSFLG
GOTO W
+67 ;
+68 IF XQ>0
IF '$DATA(XQ(XQS*20+1))
SET XQY=-1
GOTO OUT
+69 if XQ>0
DO C
if XQY<0
GOTO OUT
IF XQ=0
SET XQY=-1
GOTO OUT
+70 ;
W ;Write out remaining text and return to XQ
+1 ;G:$D(XQXFLG("GUI")) OUT
+2 IF $DATA(XQ("S",+XQY))
IF XQUR=$EXTRACT(XQ("S",+XQY),1,$LENGTH(XQUR))
WRITE $EXTRACT(XQ("S",+XQY),$LENGTH(XQUR)+1,99)," ",$PIECE(XQY0,U,2)
+3 IF '$TEST
WRITE $EXTRACT($PIECE(XQY0,U,2),$LENGTH(XQUR)+1,99)
if $DATA(XQ("S",+XQY))
WRITE " (",XQ("S",+XQY),")"
+4 ;
OUT ;Exit here
+1 KILL XQ
+2 NEW %
SET XQ=""
+3 IF XQY>0
IF $DATA(^XUTL("XQO",XQDIC,"^",+XQY,0))
Begin DoDot:1
+4 SET %=$GET(^XUTL("XQO",XQDIC,"^",+XQY,0))
IF %=""
Begin DoDot:2
+5 ;Micro surgery must have it wait a sec
HANG 1
+6 SET %=$GET(^XUTL("XQO",XQDIC,"^",+XQY,0))
+7 QUIT
End DoDot:2
+8 if %=""
QUIT
+9 if %>0
SET XQ=+%
+10 FOR XQI=1:1:XQ
Begin DoDot:2
+11 SET %=$GET(^XUTL("XQO",XQDIC,"^",XQY,0,XQI))
IF %=""
Begin DoDot:3
+12 HANG 1
+13 SET %=$GET(^XUTL("XQO",XQDIC,"^",XQY,0,XQI))
+14 QUIT
End DoDot:3
+15 IF %]""
SET XQ(XQI)=$PIECE(%,U)
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF XQ=""
SET XQ=0
+19 ;I XQY=-1,'$D(XQHLP) W $C(7)," ??" S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99),XQUR=""
+20 ;
+21 KILL %,I,J,X,XQ1,XQAP,XQCY,XQCY0,XQDIC19,XQI,XQJ,XQJMP,XQK,XQO,XQO1,XQS,XQST,XQUD,XQXT,XQXUTL,XQYY,Y
+22 KILL XQ
+23 QUIT
+24 ;
FIND(XQDIC) ;The expected 0th node in ^XUTL is not here
+1 IF '$DATA(XQDIC)
QUIT 0
+2 NEW %,XQT1,XQT2
+3 SET %=$GET(^DIC(19,"AXQ",XQDIC,0))
+4 IF '$LENGTH(%)
QUIT 0
+5 IF $DATA(^XTMP("XQO","NOFIND",XQDIC))
Begin DoDot:1
+6 NEW XQT1,XQT2,XQFLG
+7 SET XQT1=$HOROLOG
SET XQFLG=0
+8 SET XQT2=$GET(^XTMP("XQO","NOFIND",XQDIC))
+9 IF '$LENGTH(XQT2)
QUIT
+10 IF XQT2>XQT1
KILL ^XTMP("XQO","NOFIND",XQDIC)
QUIT
+11 IF XQT1>XQT2!($PIECE(XQT1,",",2)-$PIECE(XQT2,",",2)>.300)
Begin DoDot:2
+12 KILL ^XTMP("XQO","NOFIND",XQDIC)
+13 IF XQDIC="PXU"
SET XQFLG=1
DO MGPXU^XQ12
+14 IF 'XQFLG
DO MERGE^XQ12
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 IF '$DATA(^XTMP("XQO","NOFIND",XQDIC))
SET ^(XQDIC)=$HOROLOG
+18 QUIT %
+19 ;
P ;Entry point for '"' jump to XUCOMMAND options
+1 IF XQUR'?.ANP!(XQUR[U)
WRITE $CHAR(7)," ??"
SET XQY=-1
QUIT
+2 ;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)
SET XQO=XQUR
IF XQUR'?.PUN
SET XQO=$$UP^XLFSTR(XQO)
+3 ;,XQSV=XQY_U_XQDIC_U_XQY0
SET XQUR=XQO
+4 SET XQJ=""
SET XQJMP=1
SET (XQ,XQ1,XQS,XQXT,XQY)=0
+5 SET (XQO,XQO1)=$EXTRACT(XQUR,1,$LENGTH(XQUR)-1)_$CHAR($ASCII($EXTRACT(XQUR,$LENGTH(XQUR)))-1)_"z"
+6 SET XQDIC="PXU"
DO X
if XQY<0
GOTO OUT
if XQUR=""
GOTO W
+7 IF XQXT
KILL XQ
SET XQ=XQXT
FOR XQI=1:1:XQ
SET XQ(XQI)=XQXT(XQI)
SET %=+XQ(XQI)
SET XQ("X",%)=""
IF $DATA(XQXT("S",%))
SET XQ("S",%)=XQXT("S",%)
+8 IF XQ=1
IF XQS=0
SET %=XQ(1)
SET XQY=+%
SET XQPSM=$PIECE(%,U,3)
SET XQDIC=$SELECT($LENGTH(XQPSM,",")>1:$PIECE(XQPSM,",",$LENGTH(XQPSM,",")),1:XQPSM)
SET XQY0=$PIECE(^XUTL("XQO",XQDIC,U,XQY),U,2,99)
GOTO OUT
+9 if XQ>0
DO C
if XQY<0
GOTO OUT
IF XQ=0&('XQXT)
SET XQY=-1
GOTO OUT
+10 GOTO OUT
+11 ;
CHCKTM(XQIEN) ;check Restriction time/date
+1 NEW X,Y
+2 SET Y=+$GET(XQIEN)
IF Y'>0
QUIT 0
+3 DO NEXT^XQ92
IF X'<$$NOW^XLFDT
IF $GET(%XQOP)=3.91
QUIT 0
+4 QUIT 1
