XQ84 ;SEA/LUKE,ISD/HGW - Menu Rebuild Utilities ;06/06/13 12:59
;;8.0;KERNEL;**157,253,614,629**;Jul 10, 1995;Build 17
;Per VHA Directive 2004-038, this routine should not be modified.
;
SHOW ; Show what's in the global ^XUTL("XQO","REBUILDS")
; ZEXCEPT: DIRUT,DUOUT,IOF,IOSL ; Kernel exemptions
I '$D(^XUTL("XQO","REBUILDS")) W !," Sorry, there is no data in the global ^XUTL(""XQO"",""REBUILDS"") to show you.",! Q
;
N %,XQI,XQNL,XQNI,XQNT
N XQB,XQE,XQBY,XQTYPE,XQT,XQUCI,XQJ
;
I '$D(IOF) D HOME^%ZIS
W @IOF
S XQNL=0 ;Line counter
S XQNI=1 ;Item or occurance counter
S XQNT=$S($D(IOSL):IOSL-4,1:18) ;Number of lines on the screen
;
D TITLE
D TOP
;
S XQI=0
F Q:$D(DIRUT) S XQI=$O(^XUTL("XQO","REBUILDS",XQI)) Q:XQI="" D
.S %=^XUTL("XQO","REBUILDS",XQI)
.S XQBY=$P($P(%,U,3),","),XQBY=$E(XQBY,1,12)
.S XQB=$P(%,U,1),XQE=$P(%,U,2),XQTYPE=$P(%,U,4),XQT=$P(%,U,5)
.S XQUCI=" Location: "_$P(%,U,6,8)
.S XQJ=" Job #: "_$P(%,U,9)
.D WRITE
.Q
;
K DIRUT,DUOUT
Q
;
WRITE ;Write an entry unless the screen is full
; ZEXCEPT: IOF,XQB,XQBY,XQE,XQJ,XQNI,XQNL,XQNT,XQT,XQTYPE,XQUCI ; Kernel exemptions
I XQNL>XQNT D
.D WAIT Q:$D(DIRUT)
.W @IOF
.S XQNL=0
.D TOP
.Q
Q:$D(DIRUT)
W !,XQNI,".",?4,XQB,?28,XQE,?51,XQBY,?60,XQTYPE,?71,XQT,!,XQUCI,XQJ,!
S XQNL=XQNL+3,XQNI=XQNI+1
Q
;
TOP ; Format the top of the page
; ZEXCEPT: XQNL ; Kernel exemption
W !,?11,"Start",?35,"End",?53,"By",?59,"Type/Name",?72,"Task #",!
S XQNL=XQNL+2
Q
;
TITLE ;What is this all about?
; ZEXCEPT: XQNL ; Kernel exemption
N %
S %=$G(^XUTL("XQO","MICRO"))
W ?36,"Recent Menu Rebuilds",!
S XQNL=XQNL+2
W ?14,$S(%>0:%,1:"No")_" instances of Micro Surgery since last rebuild."
S XQNL=XQNL+2
Q
;
WAIT ;That's a screen load hold it here for a minute
; ZEXCEPT: DIR ; Kernel exemption
N X,Y
S DIR(0)="E" D ^DIR K DIR
Q
;
USER ;Rebuild the menu trees of a specific user
;called by the option XQBUILDUSER
; ZEXCEPT: XQCNTS,XQREACTS,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ; Kernel exemptions
; ZEXCEPT: XTMUNIT,ZZ8XUN - Variables set for unit testing
N XUN,XQCNT,XQSEC,XQREACT,XQPRIM,XQFL
S (XQCNT,XQSEC)=0
; Select user
S XUN=$G(ZZ8XUN)
I '$D(XTMUNIT) D
. S XUN=+$$LOOKUP^XUSER Q:XUN'>0
S XQPRIM=$G(^VA(200,XUN,201)) I XQPRIM'>0 W !!,"No Primary Menu defined for this user." Q
; Build array of options
S XQCNT=1,XQREACT(XQCNT)=XQPRIM
F S XQSEC=$O(^VA(200,XUN,203,"B",XQSEC)) Q:XQSEC'=+XQSEC D
. Q:'$D(^DIC(19,XQSEC,0)) ;Bad pointer don't use it
. I $P(^DIC(19,XQSEC,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)=XQSEC
. Q
;
M XQREACTS=XQREACT ;Save the originals
S XQCNTS=XQCNT
;
S XQFL=$$FLAG(.XQREACT,.XQCNT)
I (XQFL=1)&('$D(XTMUNIT)) D
. N DIR
. S DIR(0)="Y"
. S DIR("A")=" Are you sure you want to force a rebuild? "
. S DIR("A",1)=" ***WARNING*** "
. S DIR("A",2)=" Someone else may be rebuilding these trees right now."
. S DIR("?")=" Enter 'Y' to force a rebuild, 'N' to quit."
. D ^DIR
. I Y=1 D
. . M XQREACT=XQREACTS ;Restore original list of menus
. . S XQCNT=XQCNTS
. . S XQFL=0
. . Q
. Q
;
Q:XQFL ;Flags are set, let's not mess with it.
;
I '$D(XTMUNIT) D
. S DIR(0)="Y",DIR("A")=" Queue this rebuild? ",DIR("B")="Y"
. S DIR("?")=" Please enter 'Y'es or 'N'o."
. D ^DIR I Y=1 D
. . S ZTRTN="REACTQ^XQ84"
. . S ZTSAVE("XUN")=""
. . S ZTSAVE("XQREACT(")="",ZTSAVE("XQCNT")=""
. . S ZTIO="",ZTDTH=$H
. . S ZTDESC="Rebuild "_$P(^VA(200,XUN,0),U)_"'s menu trees (DUZ="_XUN_")"
. . D ^%ZTLOAD
. . I $D(ZTSK) W !!," Task number: ",ZTSK
. Q
K DIR,Y
;
I '$D(ZTSK) D REACTQ I '$D(XTMUNIT) W !!," Done."
K ZTSK
Q
;
REACT(XUN) ;From XUSERNEW, check trees for reactivated user
; ZEXCEPT: XQQUE,XQUEUED,XWB,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ; Kernel exemptions
;
N XQCNT,XQSEC,XQREACT,XQPRIM,XQCHAT
S XQCHAT=1 I $D(XQUEUED)!$D(XWB) S XQCHAT=0 ;Anybody out there?
S XQPRIM=$G(^VA(200,XUN,201)) I 'XQPRIM,'$D(XQQUE) W:XQCHAT !!,"** WARNING ** No Primary Menu defined." Q
I (XQPRIM'=+XQPRIM)!($G(^DIC(19,XQPRIM,0))="") Q
S (XQCNT,XQSEC)=0
I XQPRIM,'$D(^DIC(19,"AXQ","P"_XQPRIM)),$P(^DIC(19,XQPRIM,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)="P"_XQPRIM
F S XQSEC=$O(^VA(200,XUN,203,"B",XQSEC)) Q:XQSEC'=+XQSEC D
.Q:'$D(^DIC(19,XQSEC,0)) ;Bad pointer don't use it
.I '$D(^DIC(19,"AXQ","P"_XQSEC)),$P(^DIC(19,XQSEC,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)="P"_XQSEC
.Q
;
Q:XQCNT=0 ;The menu trees look OK to me.
;
N %
S %=$$FLAG(.XQREACT,.XQCNT) ;Are we already merging them (1)
Q:%
;
I XQCNT>0 D
.S ZTRTN="REACTQ^XQ84"
.S ZTSAVE("XQREACT(")="",ZTSAVE("XUN")=""
.S ZTIO="",ZTDTH=$H
.S ZTDESC="Rebuild reactivated user's menu trees (DUZ="_XUN_")"
.D ^%ZTLOAD
.K ZTSK
.Q
Q
;
FLAG(XQARRAY,XQNUM1) ;Should we build a particular array of trees
;Input: XQARRAY - array of trees e.g. P106, etc. XQNUM1 number of trees
;Output: 0 - There are trees to rebuild, 1 - Trees are already flagged
;Merge flags e.g. [^XUTL("XQO","XQMERGED","P106)=$H] are set here
; and killed in REACTQ+16
;
N %,XQNUM,XQPXU S XQNUM=0
S %=$$STATUS^XQ81() I '% Q 1 ;Menus rebuilding
S XQPXU=$G(^DIC(19,"AXQ","PXU",0)) Q:XQPXU="" 1
S %="" F S %=$O(XQARRAY(%)) Q:%="" D
.N X
.S X=XQARRAY(%)
.I $D(^XUTL("XQO","XQMERGED",X)) D
..N Y,Z
..S Y=$G(^XUTL("XQO","XQMERGED",X)) Q:Y="" ;Flag's gone
..S Z=$$HDIFF^XLFDT(XQPXU,Y)
..I Z>0 K ^XUTL("XQO","XQMERGED",X) ;Old Flag
..Q
.I $D(^XUTL("XQO","XQMERGED",X)) K XQARRAY(%) Q
.S ^XUTL("XQO","XQMERGED",X)=$H,XQNUM=XQNUM+1 ;We'll merge this one
.Q
I XQNUM>0 S XQNUM1=XQNUM Q 0 ;There are some left to rebuild
Q 1
;
REACTQ ;Queued job to rebuild a reactivated user's menu trees
; can also be run in real time by USER (above)
; ZEXCEPT: D,I,W,X,XQFG1,XQK,XQQUE,XQREACT,XQSTAT,XQXUF,XUN,Y,Z,ZTQUEUED,ZTREQ ; Kernel exemptions
N % S %=0
K ZTREQ ;Don't delete the task information
I $D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS^XQ81 Q:'XQSTAT ;Menus are being rebuilt
Q:'$D(XQREACT) ;Nothing to rebuild
;
D MICRO^XQ81 ;Turn off Micro Surgery
S ^DIC(19,"AXQ","P0")=$H
N XQCNT,XQDIC S XQCNT=""
K ^TMP($J),^TMP("XQO",$J)
F S XQCNT=$O(XQREACT(XQCNT)) Q:XQCNT="" D
.S (XQFG1,XQXUF)="",XQDIC="P"_XQREACT(XQCNT)
.D PM2^XQ8
.Q:'$D(^TMP("XQO",$J,XQDIC))
.M ^DIC(19,"AXQ",XQDIC)=^TMP("XQO",$J,XQDIC) ;D MERGET^XQ81
.M ^XUTL("XQO",XQDIC)=^DIC(19,"AXQ",XQDIC) ;D MERGEX^XQ81
.K ^XUTL("XQO","XQMERGED",XQREACT(XQCNT))
.Q
N DUZ S DUZ=XUN S XQDIC="U"_XUN D NEWSET^XQSET
K ^DIC(19,"AXQ","P0"),^TMP($J),^TMP("XQO",$J)
D REPORT($E($P(^VA(200,XUN,0),U),1,9))
K ^DIC(19,"AXQ","P0","STOP")
K D,I,W,X,XQK,XQQUE,XQXUF,Y,Z
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
REPORT(XQTYPE) ;Tell us what happened.
; ZEXCEPT: XQSTART,ZTSK ; Kernel exemptions
N %,X,XQI,XQJ,XQK,XQLINE,XQEND,Y
I '$D(^XUTL("XQO","MICRO")) S ^XUTL("XQO","MICRO")=0
I XQTYPE["MICRO" S ^XUTL("XQO","MICRO")=^XUTL("XQO","MICRO")+1 Q ;Update Micro count
S XQEND=$$HTE^XLFDT($H)
I '$D(XQSTART) S XQSTART=XQEND
S XQLINE=XQSTART_"^"_XQEND_"^"_$P(^VA(200,DUZ,0),U,1)_"^"
S X=XQTYPE K XQTYPE
S Y=$S($D(ZTSK):ZTSK,1:"LIVE")
S XQLINE=XQLINE_X_"^"_Y
D GETENV^%ZOSV
S XQLINE=XQLINE_"^"_$P(Y,"^",1,3)_"^"_$J
I $D(^XUTL("XQO","REBUILDS")) D
.S (XQJ,XQK)=0
.F S XQJ=$O(^XUTL("XQO","REBUILDS",XQJ)) Q:XQJ=""!(XQJ=49) S XQK=XQK+1
.F XQI=XQK:-1:1 S ^XUTL("XQO","REBUILDS",XQI+1)=^(XQI)
.Q
S ^XUTL("XQO","REBUILDS",1)=XQLINE
Q
;
NOW ;Is there a rebuild of any kind running right now?
N % S %=0
I $D(^DIC(19,"AXQ","P0","MICRO")) D
.W !!?6,"Micro surgery is currently updating the compiled menus."
.I $D(^DIC(19,"AXQ","AXQ","STOP")) D
..W !?6,"... but it has been instructed to stop."
..Q
.S %=47
.Q
Q:%=47
I $D(^DIC(19,"AXQ","P0")) D
.W !!?6," A complete menu rebuild is currently running."
.S %=47
.Q
Q:%=47
W !!?6,"There is no menu rebuild activity running on your system right now."
Q
;
REBUILD(RESULT) ; RPC. [XU REBUILD MENU TREE] public (p629)
; input - none (uses DUZ)
; output - 0 if unsuccessful, 1 if successful
N XUN,XQPRIM,XQSEC,XQREACT,XQCNT
S RESULT=0
S XUN=DUZ
S XQPRIM=$G(^VA(200,XUN,201)) I XQPRIM'>0 Q 0 ; No Primary Menu defined for this user
S XQCNT=1,XQREACT(XQCNT)=XQPRIM,XQSEC=0
F S XQSEC=$O(^VA(200,XUN,203,"B",XQSEC)) Q:XQSEC'=+XQSEC D
.Q:'$D(^DIC(19,XQSEC,0)) ;Bad pointer don't use it
.I $P(^DIC(19,XQSEC,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)=XQSEC
.Q
;
D REACTQ
S RESULT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ84 8625 printed Oct 16, 2024@18:05:58 Page 2
XQ84 ;SEA/LUKE,ISD/HGW - Menu Rebuild Utilities ;06/06/13 12:59
+1 ;;8.0;KERNEL;**157,253,614,629**;Jul 10, 1995;Build 17
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
SHOW ; Show what's in the global ^XUTL("XQO","REBUILDS")
+1 ; ZEXCEPT: DIRUT,DUOUT,IOF,IOSL ; Kernel exemptions
+2 IF '$DATA(^XUTL("XQO","REBUILDS"))
WRITE !," Sorry, there is no data in the global ^XUTL(""XQO"",""REBUILDS"") to show you.",!
QUIT
+3 ;
+4 NEW %,XQI,XQNL,XQNI,XQNT
+5 NEW XQB,XQE,XQBY,XQTYPE,XQT,XQUCI,XQJ
+6 ;
+7 IF '$DATA(IOF)
DO HOME^%ZIS
+8 WRITE @IOF
+9 ;Line counter
SET XQNL=0
+10 ;Item or occurance counter
SET XQNI=1
+11 ;Number of lines on the screen
SET XQNT=$SELECT($DATA(IOSL):IOSL-4,1:18)
+12 ;
+13 DO TITLE
+14 DO TOP
+15 ;
+16 SET XQI=0
+17 FOR
if $DATA(DIRUT)
QUIT
SET XQI=$ORDER(^XUTL("XQO","REBUILDS",XQI))
if XQI=""
QUIT
Begin DoDot:1
+18 SET %=^XUTL("XQO","REBUILDS",XQI)
+19 SET XQBY=$PIECE($PIECE(%,U,3),",")
SET XQBY=$EXTRACT(XQBY,1,12)
+20 SET XQB=$PIECE(%,U,1)
SET XQE=$PIECE(%,U,2)
SET XQTYPE=$PIECE(%,U,4)
SET XQT=$PIECE(%,U,5)
+21 SET XQUCI=" Location: "_$PIECE(%,U,6,8)
+22 SET XQJ=" Job #: "_$PIECE(%,U,9)
+23 DO WRITE
+24 QUIT
End DoDot:1
+25 ;
+26 KILL DIRUT,DUOUT
+27 QUIT
+28 ;
WRITE ;Write an entry unless the screen is full
+1 ; ZEXCEPT: IOF,XQB,XQBY,XQE,XQJ,XQNI,XQNL,XQNT,XQT,XQTYPE,XQUCI ; Kernel exemptions
+2 IF XQNL>XQNT
Begin DoDot:1
+3 DO WAIT
if $DATA(DIRUT)
QUIT
+4 WRITE @IOF
+5 SET XQNL=0
+6 DO TOP
+7 QUIT
End DoDot:1
+8 if $DATA(DIRUT)
QUIT
+9 WRITE !,XQNI,".",?4,XQB,?28,XQE,?51,XQBY,?60,XQTYPE,?71,XQT,!,XQUCI,XQJ,!
+10 SET XQNL=XQNL+3
SET XQNI=XQNI+1
+11 QUIT
+12 ;
TOP ; Format the top of the page
+1 ; ZEXCEPT: XQNL ; Kernel exemption
+2 WRITE !,?11,"Start",?35,"End",?53,"By",?59,"Type/Name",?72,"Task #",!
+3 SET XQNL=XQNL+2
+4 QUIT
+5 ;
TITLE ;What is this all about?
+1 ; ZEXCEPT: XQNL ; Kernel exemption
+2 NEW %
+3 SET %=$GET(^XUTL("XQO","MICRO"))
+4 WRITE ?36,"Recent Menu Rebuilds",!
+5 SET XQNL=XQNL+2
+6 WRITE ?14,$SELECT(%>0:%,1:"No")_" instances of Micro Surgery since last rebuild."
+7 SET XQNL=XQNL+2
+8 QUIT
+9 ;
WAIT ;That's a screen load hold it here for a minute
+1 ; ZEXCEPT: DIR ; Kernel exemption
+2 NEW X,Y
+3 SET DIR(0)="E"
DO ^DIR
KILL DIR
+4 QUIT
+5 ;
USER ;Rebuild the menu trees of a specific user
+1 ;called by the option XQBUILDUSER
+2 ; ZEXCEPT: XQCNTS,XQREACTS,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ; Kernel exemptions
+3 ; ZEXCEPT: XTMUNIT,ZZ8XUN - Variables set for unit testing
+4 NEW XUN,XQCNT,XQSEC,XQREACT,XQPRIM,XQFL
+5 SET (XQCNT,XQSEC)=0
+6 ; Select user
+7 SET XUN=$GET(ZZ8XUN)
+8 IF '$DATA(XTMUNIT)
Begin DoDot:1
+9 SET XUN=+$$LOOKUP^XUSER
if XUN'>0
QUIT
End DoDot:1
+10 SET XQPRIM=$GET(^VA(200,XUN,201))
IF XQPRIM'>0
WRITE !!,"No Primary Menu defined for this user."
QUIT
+11 ; Build array of options
+12 SET XQCNT=1
SET XQREACT(XQCNT)=XQPRIM
+13 FOR
SET XQSEC=$ORDER(^VA(200,XUN,203,"B",XQSEC))
if XQSEC'=+XQSEC
QUIT
Begin DoDot:1
+14 ;Bad pointer don't use it
if '$DATA(^DIC(19,XQSEC,0))
QUIT
+15 IF $PIECE(^DIC(19,XQSEC,0),U,4)="M"
SET XQCNT=XQCNT+1
SET XQREACT(XQCNT)=XQSEC
+16 QUIT
End DoDot:1
+17 ;
+18 ;Save the originals
MERGE XQREACTS=XQREACT
+19 SET XQCNTS=XQCNT
+20 ;
+21 SET XQFL=$$FLAG(.XQREACT,.XQCNT)
+22 IF (XQFL=1)&('$DATA(XTMUNIT))
Begin DoDot:1
+23 NEW DIR
+24 SET DIR(0)="Y"
+25 SET DIR("A")=" Are you sure you want to force a rebuild? "
+26 SET DIR("A",1)=" ***WARNING*** "
+27 SET DIR("A",2)=" Someone else may be rebuilding these trees right now."
+28 SET DIR("?")=" Enter 'Y' to force a rebuild, 'N' to quit."
+29 DO ^DIR
+30 IF Y=1
Begin DoDot:2
+31 ;Restore original list of menus
MERGE XQREACT=XQREACTS
+32 SET XQCNT=XQCNTS
+33 SET XQFL=0
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 ;
+37 ;Flags are set, let's not mess with it.
if XQFL
QUIT
+38 ;
+39 IF '$DATA(XTMUNIT)
Begin DoDot:1
+40 SET DIR(0)="Y"
SET DIR("A")=" Queue this rebuild? "
SET DIR("B")="Y"
+41 SET DIR("?")=" Please enter 'Y'es or 'N'o."
+42 DO ^DIR
IF Y=1
Begin DoDot:2
+43 SET ZTRTN="REACTQ^XQ84"
+44 SET ZTSAVE("XUN")=""
+45 SET ZTSAVE("XQREACT(")=""
SET ZTSAVE("XQCNT")=""
+46 SET ZTIO=""
SET ZTDTH=$HOROLOG
+47 SET ZTDESC="Rebuild "_$PIECE(^VA(200,XUN,0),U)_"'s menu trees (DUZ="_XUN_")"
+48 DO ^%ZTLOAD
+49 IF $DATA(ZTSK)
WRITE !!," Task number: ",ZTSK
End DoDot:2
+50 QUIT
End DoDot:1
+51 KILL DIR,Y
+52 ;
+53 IF '$DATA(ZTSK)
DO REACTQ
IF '$DATA(XTMUNIT)
WRITE !!," Done."
+54 KILL ZTSK
+55 QUIT
+56 ;
REACT(XUN) ;From XUSERNEW, check trees for reactivated user
+1 ; ZEXCEPT: XQQUE,XQUEUED,XWB,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ; Kernel exemptions
+2 ;
+3 NEW XQCNT,XQSEC,XQREACT,XQPRIM,XQCHAT
+4 ;Anybody out there?
SET XQCHAT=1
IF $DATA(XQUEUED)!$DATA(XWB)
SET XQCHAT=0
+5 SET XQPRIM=$GET(^VA(200,XUN,201))
IF 'XQPRIM
IF '$DATA(XQQUE)
if XQCHAT
WRITE !!,"** WARNING ** No Primary Menu defined."
QUIT
+6 IF (XQPRIM'=+XQPRIM)!($GET(^DIC(19,XQPRIM,0))="")
QUIT
+7 SET (XQCNT,XQSEC)=0
+8 IF XQPRIM
IF '$DATA(^DIC(19,"AXQ","P"_XQPRIM))
IF $PIECE(^DIC(19,XQPRIM,0),U,4)="M"
SET XQCNT=XQCNT+1
SET XQREACT(XQCNT)="P"_XQPRIM
+9 FOR
SET XQSEC=$ORDER(^VA(200,XUN,203,"B",XQSEC))
if XQSEC'=+XQSEC
QUIT
Begin DoDot:1
+10 ;Bad pointer don't use it
if '$DATA(^DIC(19,XQSEC,0))
QUIT
+11 IF '$DATA(^DIC(19,"AXQ","P"_XQSEC))
IF $PIECE(^DIC(19,XQSEC,0),U,4)="M"
SET XQCNT=XQCNT+1
SET XQREACT(XQCNT)="P"_XQSEC
+12 QUIT
End DoDot:1
+13 ;
+14 ;The menu trees look OK to me.
if XQCNT=0
QUIT
+15 ;
+16 NEW %
+17 ;Are we already merging them (1)
SET %=$$FLAG(.XQREACT,.XQCNT)
+18 if %
QUIT
+19 ;
+20 IF XQCNT>0
Begin DoDot:1
+21 SET ZTRTN="REACTQ^XQ84"
+22 SET ZTSAVE("XQREACT(")=""
SET ZTSAVE("XUN")=""
+23 SET ZTIO=""
SET ZTDTH=$HOROLOG
+24 SET ZTDESC="Rebuild reactivated user's menu trees (DUZ="_XUN_")"
+25 DO ^%ZTLOAD
+26 KILL ZTSK
+27 QUIT
End DoDot:1
+28 QUIT
+29 ;
FLAG(XQARRAY,XQNUM1) ;Should we build a particular array of trees
+1 ;Input: XQARRAY - array of trees e.g. P106, etc. XQNUM1 number of trees
+2 ;Output: 0 - There are trees to rebuild, 1 - Trees are already flagged
+3 ;Merge flags e.g. [^XUTL("XQO","XQMERGED","P106)=$H] are set here
+4 ; and killed in REACTQ+16
+5 ;
+6 NEW %,XQNUM,XQPXU
SET XQNUM=0
+7 ;Menus rebuilding
SET %=$$STATUS^XQ81()
IF '%
QUIT 1
+8 SET XQPXU=$GET(^DIC(19,"AXQ","PXU",0))
if XQPXU=""
QUIT 1
+9 SET %=""
FOR
SET %=$ORDER(XQARRAY(%))
if %=""
QUIT
Begin DoDot:1
+10 NEW X
+11 SET X=XQARRAY(%)
+12 IF $DATA(^XUTL("XQO","XQMERGED",X))
Begin DoDot:2
+13 NEW Y,Z
+14 ;Flag's gone
SET Y=$GET(^XUTL("XQO","XQMERGED",X))
if Y=""
QUIT
+15 SET Z=$$HDIFF^XLFDT(XQPXU,Y)
+16 ;Old Flag
IF Z>0
KILL ^XUTL("XQO","XQMERGED",X)
+17 QUIT
End DoDot:2
+18 IF $DATA(^XUTL("XQO","XQMERGED",X))
KILL XQARRAY(%)
QUIT
+19 ;We'll merge this one
SET ^XUTL("XQO","XQMERGED",X)=$HOROLOG
SET XQNUM=XQNUM+1
+20 QUIT
End DoDot:1
+21 ;There are some left to rebuild
IF XQNUM>0
SET XQNUM1=XQNUM
QUIT 0
+22 QUIT 1
+23 ;
REACTQ ;Queued job to rebuild a reactivated user's menu trees
+1 ; can also be run in real time by USER (above)
+2 ; ZEXCEPT: D,I,W,X,XQFG1,XQK,XQQUE,XQREACT,XQSTAT,XQXUF,XUN,Y,Z,ZTQUEUED,ZTREQ ; Kernel exemptions
+3 NEW %
SET %=0
+4 ;Don't delete the task information
KILL ZTREQ
+5 ;Menus are being rebuilt
IF $DATA(^DIC(19,"AXQ","P0"))
SET XQSTAT=$$STATUS^XQ81
if 'XQSTAT
QUIT
+6 ;Nothing to rebuild
if '$DATA(XQREACT)
QUIT
+7 ;
+8 ;Turn off Micro Surgery
DO MICRO^XQ81
+9 SET ^DIC(19,"AXQ","P0")=$HOROLOG
+10 NEW XQCNT,XQDIC
SET XQCNT=""
+11 KILL ^TMP($JOB),^TMP("XQO",$JOB)
+12 FOR
SET XQCNT=$ORDER(XQREACT(XQCNT))
if XQCNT=""
QUIT
Begin DoDot:1
+13 SET (XQFG1,XQXUF)=""
SET XQDIC="P"_XQREACT(XQCNT)
+14 DO PM2^XQ8
+15 if '$DATA(^TMP("XQO",$JOB,XQDIC))
QUIT
+16 ;D MERGET^XQ81
MERGE ^DIC(19,"AXQ",XQDIC)=^TMP("XQO",$JOB,XQDIC)
+17 ;D MERGEX^XQ81
MERGE ^XUTL("XQO",XQDIC)=^DIC(19,"AXQ",XQDIC)
+18 KILL ^XUTL("XQO","XQMERGED",XQREACT(XQCNT))
+19 QUIT
End DoDot:1
+20 NEW DUZ
SET DUZ=XUN
SET XQDIC="U"_XUN
DO NEWSET^XQSET
+21 KILL ^DIC(19,"AXQ","P0"),^TMP($JOB),^TMP("XQO",$JOB)
+22 DO REPORT($EXTRACT($PIECE(^VA(200,XUN,0),U),1,9))
+23 KILL ^DIC(19,"AXQ","P0","STOP")
+24 KILL D,I,W,X,XQK,XQQUE,XQXUF,Y,Z
+25 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+26 QUIT
+27 ;
REPORT(XQTYPE) ;Tell us what happened.
+1 ; ZEXCEPT: XQSTART,ZTSK ; Kernel exemptions
+2 NEW %,X,XQI,XQJ,XQK,XQLINE,XQEND,Y
+3 IF '$DATA(^XUTL("XQO","MICRO"))
SET ^XUTL("XQO","MICRO")=0
+4 ;Update Micro count
IF XQTYPE["MICRO"
SET ^XUTL("XQO","MICRO")=^XUTL("XQO","MICRO")+1
QUIT
+5 SET XQEND=$$HTE^XLFDT($HOROLOG)
+6 IF '$DATA(XQSTART)
SET XQSTART=XQEND
+7 SET XQLINE=XQSTART_"^"_XQEND_"^"_$PIECE(^VA(200,DUZ,0),U,1)_"^"
+8 SET X=XQTYPE
KILL XQTYPE
+9 SET Y=$SELECT($DATA(ZTSK):ZTSK,1:"LIVE")
+10 SET XQLINE=XQLINE_X_"^"_Y
+11 DO GETENV^%ZOSV
+12 SET XQLINE=XQLINE_"^"_$PIECE(Y,"^",1,3)_"^"_$JOB
+13 IF $DATA(^XUTL("XQO","REBUILDS"))
Begin DoDot:1
+14 SET (XQJ,XQK)=0
+15 FOR
SET XQJ=$ORDER(^XUTL("XQO","REBUILDS",XQJ))
if XQJ=""!(XQJ=49)
QUIT
SET XQK=XQK+1
+16 FOR XQI=XQK:-1:1
SET ^XUTL("XQO","REBUILDS",XQI+1)=^(XQI)
+17 QUIT
End DoDot:1
+18 SET ^XUTL("XQO","REBUILDS",1)=XQLINE
+19 QUIT
+20 ;
NOW ;Is there a rebuild of any kind running right now?
+1 NEW %
SET %=0
+2 IF $DATA(^DIC(19,"AXQ","P0","MICRO"))
Begin DoDot:1
+3 WRITE !!?6,"Micro surgery is currently updating the compiled menus."
+4 IF $DATA(^DIC(19,"AXQ","AXQ","STOP"))
Begin DoDot:2
+5 WRITE !?6,"... but it has been instructed to stop."
+6 QUIT
End DoDot:2
+7 SET %=47
+8 QUIT
End DoDot:1
+9 if %=47
QUIT
+10 IF $DATA(^DIC(19,"AXQ","P0"))
Begin DoDot:1
+11 WRITE !!?6," A complete menu rebuild is currently running."
+12 SET %=47
+13 QUIT
End DoDot:1
+14 if %=47
QUIT
+15 WRITE !!?6,"There is no menu rebuild activity running on your system right now."
+16 QUIT
+17 ;
REBUILD(RESULT) ; RPC. [XU REBUILD MENU TREE] public (p629)
+1 ; input - none (uses DUZ)
+2 ; output - 0 if unsuccessful, 1 if successful
+3 NEW XUN,XQPRIM,XQSEC,XQREACT,XQCNT
+4 SET RESULT=0
+5 SET XUN=DUZ
+6 ; No Primary Menu defined for this user
SET XQPRIM=$GET(^VA(200,XUN,201))
IF XQPRIM'>0
QUIT 0
+7 SET XQCNT=1
SET XQREACT(XQCNT)=XQPRIM
SET XQSEC=0
+8 FOR
SET XQSEC=$ORDER(^VA(200,XUN,203,"B",XQSEC))
if XQSEC'=+XQSEC
QUIT
Begin DoDot:1
+9 ;Bad pointer don't use it
if '$DATA(^DIC(19,XQSEC,0))
QUIT
+10 IF $PIECE(^DIC(19,XQSEC,0),U,4)="M"
SET XQCNT=XQCNT+1
SET XQREACT(XQCNT)=XQSEC
+11 QUIT
End DoDot:1
+12 ;
+13 DO REACTQ
+14 SET RESULT=1
+15 QUIT
