XQ83.m

XQ83 ;SF-ISC.SEA/JLI/LUKE,ISD/HGW - FIND ^XUTL NODES NEEDING SURGERY ;05/01/12  09:43

 ;;8.0;KERNEL;**60,157,286,593**;Jul 10, 1995;Build 8

 ;Per VHA Directive 2004-038, this routine should not be modified

 Q

DQ ;TaskMan entry fired by CHEK below

 ;

 Q:'$D(^DIC(19,"AT"))  ;Nothing to do

 ;

 I $D(^DIC(19,"AXQ","P0"))=1 D  ;Somebody is rebuilding menus

 .L +^DIC(19,"AXQ","P0"):DILOCKTM ;If we can lock it the flag is bogus ;P593

 .I $T L -^DIC(19,"AXQ","P0") K ^DIC(19,"AXQ","P0")

 .Q

 Q:$D(^DIC(19,"AXQ","P0"))=1

 ;

 I $D(^DIC(19,"AXQ","P0","STOP")) D

 .N X,Y,Z

 .S X=$G(^DIC(19,"AXQ","P0","STOP")) Q:X=""

 .S Y=$H

 .S Z=$$HDIFF^XLFDT(Y,X,1)

 .I Z>0 K ^DIC(19,"AXQ","P0","STOP") Q  ;Flag left over from yesterday

 .S Z=$$HDIFF^XLFDT(Y,X,2)

 .I Z>11000 K ^DIC(19,"AXQ","P0","STOP") Q  ;Flag is over 2 hours old

 .Q

 Q:$D(^DIC(19,"AXQ","P0","STOP"))  ;Rebuilding - stop micro surgery

 ;

 S ^DIC(19,"AXQ","P0","MICRO")=$H ;Set the 'I am working' flag.

 ;

 D NOW^%DTC ;Returns: %=3010706.131332, %H=58626,47612, X=3010706

 S X=% S %XQT1=X H 2

 S XQSTART=$$HTE^XLFDT($H) ;Returns: Jul 06, 2001@13:19:20

 ;

 S X1=X,X2=-21 D C^%DTC F %K=0:0 S %K=$O(^DIC(19,"AT",%K)) Q:%K'>0!(%K'<X)  K ^(%K) ;Kill of those that are 21 days old

 S X=DT+2 F  S X=$O(^DIC(19,"AT",X)) Q:X'>0  S %K="" F  S %K=$O(^DIC(19,"AT",X,%K)) Q:%K=""  W !,X K ^(%K) S ^DIC(19,"AT",$$NOW^XLFDT(),%K)="" W " ",$$NOW^XLFDT()

 ;Kill off old "AT" nodes

 ;

LOOP ;Main loop

 ;

 ;I $D(^DIC(19,"AXQ","P0","STOP")) G KILL

 K ^TMP($J) S X=%XQT,%XQX="",N=0 F %K=X:0 S %K=$O(^DIC(19,"AT",%K)) Q:%K'>0!(%K>%XQT1)  S %XQT=%K,%Z="" F %J=0:0 S %Z=$O(^DIC(19,"AT",%K,%Z)) Q:%Z=""  S N=N+1,^TMP($J,N,%Z)="",^TMP($J,"A",%Z,N)=""

 ;$O through "AT" and set up lists in ^TMP, ^TMP($J,"A" is the XREF

 ;

 I '$D(^TMP($J)) S XQN="P0",X=%XQT D H^%DTC S %XQT=%H_","_%T F %K=0:0 S XQN=$O(^XUTL("XQO",XQN)) Q:$E(XQN)'="P"  S ^(XQN,0)=%XQT

 I '$D(^TMP($J)) G KILL

 ;If nothing appears in TMP quit

 ;

 S %Z="" F %K=0:0 S %Z=$O(^TMP($J,"A",%Z)) Q:%Z=""  F N=0:0 S N=$O(^TMP($J,"A",%Z,N)) Q:N'>0  I $O(^(N))>0 K ^TMP($J,N)

 ;F N=0:0 S N=$O(^TMP($J,N)) Q:N'>0  S %Z=$O(^(N,"")),%X1=+%Z,%XC=$E(%Z,$L(%X1)+1,99),%X2=$E(%XC,2,99),XJ=$S(%XC="DIFROM":"DNUL",%XC["I":"DINS",%XC["D":"DDEL",%Z=+%Z:"DREG",%XC["S":"DSYN",%XC["P":"DPRI",1:"DNUL") D @XJ

 F XQXM=0:0 S XQXM=$O(^TMP($J,XQXM)) Q:XQXM'>0  S XQOP=$O(^(XQXM,"")),XQENT=$S(XQOP["S":"SYN",XQOP["I":"INS",XQOP["D":"DEL",XQOP["P":"PRI",1:"REG") D @XQENT

 ;solve the entry for the type of operation needs to be performed and

 ; to that code below.

 ;Remove the "AT" nodes that we processed

 F XQI=0:0 S XQI=$O(^DIC(19,"AT",XQI)) Q:(XQI'<%XQT1)!(XQI<1)  K ^(XQI)

 D NOW^%DTC S %XQT=%XQT1 S:%=0 %="" S %XQT1=X H 2

 G LOOP

 ;

DINS F %M=N:0 S %M=$O(^TMP($J,%M)) Q:%M'>0  I $D(^(%M,(%X1_"D"_%X2)))!$D(^(%X1))!$D(^(%X2)) K ^TMP($J,N) Q

 I $D(^TMP($J,N)) F %M=N:0 S %M=$O(^TMP($J,%M)) Q:%M'>0  I $D(^(%M,(%X1_"S"_%X2))) K ^TMP($J,%M)

 Q

DDEL F %M=N:0 S %M=$O(^TMP($J,%M)) Q:%M'>0  I $D(^(%M,(%X1_"I"_%X2))) K ^TMP($J,N) Q

 I $D(^TMP($J,N)) F %M=N:0 S %M=$O(^TMP($J,%M)) Q:%M'>0  I $D(^(%M,(%X1_"S"_%X2))) K ^TMP($J,%M)

 Q

DREG F %M=N:0 S %M=$O(^TMP($J,%M)) Q:%M'>0  S X=$O(^(%M,"")) I X[("I"_%X2)!(X[("S"_%X2)) K ^TMP($J,%M)

 Q

DSYN F %M=N:0 S %M=$O(^TMP($J,%M)) Q:%M'>0  S X=$O(^(%M,"")) I X=%X2!(X=(%X1_"I"_%X2)) K ^TMP($J,N) Q

 Q

DNUL K ^TMP($J,N)

DPRI Q

 ;

DEL S XQC="D" D SPLIT D ^XQ83D Q

 ;

DIFROM S XQH=%XQT D QUE^XQ81

 G KILL

 ;

INS S XQC="I" D SPLIT D ^XQ83A Q

 ;

SYN S XQC="S" D SPLIT D SYN^XQ83R Q

 ;

REG S XQC="" D REG^XQ83R Q

 ;

PRI ; Enter a new Primary menu

 S XQC="P" D SPLIT S (A,XQDIC)="P"_XQOPM,XQVE=0,XQRB=0,XQFG1=1 K XQFG L +^XUTL("XQO",A):0 D PM1^XQ8 S ^XUTL("XQO",XQDIC,0)=%XQT1 L -^XUTL("XQO",XQDIC)

 Q

 ;

SPLIT S XQOPM=+XQOP,XQOPI=+$P(XQOP,XQC,2),XQC1=XQOPM_","_XQOPI_",",XQC2=","_XQC1,XQOPI1=XQOPI_",",XQOPI2=","_XQOPI1 Q

 ;

 ;

CHEKV ;First see if the compiled menus live on this system

 ;If so fall through to CHEK, else quit (called by XQOO*)

 Q:'$D(^XUTL("XQO"))

 ;

CHEK ;See if microsurgery needs to be run here

 ;Called by XUS+25 and XUSG+18

 ;Also kicked off by the option XQKICKMICRO

 ;

 Q:'$D(^DIC(19,"AT"))  ;Nothing to do

 ;

 I $D(^DIC(19,"AXQ","P0"))=1 D  ;Somebody is rebuilding menus

 .L +^DIC(19,"AXQ","P0"):DILOCKTM ;If we can lock it the flag is bogus ;P593

 .I $T L -^DIC(19,"AXQ","P0") K ^DIC(19,"AXQ","P0")

 .Q

 Q:$D(^DIC(19,"AXQ","P0"))=1

 ;

 I $D(^DIC(19,"AXQ","P0","STOP")) D

 .N X,Y,Z

 .S X=$G(^DIC(19,"AXQ","P0","STOP")) Q:X=""

 .S Y=$H

 .S Z=$$HDIFF^XLFDT(Y,X,1)

 .I Z>0 K ^DIC(19,"AXQ","P0","STOP") Q  ;Flag left over from yesterday

 .S Z=$$HDIFF^XLFDT(Y,X,2)

 .I Z>11000 K ^DIC(19,"AXQ","P0","STOP") Q  ;Flag is over 2 hours old

 .Q

 Q:$D(^DIC(19,"AXQ","P0","STOP"))  ;Rebuilding - stop micro surgery

 ;

 ;If the compiled menus do not exist on "AXQ" rebuild all of them

 S %XQH=$O(^DIC(19,"AXQ","P")) I %XQH'["P" D  Q

 .;S ^DIC(19,"AXQ","P0")=$H

 .S ZTIO="",ZTDTH=$H,ZTRTN="QUE^XQ81",ZTSAVE("DUZ")=.5

 .D SETVOL

 .D ^%ZTLOAD

 .Q

 ;

 Q:'$D(^XUTL("XQO",%XQH,0))  L ^XUTL("XQO",%XQH,0):DILOCKTM I '$T K %XQH Q  ;P593

 ;If the first menu has a 0th node lock it, if it won't lock quit

 N X S %H=$P(^XUTL("XQO",%XQH,0),U,1) D YMD^%DTC S:%>.001 %=%-.001 S:%=0 %="" S %XQT=X_%

 ;Get date off first entry set %XQT (looks like: 3000414.081043)

 S %XQX="",%ZO="" S:'$D(XQM) XQM=+$G(^VA(200,DUZ,201)) I XQM>0,'$D(^XUTL("XQO","P"_XQM)) S %XQX=XQM_"P",^DIC(19,"AT",%XQT+.0001,%XQX)=""

 ;Set Primary menu of this user, if not there flag it in "AT" it looks

 ;  like this: ^DIC(19,"AT",3000414.081143,9P)

 ;I $O(^DIC(19,"AT",%XQT))>0

 ;

 S ^DIC(19,"AXQ","P0","MICRO")=$H,%XQX=1

 S %TIM=$P($H,",")-1_","_$P($H,",",2)

 L -^XUTL("XQO",%XQH,0)

 ;

 S ZTDESC="MICRO UPDATING XUTL",ZTRTN="DQ^XQ83",ZTSAVE("%XQT")="",ZTSAVE("DUZ")=.5,ZTDTH=%TIM,ZTIO="" D:'$D(ZTCPU) SETVOL D ^%ZTLOAD

 ;Unlock the node and task off DQ above and quit

 ;

 Q

SETVOL ;

 X ^%ZOSF("UCI") S ZTCPU=$P(Y,",",2),ZTUCI=$P(Y,",")

 Q

 ;

KILL D REPORT^XQ84("MICRO")

 K ^DIC(19,"AXQ","P0","MICRO")

 ;

 K %,%H,%J,%K,%M,%X1,%X2,%TIM,%XQT1,%XQH,%I,%T,%XQA,%XQX,%XQT,%XQX1,%XQX2,%XQY,A,B,I,I0,%Z,%ZO

 K J,K,M,N,P,X1,X2,XQA,XQC,XQC1,XQC2,XQE,XQENT,XQK,XQOP,XQOPI,XQOPI1,XQOPI2

 K XQI,XQH,XQFG1,XQM,XQN,XQOPM,XQOPS,XQP,XQRB,XQSTART,XQVE,XQXM,Y

 I $D(ZTQUEUED) S ZTREQ="@"

 Q

XQ83      ;SF-ISC.SEA/JLI/LUKE,ISD/HGW - FIND ^XUTL NODES NEEDING SURGERY ;05/01/12  09:43

 +1       ;;8.0;KERNEL;**60,157,286,593**;Jul 10, 1995;Build 8

 +2       ;Per VHA Directive 2004-038, this routine should not be modified

 +3        QUIT 

DQ        ;TaskMan entry fired by CHEK below

 +1       ;

 +2       ;Nothing to do

           IF '$DATA(^DIC(19,"AT"))

               QUIT 

 +3       ;

 +4       ;Somebody is rebuilding menus

           IF $DATA(^DIC(19,"AXQ","P0"))=1

               Begin DoDot:1

 +5       ;If we can lock it the flag is bogus ;P593

                   LOCK +^DIC(19,"AXQ","P0"):DILOCKTM

 +6                IF $TEST

                       LOCK -^DIC(19,"AXQ","P0")

                       KILL ^DIC(19,"AXQ","P0")

 +7                QUIT 

               End DoDot:1

 +8        IF $DATA(^DIC(19,"AXQ","P0"))=1

               QUIT 

 +9       ;

 +10       IF $DATA(^DIC(19,"AXQ","P0","STOP"))

               Begin DoDot:1

 +11               NEW X,Y,Z

 +12               SET X=$GET(^DIC(19,"AXQ","P0","STOP"))

                   IF X=""

                       QUIT 

 +13               SET Y=$HOROLOG

 +14               SET Z=$$HDIFF^XLFDT(Y,X,1)

 +15      ;Flag left over from yesterday

                   IF Z>0

                       KILL ^DIC(19,"AXQ","P0","STOP")

                       QUIT 

 +16               SET Z=$$HDIFF^XLFDT(Y,X,2)

 +17      ;Flag is over 2 hours old

                   IF Z>11000

                       KILL ^DIC(19,"AXQ","P0","STOP")

                       QUIT 

 +18               QUIT 

               End DoDot:1

 +19      ;Rebuilding - stop micro surgery

           IF $DATA(^DIC(19,"AXQ","P0","STOP"))

               QUIT 

 +20      ;

 +21      ;Set the 'I am working' flag.

           SET ^DIC(19,"AXQ","P0","MICRO")=$HOROLOG

 +22      ;

 +23      ;Returns: %=3010706.131332, %H=58626,47612, X=3010706

           DO NOW^%DTC

 +24       SET X=%

           SET %XQT1=X

           HANG 2

 +25      ;Returns: Jul 06, 2001@13:19:20

           SET XQSTART=$$HTE^XLFDT($HOROLOG)

 +26      ;

 +27      ;Kill of those that are 21 days old

           SET X1=X

           SET X2=-21

           DO C^%DTC

           FOR %K=0:0

               SET %K=$ORDER(^DIC(19,"AT",%K))

               IF %K'>0!(%K'<X)

                   QUIT 

               KILL ^(%K)

 +28       SET X=DT+2

           FOR 

               SET X=$ORDER(^DIC(19,"AT",X))

               IF X'>0

                   QUIT 

               SET %K=""

               FOR 

                   SET %K=$ORDER(^DIC(19,"AT",X,%K))

                   IF %K=""

                       QUIT 

                   WRITE !,X

                   KILL ^(%K)

                   SET ^DIC(19,"AT",$$NOW^XLFDT(),%K)=""

                   WRITE " ",$$NOW^XLFDT()

 +29      ;Kill off old "AT" nodes

 +30      ;

LOOP      ;Main loop

 +1       ;

 +2       ;I $D(^DIC(19,"AXQ","P0","STOP")) G KILL

 +3        KILL ^TMP($JOB)

           SET X=%XQT

           SET %XQX=""

           SET N=0

           FOR %K=X:0

               SET %K=$ORDER(^DIC(19,"AT",%K))

               IF %K'>0!(%K>%XQT1)

                   QUIT 

               SET %XQT=%K

               SET %Z=""

               FOR %J=0:0

                   SET %Z=$ORDER(^DIC(19,"AT",%K,%Z))

                   IF %Z=""

                       QUIT 

                   SET N=N+1

                   SET ^TMP($JOB,N,%Z)=""

                   SET ^TMP($JOB,"A",%Z,N)=""

 +4       ;$O through "AT" and set up lists in ^TMP, ^TMP($J,"A" is the XREF

 +5       ;

 +6        IF '$DATA(^TMP($JOB))

               SET XQN="P0"

               SET X=%XQT

               DO H^%DTC

               SET %XQT=%H_","_%T

               FOR %K=0:0

                   SET XQN=$ORDER(^XUTL("XQO",XQN))

                   IF $EXTRACT(XQN)'="P"

                       QUIT 

                   SET ^(XQN,0)=%XQT

 +7        IF '$DATA(^TMP($JOB))

               GOTO KILL

 +8       ;If nothing appears in TMP quit

 +9       ;

 +10       SET %Z=""

           FOR %K=0:0

               SET %Z=$ORDER(^TMP($JOB,"A",%Z))

               IF %Z=""

                   QUIT 

               FOR N=0:0

                   SET N=$ORDER(^TMP($JOB,"A",%Z,N))

                   IF N'>0

                       QUIT 

                   IF $ORDER(^(N))>0

                       KILL ^TMP($JOB,N)

 +11      ;F N=0:0 S N=$O(^TMP($J,N)) Q:N'>0  S %Z=$O(^(N,"")),%X1=+%Z,%XC=$E(%Z,$L(%X1)+1,99),%X2=$E(%XC,2,99),XJ=$S(%XC="DIFROM":"DNUL",%XC["I":"DINS",%XC["D":"DDEL",%Z=+%Z:"DREG",%XC["S":"DSYN",%XC["P":"DPRI",1:"DNUL") D @XJ

 +12       FOR XQXM=0:0

               SET XQXM=$ORDER(^TMP($JOB,XQXM))

               IF XQXM'>0

                   QUIT 

               SET XQOP=$ORDER(^(XQXM,""))

               SET XQENT=$SELECT(XQOP["S":"SYN",XQOP["I":"INS",XQOP["D":"DEL",XQOP["P":"PRI",1:"REG")

               DO @XQENT

 +13      ;solve the entry for the type of operation needs to be performed and

 +14      ; to that code below.

 +15      ;Remove the "AT" nodes that we processed

 +16       FOR XQI=0:0

               SET XQI=$ORDER(^DIC(19,"AT",XQI))

               IF (XQI'<%XQT1)!(XQI<1)

                   QUIT 

               KILL ^(XQI)

 +17       DO NOW^%DTC

           SET %XQT=%XQT1

           IF %=0

               SET %=""

           SET %XQT1=X

           HANG 2

 +18       GOTO LOOP

 +19      ;

DINS       FOR %M=N:0

               SET %M=$ORDER(^TMP($JOB,%M))

               IF %M'>0

                   QUIT 

               IF $DATA(^(%M,(%X1_"D"_%X2)))!$DATA(^(%X1))!$DATA(^(%X2))

                   KILL ^TMP($JOB,N)

                   QUIT 

 +1        IF $DATA(^TMP($JOB,N))

               FOR %M=N:0

                   SET %M=$ORDER(^TMP($JOB,%M))

                   IF %M'>0

                       QUIT 

                   IF $DATA(^(%M,(%X1_"S"_%X2)))

                       KILL ^TMP($JOB,%M)

 +2        QUIT 

DDEL       FOR %M=N:0

               SET %M=$ORDER(^TMP($JOB,%M))

               IF %M'>0

                   QUIT 

               IF $DATA(^(%M,(%X1_"I"_%X2)))

                   KILL ^TMP($JOB,N)

                   QUIT 

 +1        IF $DATA(^TMP($JOB,N))

               FOR %M=N:0

                   SET %M=$ORDER(^TMP($JOB,%M))

                   IF %M'>0

                       QUIT 

                   IF $DATA(^(%M,(%X1_"S"_%X2)))

                       KILL ^TMP($JOB,%M)

 +2        QUIT 

DREG       FOR %M=N:0

               SET %M=$ORDER(^TMP($JOB,%M))

               IF %M'>0

                   QUIT 

               SET X=$ORDER(^(%M,""))

               IF X[("I"_%X2)!(X[("S"_%X2))

                   KILL ^TMP($JOB,%M)

 +1        QUIT 

DSYN       FOR %M=N:0

               SET %M=$ORDER(^TMP($JOB,%M))

               IF %M'>0

                   QUIT 

               SET X=$ORDER(^(%M,""))

               IF X=%X2!(X=(%X1_"I"_%X2))

                   KILL ^TMP($JOB,N)

                   QUIT 

 +1        QUIT 

DNUL       KILL ^TMP($JOB,N)

DPRI       QUIT 

 +1       ;

DEL        SET XQC="D"

           DO SPLIT

           DO ^XQ83D

           QUIT 

 +1       ;

DIFROM     SET XQH=%XQT

           DO QUE^XQ81

 +1        GOTO KILL

 +2       ;

INS        SET XQC="I"

           DO SPLIT

           DO ^XQ83A

           QUIT 

 +1       ;

SYN        SET XQC="S"

           DO SPLIT

           DO SYN^XQ83R

           QUIT 

 +1       ;

REG        SET XQC=""

           DO REG^XQ83R

           QUIT 

 +1       ;

PRI       ; Enter a new Primary menu

 +1        SET XQC="P"

           DO SPLIT

           SET (A,XQDIC)="P"_XQOPM

           SET XQVE=0

           SET XQRB=0

           SET XQFG1=1

           KILL XQFG

           LOCK +^XUTL("XQO",A):0

           DO PM1^XQ8

           SET ^XUTL("XQO",XQDIC,0)=%XQT1

           LOCK -^XUTL("XQO",XQDIC)

 +2        QUIT 

 +3       ;

SPLIT      SET XQOPM=+XQOP

           SET XQOPI=+$PIECE(XQOP,XQC,2)

           SET XQC1=XQOPM_","_XQOPI_","

           SET XQC2=","_XQC1

           SET XQOPI1=XQOPI_","

           SET XQOPI2=","_XQOPI1

           QUIT 

 +1       ;

 +2       ;

CHEKV     ;First see if the compiled menus live on this system

 +1       ;If so fall through to CHEK, else quit (called by XQOO*)

 +2        IF '$DATA(^XUTL("XQO"))

               QUIT 

 +3       ;

CHEK      ;See if microsurgery needs to be run here

 +1       ;Called by XUS+25 and XUSG+18

 +2       ;Also kicked off by the option XQKICKMICRO

 +3       ;

 +4       ;Nothing to do

           IF '$DATA(^DIC(19,"AT"))

               QUIT 

 +5       ;

 +6       ;Somebody is rebuilding menus

           IF $DATA(^DIC(19,"AXQ","P0"))=1

               Begin DoDot:1

 +7       ;If we can lock it the flag is bogus ;P593

                   LOCK +^DIC(19,"AXQ","P0"):DILOCKTM

 +8                IF $TEST

                       LOCK -^DIC(19,"AXQ","P0")

                       KILL ^DIC(19,"AXQ","P0")

 +9                QUIT 

               End DoDot:1

 +10       IF $DATA(^DIC(19,"AXQ","P0"))=1

               QUIT 

 +11      ;

 +12       IF $DATA(^DIC(19,"AXQ","P0","STOP"))

               Begin DoDot:1

 +13               NEW X,Y,Z

 +14               SET X=$GET(^DIC(19,"AXQ","P0","STOP"))

                   IF X=""

                       QUIT 

 +15               SET Y=$HOROLOG

 +16               SET Z=$$HDIFF^XLFDT(Y,X,1)

 +17      ;Flag left over from yesterday

                   IF Z>0

                       KILL ^DIC(19,"AXQ","P0","STOP")

                       QUIT 

 +18               SET Z=$$HDIFF^XLFDT(Y,X,2)

 +19      ;Flag is over 2 hours old

                   IF Z>11000

                       KILL ^DIC(19,"AXQ","P0","STOP")

                       QUIT 

 +20               QUIT 

               End DoDot:1

 +21      ;Rebuilding - stop micro surgery

           IF $DATA(^DIC(19,"AXQ","P0","STOP"))

               QUIT 

 +22      ;

 +23      ;If the compiled menus do not exist on "AXQ" rebuild all of them

 +24       SET %XQH=$ORDER(^DIC(19,"AXQ","P"))

           IF %XQH'["P"

               Begin DoDot:1

 +25      ;S ^DIC(19,"AXQ","P0")=$H

 +26               SET ZTIO=""

                   SET ZTDTH=$HOROLOG

                   SET ZTRTN="QUE^XQ81"

                   SET ZTSAVE("DUZ")=.5

 +27               DO SETVOL

 +28               DO ^%ZTLOAD

 +29               QUIT 

               End DoDot:1

               QUIT 

 +30      ;

 +31      ;P593

           IF '$DATA(^XUTL("XQO",%XQH,0))

               QUIT 

           LOCK ^XUTL("XQO",%XQH,0):DILOCKTM

           IF '$TEST

               KILL %XQH

               QUIT 

 +32      ;If the first menu has a 0th node lock it, if it won't lock quit

 +33       NEW X

           SET %H=$PIECE(^XUTL("XQO",%XQH,0),U,1)

           DO YMD^%DTC

           IF %>.001

               SET %=%-.001

           IF %=0

               SET %=""

           SET %XQT=X_%

 +34      ;Get date off first entry set %XQT (looks like: 3000414.081043)

 +35       SET %XQX=""

           SET %ZO=""

           IF '$DATA(XQM)

               SET XQM=+$GET(^VA(200,DUZ,201))

           IF XQM>0

               IF '$DATA(^XUTL("XQO","P"_XQM))

                   SET %XQX=XQM_"P"

                   SET ^DIC(19,"AT",%XQT+.0001,%XQX)=""

 +36      ;Set Primary menu of this user, if not there flag it in "AT" it looks

 +37      ;  like this: ^DIC(19,"AT",3000414.081143,9P)

 +38      ;I $O(^DIC(19,"AT",%XQT))>0

 +39      ;

 +40       SET ^DIC(19,"AXQ","P0","MICRO")=$HOROLOG

           SET %XQX=1

 +41       SET %TIM=$PIECE($HOROLOG,",")-1_","_$PIECE($HOROLOG,",",2)

 +42       LOCK -^XUTL("XQO",%XQH,0)

 +43      ;

 +44       SET ZTDESC="MICRO UPDATING XUTL"

           SET ZTRTN="DQ^XQ83"

           SET ZTSAVE("%XQT")=""

           SET ZTSAVE("DUZ")=.5

           SET ZTDTH=%TIM

           SET ZTIO=""

           IF '$DATA(ZTCPU)

               DO SETVOL

           DO ^%ZTLOAD

 +45      ;Unlock the node and task off DQ above and quit

 +46      ;

 +47       QUIT 

SETVOL    ;

 +1        XECUTE ^%ZOSF("UCI")

           SET ZTCPU=$PIECE(Y,",",2)

           SET ZTUCI=$PIECE(Y,",")

 +2        QUIT 

 +3       ;

KILL       DO REPORT^XQ84("MICRO")

 +1        KILL ^DIC(19,"AXQ","P0","MICRO")

 +2       ;

 +3        KILL %,%H,%J,%K,%M,%X1,%X2,%TIM,%XQT1,%XQH,%I,%T,%XQA,%XQX,%XQT,%XQX1,%XQX2,%XQY,A,B,I,I0,%Z,%ZO

 +4        KILL J,K,M,N,P,X1,X2,XQA,XQC,XQC1,XQC2,XQE,XQENT,XQK,XQOP,XQOPI,XQOPI1,XQOPI2

 +5        KILL XQI,XQH,XQFG1,XQM,XQN,XQOPM,XQOPS,XQP,XQRB,XQSTART,XQVE,XQXM,Y

 +6        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +7        QUIT