Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XQ75

XQ75.m

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