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

XQ84.m

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