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