XQSRV1 ;SEA/MJM - Server option utilities ;10/15/96 13:14
;;8.0;KERNEL;**50**;Jul 10, 1995
;
;File the message in POSTMASTER'S mailbox of option's name
S XQSRV=$P(XQ220,U,7) S:XQSRV="" XQSRV=1
I XQSRV S XMXX="S."_XQSOP,XMZ=XQMSG D SETSB^XMA1C
;
;Check for a resource
S XQRES=$P(XQ220,U,8) I XQRES'="",($D(^%ZIS(1,XQRES,0))) S XQRES=$P(^(0),U)
E S XQRES=""
;
I $D(XMFROM),XMFROM=+XMFROM,$D(^VA(200,+XMFROM,0)) S XMFROM=$P(^(0),U)
I XQSUB["~U~" F XQI=0:0 Q:XQSUB'["~U~" S XQSUB=$P(XQSUB,"~U~")_"^"_$P(XQSUB,"~U~",2,99)
;
TASK ;Set up task parameters and call Taskman
S XQRTN="" S:$D(^DIC(19,+XQY,25)) XQRTN=^(25) S:XQRTN'["^" XQRTN="^"_XQRTN
;I XQMD="R"&'($D(^DIC(19,XQY,3.91,0))&($P(^(0),U,4)>0)) S X=$P(XQY0,U,8) X:$L(X) ^%ZOSF("PRIORITY") G ZTSK^XQSRV2 ;Just go do it!
I XQMD="R"&'($P($G(^DIC(19,XQY,3.91,0)),U,4)>0) S X=$P(XQY0,U,8) X:$L(X) ^%ZOSF("PRIORITY") G ZTSK^XQSRV2
I XQMD="R" S XQMD="Q" ;Must be queued if days/times are restricted
;
S ZTPRI=$P(XQY0,U,8),ZTRTN="ZTSK^XQSRV2",ZTDESC="Server Request: "_$P(XQY0,U,2)_" Message #: "_XQMSG,ZTIO=XQRES
S XQDAYS=$P(XQ220,U,9) S:(XQDAYS'>0) XQDAYS=14 S ZTKIL=$P($H,",")+XQDAYS_",00000" ;Retention time to save task in ZTSK
S ZTSAVE("XQY")="",ZTSAVE("XQY0")="",ZTSAVE("XQ220")="",ZTSAVE("XQLTL")="",ZTSAVE("XQAUDIT")="",ZTSAVE("XQREPLY")="",ZTSAVE("XQSUP")="",ZTSAVE("XQNOUSR")=""
S ZTSAVE("XQMSG")="",ZTSAVE("XQSUB")="",ZTSAVE("XQSND")="",ZTSAVE("XQRTN")="",ZTSAVE("XQSOP")="",ZTSAVE("XQMD")="",ZTSAVE("XQDATE")="",ZTSAVE("XQMB6")="",ZTSAVE("XQMB")=""
S ZTSAVE("XMREC")="",ZTSAVE("XMFROM")="",ZTSAVE("XMCHAN")="",ZTSAVE("XMXX")="",ZTSAVE("XMZ")=""
;
I XQMD="N" S ZTDTH=$H+2_",0" D ^%ZTLOAD,XQ^XUTMT S XQMB6="Server request for "_XQSOP_". Task # "_ZTSK_" needs to be scheduled." G OUT
I XQMD="Q" S X=XQLTL D
.N Y S Y=+XQY D NEXT^XQ92 S XQX=X
.I XQX="" S XQER="Scheduling Error: All days and times for the option "_XQSOP_" are prohibited."
.I XQX'="" S (ZTDTH,XQDTH)=X D ^%ZTLOAD S XQMB6="Server request queued for "_XQDTH_" task # "_ZTSK
G:(XQX'="") KILL^XQSRV2
;
OUT ;Trigger the bulletin, do the audit, and split.
D:XQAUDIT AUDIT,AUDIT^XQSRV2
G OUT^XQSRV2
Q
;
AUDIT ;Enter the option audit data in Audit Log for Option File
D GETENV^%ZOSV S XQVOL=$P(Y,U,2)
F XQI=0:0 S XQLTL=XQLTL+.0000001 I '$D(^XUSEC(19,XQLTL,0))#2 L +^XUSEC(19,0) S $P(^(0),U,3,4)=XQLTL_"^"_($P(^XUSEC(19,0),U,4)+1) L -^XUSEC(19,0) Q
S ^XUSEC(19,XQLTL,0)=XQY_U_DUZ_U_$I_U_$J_U_U_XQVOL
S ^XUSEC(19,XQLTL,1)=XQMSG_U_XMFROM
S ^XUSEC(19,XQLTL,2)=XQSUB
Q
;
REQUE ; Requeue a server option not previously queued due to some problem
R !,"Message Number of Server message: ",XQMSG:DTIME Q:'$T!(XQMSG="")!(XQMSG[U)!(XQMSG'>0)
I '$D(^XMB(3.9,XQMSG)) W !,$C(7),"Invalid MESSAGE NUMBER",! G REQUE
F I=0:0 S I=$O(^XMB(3.9,XQMSG,1,I)) Q:I'>0 S XQ=^(I,0) I "S.s."[$E(XQ,1,2) S XQ=$P(XQ,U,1) Q
I "S.s."'[$E(XQ,1,2) W !,$C(7),"MESSAGE is NOT a SERVER MESSAGE",! G REQUE
S %DT="AET",%DT("A")="Date/time to run server program: ",%DT("B")="NOW" D ^%DT I Y>0 S ZTDTH=Y
S X=$E(XQ,3,$L(XQ))_U_XQMSG S I=$P(^XMB(3.9,XQMSG,0),U,2),X=X_U_$S(I'>0:I,'$D(^VA(200,+I,0)):"UNKNOWN",1:$P(^(0),U,1))_U_$P(^XMB(3.9,XQMSG,0),U,1)
G ^XQSRV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQSRV1 3237 printed Oct 16, 2024@18:07:28 Page 2
XQSRV1 ;SEA/MJM - Server option utilities ;10/15/96 13:14
+1 ;;8.0;KERNEL;**50**;Jul 10, 1995
+2 ;
+3 ;File the message in POSTMASTER'S mailbox of option's name
+4 SET XQSRV=$PIECE(XQ220,U,7)
if XQSRV=""
SET XQSRV=1
+5 IF XQSRV
SET XMXX="S."_XQSOP
SET XMZ=XQMSG
DO SETSB^XMA1C
+6 ;
+7 ;Check for a resource
+8 SET XQRES=$PIECE(XQ220,U,8)
IF XQRES'=""
IF ($DATA(^%ZIS(1,XQRES,0)))
SET XQRES=$PIECE(^(0),U)
+9 IF '$TEST
SET XQRES=""
+10 ;
+11 IF $DATA(XMFROM)
IF XMFROM=+XMFROM
IF $DATA(^VA(200,+XMFROM,0))
SET XMFROM=$PIECE(^(0),U)
+12 IF XQSUB["~U~"
FOR XQI=0:0
if XQSUB'["~U~"
QUIT
SET XQSUB=$PIECE(XQSUB,"~U~")_"^"_$PIECE(XQSUB,"~U~",2,99)
+13 ;
TASK ;Set up task parameters and call Taskman
+1 SET XQRTN=""
if $DATA(^DIC(19,+XQY,25))
SET XQRTN=^(25)
if XQRTN'["^"
SET XQRTN="^"_XQRTN
+2 ;I XQMD="R"&'($D(^DIC(19,XQY,3.91,0))&($P(^(0),U,4)>0)) S X=$P(XQY0,U,8) X:$L(X) ^%ZOSF("PRIORITY") G ZTSK^XQSRV2 ;Just go do it!
+3 IF XQMD="R"&'($PIECE($GET(^DIC(19,XQY,3.91,0)),U,4)>0)
SET X=$PIECE(XQY0,U,8)
if $LENGTH(X)
XECUTE ^%ZOSF("PRIORITY")
GOTO ZTSK^XQSRV2
+4 ;Must be queued if days/times are restricted
IF XQMD="R"
SET XQMD="Q"
+5 ;
+6 SET ZTPRI=$PIECE(XQY0,U,8)
SET ZTRTN="ZTSK^XQSRV2"
SET ZTDESC="Server Request: "_$PIECE(XQY0,U,2)_" Message #: "_XQMSG
SET ZTIO=XQRES
+7 ;Retention time to save task in ZTSK
SET XQDAYS=$PIECE(XQ220,U,9)
if (XQDAYS'>0)
SET XQDAYS=14
SET ZTKIL=$PIECE($HOROLOG,",")+XQDAYS_",00000"
+8 SET ZTSAVE("XQY")=""
SET ZTSAVE("XQY0")=""
SET ZTSAVE("XQ220")=""
SET ZTSAVE("XQLTL")=""
SET ZTSAVE("XQAUDIT")=""
SET ZTSAVE("XQREPLY")=""
SET ZTSAVE("XQSUP")=""
SET ZTSAVE("XQNOUSR")=""
+9 SET ZTSAVE("XQMSG")=""
SET ZTSAVE("XQSUB")=""
SET ZTSAVE("XQSND")=""
SET ZTSAVE("XQRTN")=""
SET ZTSAVE("XQSOP")=""
SET ZTSAVE("XQMD")=""
SET ZTSAVE("XQDATE")=""
SET ZTSAVE("XQMB6")=""
SET ZTSAVE("XQMB")=""
+10 SET ZTSAVE("XMREC")=""
SET ZTSAVE("XMFROM")=""
SET ZTSAVE("XMCHAN")=""
SET ZTSAVE("XMXX")=""
SET ZTSAVE("XMZ")=""
+11 ;
+12 IF XQMD="N"
SET ZTDTH=$HOROLOG+2_",0"
DO ^%ZTLOAD
DO XQ^XUTMT
SET XQMB6="Server request for "_XQSOP_". Task # "_ZTSK_" needs to be scheduled."
GOTO OUT
+13 IF XQMD="Q"
SET X=XQLTL
Begin DoDot:1
+14 NEW Y
SET Y=+XQY
DO NEXT^XQ92
SET XQX=X
+15 IF XQX=""
SET XQER="Scheduling Error: All days and times for the option "_XQSOP_" are prohibited."
+16 IF XQX'=""
SET (ZTDTH,XQDTH)=X
DO ^%ZTLOAD
SET XQMB6="Server request queued for "_XQDTH_" task # "_ZTSK
End DoDot:1
+17 if (XQX'="")
GOTO KILL^XQSRV2
+18 ;
OUT ;Trigger the bulletin, do the audit, and split.
+1 if XQAUDIT
DO AUDIT
DO AUDIT^XQSRV2
+2 GOTO OUT^XQSRV2
+3 QUIT
+4 ;
AUDIT ;Enter the option audit data in Audit Log for Option File
+1 DO GETENV^%ZOSV
SET XQVOL=$PIECE(Y,U,2)
+2 FOR XQI=0:0
SET XQLTL=XQLTL+.0000001
IF '$DATA(^XUSEC(19,XQLTL,0))#2
LOCK +^XUSEC(19,0)
SET $PIECE(^(0),U,3,4)=XQLTL_"^"_($PIECE(^XUSEC(19,0),U,4)+1)
LOCK -^XUSEC(19,0)
QUIT
+3 SET ^XUSEC(19,XQLTL,0)=XQY_U_DUZ_U_$IO_U_$JOB_U_U_XQVOL
+4 SET ^XUSEC(19,XQLTL,1)=XQMSG_U_XMFROM
+5 SET ^XUSEC(19,XQLTL,2)=XQSUB
+6 QUIT
+7 ;
REQUE ; Requeue a server option not previously queued due to some problem
+1 READ !,"Message Number of Server message: ",XQMSG:DTIME
if '$TEST!(XQMSG="")!(XQMSG[U)!(XQMSG'>0)
QUIT
+2 IF '$DATA(^XMB(3.9,XQMSG))
WRITE !,$CHAR(7),"Invalid MESSAGE NUMBER",!
GOTO REQUE
+3 FOR I=0:0
SET I=$ORDER(^XMB(3.9,XQMSG,1,I))
if I'>0
QUIT
SET XQ=^(I,0)
IF "S.s."[$EXTRACT(XQ,1,2)
SET XQ=$PIECE(XQ,U,1)
QUIT
+4 IF "S.s."'[$EXTRACT(XQ,1,2)
WRITE !,$CHAR(7),"MESSAGE is NOT a SERVER MESSAGE",!
GOTO REQUE
+5 SET %DT="AET"
SET %DT("A")="Date/time to run server program: "
SET %DT("B")="NOW"
DO ^%DT
IF Y>0
SET ZTDTH=Y
+6 SET X=$EXTRACT(XQ,3,$LENGTH(XQ))_U_XQMSG
SET I=$PIECE(^XMB(3.9,XQMSG,0),U,2)
SET X=X_U_$SELECT(I'>0:I,'$DATA(^VA(200,+I,0)):"UNKNOWN",1:$PIECE(^(0),U,1))_U_$PIECE(^XMB(3.9,XQMSG,0),U,1)
+7 GOTO ^XQSRV
