- 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 Feb 18, 2025@23:31:28 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