XQ81 ;SEA/AMF/LUKE,SF/RWF,ISD/HGW - Build menu trees ;03/19/13 09:21
;;8.0;KERNEL;**81,116,157,253,478,614**;Jul 10, 1995;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;
BUILD ;
;
RD2 N XQSTAT S XQSTAT=$$STATUS()
I 'XQSTAT W !!,"Some one else is rebuilding menus. Sorry." Q
K ZTSK
D MICRO ;Turn off micro surgery for now
;
S XQSTART=$$HTE^XLFDT($H)
K XQFG W !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",!
S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND1 S XQVE=(Y=1)
S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND1 S XQBSEC=(Y=1)
;
I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND1 I Y=1 D
.S ZTRTN="QUE^XQ81",ZTIO=""
.S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")=""
.S ZTDESC="Build menu trees in ^DIC(19,""AXQ"")"
.D ^%ZTLOAD
.I $D(ZTSK),'XQVE W !!,"Task #: ",ZTSK,!
.Q
;
I $D(ZTSK) K ^DIC(19,"AXQ","P0") S XQALLDON="" G BLDEND
E S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0"):DILOCKTM
;
I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND1 G:Y'=1 RD2
;
KIDS ;Entry from KIDS
I '$D(XQSTAT),$D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS I 'XQSTAT W !!," Some one else is building menus. Sorry." K XQSTAT Q
I '$D(^DIC(19,"AXQ","P0","STOP")) D MICRO
I '$D(^DIC(19,"AXQ","P0")) S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0"):DILOCKTM
I '$D(XQVE) S XQFG=0,XQBSEC=1,XQVE=0
N XQNTREE,XQNDONE S (XQNTREE,XQNDONE)=0
;
;Set up the error trap so we can clear the screen if it blows
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XQ81"
E S X="ERR^XQ81",@^%ZOSF("TRAP")
;
;Set up the bar graph and window if not from KIDS
I '$D(XPDNM) D INIT^XPDID
I XPDIDVT D
.I $D(XPDIDTOT) S XQSAVTOT=XPDIDTOT
.S X="Rebuilding Menus" D TITLE^XPDID(X)
.S XPDIDTOT=50 ;Number of divisions in bar graph
.D UPDATE^XPDID(0)
.Q
;
S XQSTART=$$HTE^XLFDT($H)
W !!,"Starting Menu Rebuild: ",XQSTART
S XQFG=0 W !!,"Collecting primary menus in the New Person file..."
;
DQ ;Entry from taskman Write if $D(XQFG)
K ZTREQ
I '$D(XQSTART) S XQSTART=$$HTE^XLFDT($H)
N XQNOW,XQ8FLG,XQTASK
S XQ8FLG=0
S:'$D(XQNOW) XQNOW=$H
S ^DIC(19,"AXQ","P0")=XQNOW
S ^DIC(19,"AXQ","P0","STOP")=XQNOW ;Stop micro surgery if it's running
;
S XQSEC=1,XQ81T="" I 'XQVE H 1
S XQI="" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:XQI'=+XQI!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)=""
S XQI="U" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"U"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)=""
S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2,$L(^(0)) S XQ81T=^(0) Q
S:XQ81T="" XQ81T="Unknown"
S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I "P"[$E(XQI),XQI'="P0" K ^TMP("XQO",$J,XQI)
;
;Find the various trees and put them into ^TMP($J), and count them
S:'$D(XQH) XQH=$H K ^TMP($J) S XQI=.5 F XQK=0:0 S XQI=$O(^VA(200,XQI)) Q:XQI'=+XQI I $D(^VA(200,XQI,0)),$L($P(^VA(200,XQI,0),U,3)) D SET
;
S (XQNTREE,%)=0 F S %=$O(^TMP($J,%)) Q:%="" S XQNTREE=XQNTREE+1
S %=0 F S %=$O(^TMP($J,"SEC",%)) Q:%="" S XQNTREE=XQNTREE+1
;
W:$D(XQFG) !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------"
W:$D(XQFG) !!,"OPTION NAME MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",!
S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,XQBLD)) Q:XQBLD'>0!(X=U) I $D(^DIC(19,XQBLD,0)) S XQJ=^DIC(19,XQBLD,0) D VER
S XQSEC=0 I $D(XQFG),XQBSEC W !!,"Building secondary menu trees...."
I XQBSEC S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,"SEC",XQBLD)) Q:XQBLD'>0 D SEC
I 'XQVE S XQK="P" F XQBLD=0:0 S XQK=$O(^TMP("XQO",$J,XQK)) Q:XQK'["P" S ^(XQK,0)=XQH
G BLDEND
;
SEC S XQL="P"_XQBLD Q:$D(^TMP("XQO",$J,XQL)) D RD3 Q
S XQL="P" F XQN=0:0 S XQL=$O(^TMP("XQO",$J,XQL)) Q:$E(XQL)'="P" I $D(^TMP("XQO",$J,XQL,"^",XQBLD)) Q
D:$E(XQL)'="P" RD3
Q
;
VER I $D(XQFG) D
.N XQMT,XQOPNM
.S XQK=$P(^TMP($J,XQBLD),U,2)
.S:$L(XQK) XQK=$E(XQK,4,5)_"/"_$E(XQK,6,7)_"/"_$E(XQK,2,3)
.S XQOPNM=$P(XQJ,U)
.S XQMT=$P(XQJ,U,2) I $L(XQMT)>28 S XQMT=$E(XQMT,1,25)_"..."
.W !,$P(XQJ,U,1)
.W:($L(XQOPNM)>20) !
.W ?20,XQMT,?49,+^TMP($J,XQBLD),?60,XQK
.Q
;
I $D(XQFG) S:$D(^DIC(19,"AXQ","P"_XQBLD,0)) XQ81T=+^(0) I $L(XQ81T) S %H=XQ81T D YMD^%DTC S XQK=X W ?71,$E(XQK,4,5),"/",$E(XQK,6,7),"/",$E(XQK,2,3)
;
RD3 ;Update counter an rebuild it if necessary
I $D(XQFG),XPDIDVT D
.N %
.S XQNDONE=XQNDONE+1
.S %=(XQNDONE/XQNTREE)*XPDIDTOT
.D UPDATE^XPDID(%)
.Q
;
S XQDIC="P"_XQBLD D CHK^XQ8 I XQRE W:$D(XQFG) !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU" Q
I XQVE,XQSEC S DIR(0)="Y",DIR("A")="Rebuild",DIR("B")="YES" D ^DIR Q:$D(DIRUT) W ! Q:Y'=1
S XQFG1=1 D PM2^XQ8
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
SET G:'$D(^VA(200,XQI,201)) SET1 S XQK=+^(201) Q:'$L(XQK) ;I $D(XQFG) W:'(XQI#10) "."
S XQR="" S:$D(^VA(200,XQI,1.1)) XQR=$P(^(1.1),".",1) S XQP=1_U_XQR
I $D(^TMP($J,XQK)) S XQP=^TMP($J,XQK) S XQP=XQP+1_U_$S(XQR>$P(XQP,U,2):XQR,1:$P(XQP,U,2))
I $D(^DIC(19,XQK,0)),$P(^(0),U,4)="M" S ^TMP($J,XQK)=XQP
;
SET1 I XQBSEC F XQN=0:0 S XQN=$O(^VA(200,XQI,203,XQN)) Q:XQN'>0 S XQL=+^(XQN,0) I $D(^DIC(19,XQL,0)),$P(^(0),U,4)="M" S ^TMP($J,"SEC",XQL)=""
Q
;
QUE ;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL
;Also called by CHEK^XQ83
S XQVE=0,XQBSEC=1 K XQFG
S XQSTART=$$HTE^XLFDT($H)
G DQ
;
BLDEND ;File a report, cleanup, and quit.
;
K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ
;
I $D(XQALLDON) K XQALLDON Q ;Quit here if we're just creating a task
;
D MERGET
D CLEAN
D MERGEX
;
K ^TMP($J),^TMP("XQO",$J)
;
;Clear the flags and locks.
K ^XUTL("XQO","XQMERGED") ;Menus merged since last rebuild REACT^XQ84
K ^DIC(19,"AT") ;Micro message nodes
S ^XUTL("XQO","MICRO")=0 ;Number of Micro instances since last build
K ^DIC(19,"AXQ","P0","STOP") ;Allow Micro surgery to start up
K ^DIC(19,"AXQ","P0") ;Clear the rebuild flag (redundant, I know)
L -^DIC(19,"AXQ","P0") ;Unlock the rebuild flag, everybody's good to go
;
S %=$S($D(XPDNM):"KIDS",$D(ZTSK):"QUEUED",1:"LIVE")
D REPORT^XQ84(%)
K XQSTART,ZTSK
;
I '$D(XPDIDVT) K XQFG Q
;
I $D(XQFG),XPDIDVT F %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT D UPDATE^XPDID(%) H .25
I $D(XQFG),XPDIDVT D UPDATE^XPDID(XPDIDTOT)
I $D(XQFG) W !!,"Menu Rebuild Complete: ",$$HTE^XLFDT($H)
;
;
H 2
;If we're not from KIDS then clean it up, otherwise let kids do it.
I '$D(XPDNM) D
.D EXIT^XPDID()
.K XPDIDVT,XPDIDTOT
.Q
;
I $D(XQSAVTOT) S XPDIDTOT=XQSAVTOT
K %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT
Q
;
;================================Subroutines==========================
;
MERGET ;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ")
N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q=""""
I $D(XQFG) W !!,"Merging...."
F S X=$O(^TMP("XQO",$J,X)) Q:X="" D
.L +^DIC(19,"AXQ",X):2 I '$T S XQFLAG=1 Q
.S %X="^TMP(""XQO"","_$J_","_Q_X_Q_","
.S %Y="^DIC(19,""AXQ"","_Q_X_Q_","
.K ^DIC(19,"AXQ",X)
.;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X)
.D %XY^%RCR
.L -^DIC(19,"AXQ",X)
.K %X,%Y
.Q
;
I XQFLAG,$D(XQFG) D
.N %,Y
.S Y=$P(X,"P",2) Q:Y=""
.S %=$G(^DIC(19,Y,0)) Q:%=""
.S Y=$P(%,"^",2) Q:%=""
.W !,?12,"Could not merge menu: "_Y
.Q
Q
;
CLEAN ;Clean out unused menu trees from ^DIC(19,"AXQ")
N X,Y S X="P"
F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D
.I X'="PXU" D
..S Y=$E(X,2,99)
..I '$D(^TMP($J,Y))&('$D(^TMP($J,"SEC",Y))) K ^DIC(19,"AXQ",X),^XUTL("XQO",X)
..Q
.Q
Q
;
MERGEX ;Merge ^DIC(19,"AXQ") into ^XUTL("XQO")
N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q=""""
F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D
.L +^XUTL("XQO",X):2 I '$T S XQFLAG=1 Q
.S %X="^DIC(19,""AXQ"","_Q_X_Q_","
.S %Y="^XUTL(""XQO"","_Q_X_Q_","
.K ^XUTL("XQO",X)
.;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X)
.D %XY^%RCR
.L -^XUTL("XQO",X)
.K %X,%Y
.Q
;
I XQFLAG,$D(XQFG) D
.N %,Y
.S Y=$P(X,"P",2) Q:Y=""
.S %=$G(^DIC(19,Y,0)) Q:%=""
.S Y=$P(%,"^",2) Q:%=""
.W !,?12,"Could not merge menu: "_Y
.Q
;
I 'XQFLAG,$D(XQFG) W " done."
Q
;
STATUS() ;Are the menus being rebuilt even as we speak?
N %,XQTHEN
S %=$G(^DIC(19,"AXQ","P0")) I %="" Q 1 ;It finished. Never mind.
L +^DIC(19,"AXQ","P0"):0 ;If job is still running we can't lock it
I $T L -^DIC(19,"AXQ","P0") K ^("P0") Q 1 ;Job must have failed
Q 0
;
;
MICRO ;Turn off micro surgery
I $D(^DIC(19,"AXQ","P0","MICRO")) D
.S ^DIC(19,"AXQ","P0","STOP")=$H ;Turn off micro-surgery
.K ^DIC(19,"AXQ","P0","MICRO")
.H 2
.Q
Q
;
;
ERR ;Come here on error
N XQERROR
S XQERROR=$$EC^%ZOSV
D ^%ZTER
D EXIT^XPDID()
G UNWIND^%ZTER
Q
;
BLDEND1 ;Quit and clean
K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ81 9528 printed Oct 16, 2024@18:05:52 Page 2
XQ81 ;SEA/AMF/LUKE,SF/RWF,ISD/HGW - Build menu trees ;03/19/13 09:21
+1 ;;8.0;KERNEL;**81,116,157,253,478,614**;Jul 10, 1995;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
BUILD ;
+1 ;
RD2 NEW XQSTAT
SET XQSTAT=$$STATUS()
+1 IF 'XQSTAT
WRITE !!,"Some one else is rebuilding menus. Sorry."
QUIT
+2 KILL ZTSK
+3 ;Turn off micro surgery for now
DO MICRO
+4 ;
+5 SET XQSTART=$$HTE^XLFDT($HOROLOG)
+6 KILL XQFG
WRITE !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",!
+7 SET DIR(0)="Y"
SET DIR("A")="Do you wish to verify each primary menu"
SET DIR("B")="NO"
SET DIR("??")="XQBUILDTREE-VER"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO BLDEND1
SET XQVE=(Y=1)
+8 SET DIR(0)="Y"
SET DIR("A")="Would you like to build secondary menu trees too"
SET DIR("B")="YES"
SET DIR("??")="XQBUILDTREE-SEC"
DO ^DIR
if $DATA(DIRUT)
GOTO BLDEND1
SET XQBSEC=(Y=1)
+9 ;
+10 IF 'XQVE
SET DIR(0)="Y"
SET DIR("A")="Would you like to queue this job"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO BLDEND1
IF Y=1
Begin DoDot:1
+11 SET ZTRTN="QUE^XQ81"
SET ZTIO=""
+12 SET ZTSAVE("XQVE")=""
SET ZTSAVE("XQBSEC")=""
SET ZTSAVE("XQSTART")=""
+13 SET ZTDESC="Build menu trees in ^DIC(19,""AXQ"")"
+14 DO ^%ZTLOAD
+15 IF $DATA(ZTSK)
IF 'XQVE
WRITE !!,"Task #: ",ZTSK,!
+16 QUIT
End DoDot:1
+17 ;
+18 IF $DATA(ZTSK)
KILL ^DIC(19,"AXQ","P0")
SET XQALLDON=""
GOTO BLDEND
+19 IF '$TEST
SET ^DIC(19,"AXQ","P0")=$HOROLOG
LOCK +^DIC(19,"AXQ","P0"):DILOCKTM
+20 ;
+21 IF 'XQVE
SET DIR(0)="Y"
SET DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO BLDEND1
if Y'=1
GOTO RD2
+22 ;
KIDS ;Entry from KIDS
+1 IF '$DATA(XQSTAT)
IF $DATA(^DIC(19,"AXQ","P0"))
SET XQSTAT=$$STATUS
IF 'XQSTAT
WRITE !!," Some one else is building menus. Sorry."
KILL XQSTAT
QUIT
+2 IF '$DATA(^DIC(19,"AXQ","P0","STOP"))
DO MICRO
+3 IF '$DATA(^DIC(19,"AXQ","P0"))
SET ^DIC(19,"AXQ","P0")=$HOROLOG
LOCK +^DIC(19,"AXQ","P0"):DILOCKTM
+4 IF '$DATA(XQVE)
SET XQFG=0
SET XQBSEC=1
SET XQVE=0
+5 NEW XQNTREE,XQNDONE
SET (XQNTREE,XQNDONE)=0
+6 ;
+7 ;Set up the error trap so we can clear the screen if it blows
+8 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^XQ81"
+9 IF '$TEST
SET X="ERR^XQ81"
SET @^%ZOSF("TRAP")
+10 ;
+11 ;Set up the bar graph and window if not from KIDS
+12 IF '$DATA(XPDNM)
DO INIT^XPDID
+13 IF XPDIDVT
Begin DoDot:1
+14 IF $DATA(XPDIDTOT)
SET XQSAVTOT=XPDIDTOT
+15 SET X="Rebuilding Menus"
DO TITLE^XPDID(X)
+16 ;Number of divisions in bar graph
SET XPDIDTOT=50
+17 DO UPDATE^XPDID(0)
+18 QUIT
End DoDot:1
+19 ;
+20 SET XQSTART=$$HTE^XLFDT($HOROLOG)
+21 WRITE !!,"Starting Menu Rebuild: ",XQSTART
+22 SET XQFG=0
WRITE !!,"Collecting primary menus in the New Person file..."
+23 ;
DQ ;Entry from taskman Write if $D(XQFG)
+1 KILL ZTREQ
+2 IF '$DATA(XQSTART)
SET XQSTART=$$HTE^XLFDT($HOROLOG)
+3 NEW XQNOW,XQ8FLG,XQTASK
+4 SET XQ8FLG=0
+5 if '$DATA(XQNOW)
SET XQNOW=$HOROLOG
+6 SET ^DIC(19,"AXQ","P0")=XQNOW
+7 ;Stop micro surgery if it's running
SET ^DIC(19,"AXQ","P0","STOP")=XQNOW
+8 ;
+9 SET XQSEC=1
SET XQ81T=""
IF 'XQVE
HANG 1
+10 SET XQI=""
FOR XQK=0:0
SET XQI=$ORDER(^TMP("XQO",$JOB,XQI))
if XQI'=+XQI!(XQI="")
QUIT
IF $DATA(^TMP("XQO",$JOB,XQI,0))#2
SET $PIECE(^(0),U,2)=""
+11 SET XQI="U"
FOR XQK=0:0
SET XQI=$ORDER(^TMP("XQO",$JOB,XQI))
if "U"'[$EXTRACT(XQI)!(XQI="")
QUIT
IF $DATA(^TMP("XQO",$JOB,XQI,0))#2
SET $PIECE(^(0),U,2)=""
+12 SET XQI="P"
FOR XQK=0:0
SET XQI=$ORDER(^TMP("XQO",$JOB,XQI))
if "P"'[$EXTRACT(XQI)!(XQI="")
QUIT
IF $DATA(^TMP("XQO",$JOB,XQI,0))#2
IF $LENGTH(^(0))
SET XQ81T=^(0)
QUIT
+13 if XQ81T=""
SET XQ81T="Unknown"
+14 SET XQI="P"
FOR XQK=0:0
SET XQI=$ORDER(^TMP("XQO",$JOB,XQI))
if "P"'[$EXTRACT(XQI)!(XQI="")
QUIT
IF "P"[$EXTRACT(XQI)
IF XQI'="P0"
KILL ^TMP("XQO",$JOB,XQI)
+15 ;
+16 ;Find the various trees and put them into ^TMP($J), and count them
+17 if '$DATA(XQH)
SET XQH=$HOROLOG
KILL ^TMP($JOB)
SET XQI=.5
FOR XQK=0:0
SET XQI=$ORDER(^VA(200,XQI))
if XQI'=+XQI
QUIT
IF $DATA(^VA(200,XQI,0))
IF $LENGTH($PIECE(^VA(200,XQI,0),U,3))
DO SET
+18 ;
+19 SET (XQNTREE,%)=0
FOR
SET %=$ORDER(^TMP($JOB,%))
if %=""
QUIT
SET XQNTREE=XQNTREE+1
+20 SET %=0
FOR
SET %=$ORDER(^TMP($JOB,"SEC",%))
if %=""
QUIT
SET XQNTREE=XQNTREE+1
+21 ;
+22 if $DATA(XQFG)
WRITE !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------"
+23 if $DATA(XQFG)
WRITE !!,"OPTION NAME MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",!
+24 SET X=""
FOR XQBLD=0:0
SET XQBLD=$ORDER(^TMP($JOB,XQBLD))
if XQBLD'>0!(X=U)
QUIT
IF $DATA(^DIC(19,XQBLD,0))
SET XQJ=^DIC(19,XQBLD,0)
DO VER
+25 SET XQSEC=0
IF $DATA(XQFG)
IF XQBSEC
WRITE !!,"Building secondary menu trees...."
+26 IF XQBSEC
SET X=""
FOR XQBLD=0:0
SET XQBLD=$ORDER(^TMP($JOB,"SEC",XQBLD))
if XQBLD'>0
QUIT
DO SEC
+27 IF 'XQVE
SET XQK="P"
FOR XQBLD=0:0
SET XQK=$ORDER(^TMP("XQO",$JOB,XQK))
if XQK'["P"
QUIT
SET ^(XQK,0)=XQH
+28 GOTO BLDEND
+29 ;
SEC SET XQL="P"_XQBLD
if $DATA(^TMP("XQO",$JOB,XQL))
QUIT
DO RD3
QUIT
+1 SET XQL="P"
FOR XQN=0:0
SET XQL=$ORDER(^TMP("XQO",$JOB,XQL))
if $EXTRACT(XQL)'="P"
QUIT
IF $DATA(^TMP("XQO",$JOB,XQL,"^",XQBLD))
QUIT
+2 if $EXTRACT(XQL)'="P"
DO RD3
+3 QUIT
+4 ;
VER IF $DATA(XQFG)
Begin DoDot:1
+1 NEW XQMT,XQOPNM
+2 SET XQK=$PIECE(^TMP($JOB,XQBLD),U,2)
+3 if $LENGTH(XQK)
SET XQK=$EXTRACT(XQK,4,5)_"/"_$EXTRACT(XQK,6,7)_"/"_$EXTRACT(XQK,2,3)
+4 SET XQOPNM=$PIECE(XQJ,U)
+5 SET XQMT=$PIECE(XQJ,U,2)
IF $LENGTH(XQMT)>28
SET XQMT=$EXTRACT(XQMT,1,25)_"..."
+6 WRITE !,$PIECE(XQJ,U,1)
+7 if ($LENGTH(XQOPNM)>20)
WRITE !
+8 WRITE ?20,XQMT,?49,+^TMP($JOB,XQBLD),?60,XQK
+9 QUIT
End DoDot:1
+10 ;
+11 IF $DATA(XQFG)
if $DATA(^DIC(19,"AXQ","P"_XQBLD,0))
SET XQ81T=+^(0)
IF $LENGTH(XQ81T)
SET %H=XQ81T
DO YMD^%DTC
SET XQK=X
WRITE ?71,$EXTRACT(XQK,4,5),"/",$EXTRACT(XQK,6,7),"/",$EXTRACT(XQK,2,3)
+12 ;
RD3 ;Update counter an rebuild it if necessary
+1 IF $DATA(XQFG)
IF XPDIDVT
Begin DoDot:1
+2 NEW %
+3 SET XQNDONE=XQNDONE+1
+4 SET %=(XQNDONE/XQNTREE)*XPDIDTOT
+5 DO UPDATE^XPDID(%)
+6 QUIT
End DoDot:1
+7 ;
+8 SET XQDIC="P"_XQBLD
DO CHK^XQ8
IF XQRE
if $DATA(XQFG)
WRITE !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU"
QUIT
+9 IF XQVE
IF XQSEC
SET DIR(0)="Y"
SET DIR("A")="Rebuild"
SET DIR("B")="YES"
DO ^DIR
if $DATA(DIRUT)
QUIT
WRITE !
if Y'=1
QUIT
+10 SET XQFG1=1
DO PM2^XQ8
+11 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+12 QUIT
+13 ;
SET ;I $D(XQFG) W:'(XQI#10) "."
if '$DATA(^VA(200,XQI,201))
GOTO SET1
SET XQK=+^(201)
if '$LENGTH(XQK)
QUIT
+1 SET XQR=""
if $DATA(^VA(200,XQI,1.1))
SET XQR=$PIECE(^(1.1),".",1)
SET XQP=1_U_XQR
+2 IF $DATA(^TMP($JOB,XQK))
SET XQP=^TMP($JOB,XQK)
SET XQP=XQP+1_U_$SELECT(XQR>$PIECE(XQP,U,2):XQR,1:$PIECE(XQP,U,2))
+3 IF $DATA(^DIC(19,XQK,0))
IF $PIECE(^(0),U,4)="M"
SET ^TMP($JOB,XQK)=XQP
+4 ;
SET1 IF XQBSEC
FOR XQN=0:0
SET XQN=$ORDER(^VA(200,XQI,203,XQN))
if XQN'>0
QUIT
SET XQL=+^(XQN,0)
IF $DATA(^DIC(19,XQL,0))
IF $PIECE(^(0),U,4)="M"
SET ^TMP($JOB,"SEC",XQL)=""
+1 QUIT
+2 ;
QUE ;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL
+1 ;Also called by CHEK^XQ83
+2 SET XQVE=0
SET XQBSEC=1
KILL XQFG
+3 SET XQSTART=$$HTE^XLFDT($HOROLOG)
+4 GOTO DQ
+5 ;
BLDEND ;File a report, cleanup, and quit.
+1 ;
+2 KILL %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ
+3 ;
+4 ;Quit here if we're just creating a task
IF $DATA(XQALLDON)
KILL XQALLDON
QUIT
+5 ;
+6 DO MERGET
+7 DO CLEAN
+8 DO MERGEX
+9 ;
+10 KILL ^TMP($JOB),^TMP("XQO",$JOB)
+11 ;
+12 ;Clear the flags and locks.
+13 ;Menus merged since last rebuild REACT^XQ84
KILL ^XUTL("XQO","XQMERGED")
+14 ;Micro message nodes
KILL ^DIC(19,"AT")
+15 ;Number of Micro instances since last build
SET ^XUTL("XQO","MICRO")=0
+16 ;Allow Micro surgery to start up
KILL ^DIC(19,"AXQ","P0","STOP")
+17 ;Clear the rebuild flag (redundant, I know)
KILL ^DIC(19,"AXQ","P0")
+18 ;Unlock the rebuild flag, everybody's good to go
LOCK -^DIC(19,"AXQ","P0")
+19 ;
+20 SET %=$SELECT($DATA(XPDNM):"KIDS",$DATA(ZTSK):"QUEUED",1:"LIVE")
+21 DO REPORT^XQ84(%)
+22 KILL XQSTART,ZTSK
+23 ;
+24 IF '$DATA(XPDIDVT)
KILL XQFG
QUIT
+25 ;
+26 IF $DATA(XQFG)
IF XPDIDVT
FOR %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT
DO UPDATE^XPDID(%)
HANG .25
+27 IF $DATA(XQFG)
IF XPDIDVT
DO UPDATE^XPDID(XPDIDTOT)
+28 IF $DATA(XQFG)
WRITE !!,"Menu Rebuild Complete: ",$$HTE^XLFDT($HOROLOG)
+29 ;
+30 ;
+31 HANG 2
+32 ;If we're not from KIDS then clean it up, otherwise let kids do it.
+33 IF '$DATA(XPDNM)
Begin DoDot:1
+34 DO EXIT^XPDID()
+35 KILL XPDIDVT,XPDIDTOT
+36 QUIT
End DoDot:1
+37 ;
+38 IF $DATA(XQSAVTOT)
SET XPDIDTOT=XQSAVTOT
+39 KILL %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT
+40 QUIT
+41 ;
+42 ;================================Subroutines==========================
+43 ;
MERGET ;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ")
+1 NEW Q,X,XQFLAG,Y
SET X="P"
SET XQFLAG=0
SET Q=""""
+2 IF $DATA(XQFG)
WRITE !!,"Merging...."
+3 FOR
SET X=$ORDER(^TMP("XQO",$JOB,X))
if X=""
QUIT
Begin DoDot:1
+4 LOCK +^DIC(19,"AXQ",X):2
IF '$TEST
SET XQFLAG=1
QUIT
+5 SET %X="^TMP(""XQO"","_$JOB_","_Q_X_Q_","
+6 SET %Y="^DIC(19,""AXQ"","_Q_X_Q_","
+7 KILL ^DIC(19,"AXQ",X)
+8 ;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X)
+9 DO %XY^%RCR
+10 LOCK -^DIC(19,"AXQ",X)
+11 KILL %X,%Y
+12 QUIT
End DoDot:1
+13 ;
+14 IF XQFLAG
IF $DATA(XQFG)
Begin DoDot:1
+15 NEW %,Y
+16 SET Y=$PIECE(X,"P",2)
if Y=""
QUIT
+17 SET %=$GET(^DIC(19,Y,0))
if %=""
QUIT
+18 SET Y=$PIECE(%,"^",2)
if %=""
QUIT
+19 WRITE !,?12,"Could not merge menu: "_Y
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
CLEAN ;Clean out unused menu trees from ^DIC(19,"AXQ")
+1 NEW X,Y
SET X="P"
+2 FOR
SET X=$ORDER(^DIC(19,"AXQ",X))
if X=""
QUIT
Begin DoDot:1
+3 IF X'="PXU"
Begin DoDot:2
+4 SET Y=$EXTRACT(X,2,99)
+5 IF '$DATA(^TMP($JOB,Y))&('$DATA(^TMP($JOB,"SEC",Y)))
KILL ^DIC(19,"AXQ",X),^XUTL("XQO",X)
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
MERGEX ;Merge ^DIC(19,"AXQ") into ^XUTL("XQO")
+1 NEW Q,X,XQFLAG,Y
SET X="P"
SET XQFLAG=0
SET Q=""""
+2 FOR
SET X=$ORDER(^DIC(19,"AXQ",X))
if X=""
QUIT
Begin DoDot:1
+3 LOCK +^XUTL("XQO",X):2
IF '$TEST
SET XQFLAG=1
QUIT
+4 SET %X="^DIC(19,""AXQ"","_Q_X_Q_","
+5 SET %Y="^XUTL(""XQO"","_Q_X_Q_","
+6 KILL ^XUTL("XQO",X)
+7 ;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X)
+8 DO %XY^%RCR
+9 LOCK -^XUTL("XQO",X)
+10 KILL %X,%Y
+11 QUIT
End DoDot:1
+12 ;
+13 IF XQFLAG
IF $DATA(XQFG)
Begin DoDot:1
+14 NEW %,Y
+15 SET Y=$PIECE(X,"P",2)
if Y=""
QUIT
+16 SET %=$GET(^DIC(19,Y,0))
if %=""
QUIT
+17 SET Y=$PIECE(%,"^",2)
if %=""
QUIT
+18 WRITE !,?12,"Could not merge menu: "_Y
+19 QUIT
End DoDot:1
+20 ;
+21 IF 'XQFLAG
IF $DATA(XQFG)
WRITE " done."
+22 QUIT
+23 ;
STATUS() ;Are the menus being rebuilt even as we speak?
+1 NEW %,XQTHEN
+2 ;It finished. Never mind.
SET %=$GET(^DIC(19,"AXQ","P0"))
IF %=""
QUIT 1
+3 ;If job is still running we can't lock it
LOCK +^DIC(19,"AXQ","P0"):0
+4 ;Job must have failed
IF $TEST
LOCK -^DIC(19,"AXQ","P0")
KILL ^("P0")
QUIT 1
+5 QUIT 0
+6 ;
+7 ;
MICRO ;Turn off micro surgery
+1 IF $DATA(^DIC(19,"AXQ","P0","MICRO"))
Begin DoDot:1
+2 ;Turn off micro-surgery
SET ^DIC(19,"AXQ","P0","STOP")=$HOROLOG
+3 KILL ^DIC(19,"AXQ","P0","MICRO")
+4 HANG 2
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
+8 ;
ERR ;Come here on error
+1 NEW XQERROR
+2 SET XQERROR=$$EC^%ZOSV
+3 DO ^%ZTER
+4 DO EXIT^XPDID()
+5 GOTO UNWIND^%ZTER
+6 QUIT
+7 ;
BLDEND1 ;Quit and clean
+1 KILL %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ
+2 QUIT
