%ZTMS2 ;SEA/RDS-TaskMan: Submanager, Part 4 (Unload, Get Device) ;2/19/08 13:38
;;8.0;KERNEL;**2,18,23,36,67,118,127,163,167,175,199,275,446**;Jul 10, 1995;Build 35
;Per VHA Directive 2004-038, this routine should not be modified.
;
;^%ZTSK(ZTSK),^%ZTSCH("DEV",IO) is locked on entry or return from GETNEXT
PROCESS ;SUBMGR--process task and all others waiting for same device
L +^%ZTSCH("TASK",ZTSK):1 I '$T Q ;Only allow one copy of a task at one time
D LOOKUP I $D(ZTREJECT) Q
D DEVICE
I POP L Q ;Release all locks
I ZTSYNCFL]"",'$$SYNCFLG("A",ZTSYNCFL,%ZTIO) D Q
. D SYNCQ(ZTSYNCFL,%ZTIO,ZTDTH,ZTSK),^%ZISC L ;Release all locks
. Q
;Go run task
D TASK^%ZTMS3 I ZTYPE="C"!$D(ZTNONEXT) Q
D GETNEXT^%ZTMS7 I $D(ZTNONEXT)!$D(ZTQUIT) Q
G PROCESS
;
LOOKUP ;PROCESS--unload task, switch ucis, and test entry routine
K (%ZTIME,%ZTIO,DT,IO,U,ZTCPU,ZTDEVN,ZTDTH,ZTNODE,ZTPAIR,ZTPFLG,ZTQUEUED,ZTSK,ZTUCI,ZTYPE,ZTLKTM) ;p446
D TSKSTAT(4,"")
S ZTREC=^%ZTSK(ZTSK,0),ZTREC02=^(.02)
S ZTREC2=^%ZTSK(ZTSK,.2),ZTREC21=^(.21),ZTREC25=^(.25)
S ZTSYNCFL=$P(ZTREC2,"^",7),DUZ=+$P(ZTREC,U,3),DUZ(0)="@"
S X=$P(ZTREC02,U)_","_$P(ZTREC02,U,2)
I $P(ZTREC02,U,4) S $P(X,",",2)=ZTCPU
;should do a check to see if X is OK, Should check UCI mapping.
I X'=ZTUCI S ZTUCI=X D SWAP^%XUCI
S X=$P($P(ZTREC,U,2),"("),ZTRTN=$P(ZTREC,U,1,2)
I $E(X)'="%",$L(X) X ^%ZOSF("TEST") I X=""!'$T D REJECT S ZTREJECT=""
Q
;
REJECT ;LOOKUP--entry routine isn't here; reject task
N Y X ^%ZOSF("UCI")
D TSKSTAT("B","No routine at destination "_Y_".")
I $D(ZTDEVN) D DEVLK^%ZTMS1(-1,%ZTIO) K ZTDEVN
L Q ;Clear all locks
;
DEVICE ;PROCESS--prepare requested device; if can't, make task wait
;First clean-up all IO variables that could influence the device
K %ZIS,IO,IOCPU,IOHG,IOPAR,IOUPAR,IOS
;If don't need a device, Setup minimum.
S ZTIO=$P(ZTREC2,U),ZTIOT=$P(ZTREC2,U,3)
I ZTIO="" S (IO,IO(0),IOF,IOM,ION,IOS,IOSL,IOST,IOT)="",POP=0 Q
;
;setup call
S %ZIS="LRS0"_$S($P(ZTREC2,U,5)="DIRECT":"D",1:"")
S:ZTIOT="HFS" %ZIS("HFSIO")=$P(ZTREC2,U,6),%ZIS("IOPAR")=ZTREC25
S:ZTIOT="MT" %ZIS("IOPAR")=ZTREC25
S (IO,IO(0))=%ZTIO,IOP=ZTIO
S:'$D(^%ZTSCH("DEVTRY",$P(ZTIO,";"))) ^($P(ZTIO,";"))=%ZTIME ;Set problem device check
K ^XUTL("XQ",$J),IO("ERROR")
;
S:$P(ZTREC2,U,4)["MINIOUT" %ZISLOCK="^%ZTSCH(""NETMAIL"",IO)" ;The hang is on the close
;call
S %ZISTO=3 D ^%ZIS K %ZISTO,%ZISLOCK ;See that we use a timeout.
I %ZTIO]"" D DEVLK^%ZTMS1(-1,%ZTIO) K ZTDEVN
I 'POP K ^%ZTSCH("DEVTRY",IO),^($P(ZTIO,";")) ;Clear problem device check
;Reset %ZTIO if IO doesn't match
I 'POP,%ZTIO]"",IO'=%ZTIO C %ZTIO K IO(1,%ZTIO),^%ZTSCH("DEVTRY",$P(%ZTIO,";")) S %ZTIO=IO
;
;results
I POP,(ZTYPE'="C"),(ZTIOT="TRM")!(ZTIOT="RES")!(ZTIOT="HG") D IONQ Q ;only add to IO queue if not type C.
I POP D SCHNQ Q
I IOT'="RES",IOT'="HG" U IO
S IO(0)=IO
I $P(^%ZIS(1,+IOS,0),U,7)="y" D ^%ZTMSH
Q
;
IONQ ;DEVICE--put task on Device Waiting List
I $D(^%ZTSK(ZTSK,0))[0 D TSKSTAT("I",4) G IOQX
D TSKSTAT("A","")
N %ZTIO S %ZTIO=IO
S ZTIO(1)=$P(ZTREC2,U,5),ZTIOS=ZTREC21
D NQ^%ZTM4 ;Uses %ZTIO as the Device $I value
IOQX L Q ;Clear all Locks
;
SCHNQ ;DEVICE--if HFS or SPL or TYPE'=C, reschedule task 10 min in future (try later)
S ZTH=$$NEWH($H,300)
D TSKSTAT(1,"rescheduled for busy device")
S $P(^%ZTSK(ZTSK,.2),U,8)=$P(^%ZTSK(ZTSK,.2),U,8)+1 ;ReQ count
D SCHTM(ZTH)
I $L($G(IO("ERROR"))) S $P(^%ZTSK(ZTSK,.12),U,2,9)=$H_U_IO("ERROR") ;May tell why couldn't get device
L Q ;Clear all locks
;
SCHTM(ZTDTH) ;Set a new schedule time, See that task is updated
S $P(^%ZTSK(ZTSK,0),U,6)=$$H0^%ZTM(ZTDTH),^%ZTSK(ZTSK,.04)=ZTDTH,^%ZTSCH(ZTDTH,ZTSK)=""
Q
NEWH(%H,%Y) ;Build a new schedule time, Return $H3 time.
N %
I %H["," S %H=$$H3^%ZTM(%H)
Q (%H+%Y)
;
SYNCFLG(ACT,FLAG,ZIO,STAT) ;Allocate/deallocate sync flag
N X,DA,SYNC
L +^%ZISL(14.8):30 E Q 0
S X=0,SYNC=FLAG_"~"_ZIO,DA=$O(^%ZISL(14.8,"B",SYNC,0))
I ACT["A" D
. I DA S X=0 Q
. ;I $D(^%ZTSCH("SYNC",ZIO,FLAG)) S X=0 Q
. S X=$P(^%ZISL(14.8,0),"^",3)+1 F Q:'$D(^%ZISL(14.8,X)) S X=X+1
. S $P(^(0),"^",3,4)=X_"^"_($P(^%ZISL(14.8,0),"^",4)+1),^%ZISL(14.8,X,0)=SYNC,^%ZISL(14.8,"B",SYNC,X)=""
. S X=1 Q
I ACT["D" D S X=1
. Q:DA'>0
. K ^%ZISL(14.8,DA),^%ZISL(14.8,"B",SYNC,DA)
. S $P(^(0),"^",3,4)=(DA-1)_"^"_($P(^%ZISL(14.8,0),"^",4)-1)
. Q
I ACT["S" D S X=1
. Q:DA'>0
. S ^%ZISL(14.8,DA,1)=$G(STAT)
. Q
I ACT["?" S X=(DA)!($D(^%ZTSCH("SYNC",ZIO,FLAG)))
L -^%ZISL(14.8)
Q X
;
SYNCQ(FLAG,ZIO,ZTH,ZTSK) ;Put task on sync flag waiting list
L +^%ZTSCH("SYNC")
S ^%ZTSCH("SYNC",ZIO,FLAG,ZTSK)=ZTH
L -^%ZTSCH("SYNC")
Q
SCHSYNC(FLAG,ZIO) ;put a waiting task in IO queue
L +^%ZTSCH("SYNC") I $D(^%ZTSCH("SYNC",ZIO,FLAG)) N ZTH,ZTSK D
. S ZTSK=$O(^(FLAG,0)),ZTH=$G(^(+ZTSK)) Q:ZTSK="" S:$D(^%ZTSCH("IO",ZIO))[0 ^(ZIO)=IOT
. S ^%ZTSCH("IO",ZIO,ZTH,ZTSK)=""
. K ^%ZTSCH("SYNC",ZIO,FLAG,ZTSK)
. Q
L -^%ZTSCH("SYNC")
Q
TSKSTAT(CODE,MSG) ;Record status
S $P(^%ZTSK(ZTSK,.1),U,1,3)=$G(CODE)_U_$H_U_$G(MSG)
Q
;
POST ;Post INIT cleanup for patch XU*8*167
N T S T=0
F S T=$O(^%ZTSCH(T)) Q:T'>0 I $D(^%ZTSCH(T,0)) K ^%ZTSCH(T,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZTMS2 5255 printed Apr 09, 2024@21:08:31 Page 2
%ZTMS2 ;SEA/RDS-TaskMan: Submanager, Part 4 (Unload, Get Device) ;2/19/08 13:38
+1 ;;8.0;KERNEL;**2,18,23,36,67,118,127,163,167,175,199,275,446**;Jul 10, 1995;Build 35
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;^%ZTSK(ZTSK),^%ZTSCH("DEV",IO) is locked on entry or return from GETNEXT
PROCESS ;SUBMGR--process task and all others waiting for same device
+1 ;Only allow one copy of a task at one time
LOCK +^%ZTSCH("TASK",ZTSK):1
IF '$TEST
QUIT
+2 DO LOOKUP
IF $DATA(ZTREJECT)
QUIT
+3 DO DEVICE
+4 ;Release all locks
IF POP
LOCK
QUIT
+5 IF ZTSYNCFL]""
IF '$$SYNCFLG("A",ZTSYNCFL,%ZTIO)
Begin DoDot:1
+6 ;Release all locks
DO SYNCQ(ZTSYNCFL,%ZTIO,ZTDTH,ZTSK)
DO ^%ZISC
LOCK
+7 QUIT
End DoDot:1
QUIT
+8 ;Go run task
+9 DO TASK^%ZTMS3
IF ZTYPE="C"!$DATA(ZTNONEXT)
QUIT
+10 DO GETNEXT^%ZTMS7
IF $DATA(ZTNONEXT)!$DATA(ZTQUIT)
QUIT
+11 GOTO PROCESS
+12 ;
LOOKUP ;PROCESS--unload task, switch ucis, and test entry routine
+1 ;p446
KILL (%ZTIME,%ZTIO,DT,IO,U,ZTCPU,ZTDEVN,ZTDTH,ZTNODE,ZTPAIR,ZTPFLG,ZTQUEUED,ZTSK,ZTUCI,ZTYPE,ZTLKTM)
+2 DO TSKSTAT(4,"")
+3 SET ZTREC=^%ZTSK(ZTSK,0)
SET ZTREC02=^(.02)
+4 SET ZTREC2=^%ZTSK(ZTSK,.2)
SET ZTREC21=^(.21)
SET ZTREC25=^(.25)
+5 SET ZTSYNCFL=$PIECE(ZTREC2,"^",7)
SET DUZ=+$PIECE(ZTREC,U,3)
SET DUZ(0)="@"
+6 SET X=$PIECE(ZTREC02,U)_","_$PIECE(ZTREC02,U,2)
+7 IF $PIECE(ZTREC02,U,4)
SET $PIECE(X,",",2)=ZTCPU
+8 ;should do a check to see if X is OK, Should check UCI mapping.
+9 IF X'=ZTUCI
SET ZTUCI=X
DO SWAP^%XUCI
+10 SET X=$PIECE($PIECE(ZTREC,U,2),"(")
SET ZTRTN=$PIECE(ZTREC,U,1,2)
+11 IF $EXTRACT(X)'="%"
IF $LENGTH(X)
XECUTE ^%ZOSF("TEST")
IF X=""!'$TEST
DO REJECT
SET ZTREJECT=""
+12 QUIT
+13 ;
REJECT ;LOOKUP--entry routine isn't here; reject task
+1 NEW Y
XECUTE ^%ZOSF("UCI")
+2 DO TSKSTAT("B","No routine at destination "_Y_".")
+3 IF $DATA(ZTDEVN)
DO DEVLK^%ZTMS1(-1,%ZTIO)
KILL ZTDEVN
+4 ;Clear all locks
LOCK
QUIT
+5 ;
DEVICE ;PROCESS--prepare requested device; if can't, make task wait
+1 ;First clean-up all IO variables that could influence the device
+2 KILL %ZIS,IO,IOCPU,IOHG,IOPAR,IOUPAR,IOS
+3 ;If don't need a device, Setup minimum.
+4 SET ZTIO=$PIECE(ZTREC2,U)
SET ZTIOT=$PIECE(ZTREC2,U,3)
+5 IF ZTIO=""
SET (IO,IO(0),IOF,IOM,ION,IOS,IOSL,IOST,IOT)=""
SET POP=0
QUIT
+6 ;
+7 ;setup call
+8 SET %ZIS="LRS0"_$SELECT($PIECE(ZTREC2,U,5)="DIRECT":"D",1:"")
+9 if ZTIOT="HFS"
SET %ZIS("HFSIO")=$PIECE(ZTREC2,U,6)
SET %ZIS("IOPAR")=ZTREC25
+10 if ZTIOT="MT"
SET %ZIS("IOPAR")=ZTREC25
+11 SET (IO,IO(0))=%ZTIO
SET IOP=ZTIO
+12 ;Set problem device check
if '$DATA(^%ZTSCH("DEVTRY",$PIECE(ZTIO,";")))
SET ^($PIECE(ZTIO,";"))=%ZTIME
+13 KILL ^XUTL("XQ",$JOB),IO("ERROR")
+14 ;
+15 ;The hang is on the close
if $PIECE(ZTREC2,U,4)["MINIOUT"
SET %ZISLOCK="^%ZTSCH(""NETMAIL"",IO)"
+16 ;call
+17 ;See that we use a timeout.
SET %ZISTO=3
DO ^%ZIS
KILL %ZISTO,%ZISLOCK
+18 IF %ZTIO]""
DO DEVLK^%ZTMS1(-1,%ZTIO)
KILL ZTDEVN
+19 ;Clear problem device check
IF 'POP
KILL ^%ZTSCH("DEVTRY",IO),^($PIECE(ZTIO,";"))
+20 ;Reset %ZTIO if IO doesn't match
+21 IF 'POP
IF %ZTIO]""
IF IO'=%ZTIO
CLOSE %ZTIO
KILL IO(1,%ZTIO),^%ZTSCH("DEVTRY",$PIECE(%ZTIO,";"))
SET %ZTIO=IO
+22 ;
+23 ;results
+24 ;only add to IO queue if not type C.
IF POP
IF (ZTYPE'="C")
IF (ZTIOT="TRM")!(ZTIOT="RES")!(ZTIOT="HG")
DO IONQ
QUIT
+25 IF POP
DO SCHNQ
QUIT
+26 IF IOT'="RES"
IF IOT'="HG"
USE IO
+27 SET IO(0)=IO
+28 IF $PIECE(^%ZIS(1,+IOS,0),U,7)="y"
DO ^%ZTMSH
+29 QUIT
+30 ;
IONQ ;DEVICE--put task on Device Waiting List
+1 IF $DATA(^%ZTSK(ZTSK,0))[0
DO TSKSTAT("I",4)
GOTO IOQX
+2 DO TSKSTAT("A","")
+3 NEW %ZTIO
SET %ZTIO=IO
+4 SET ZTIO(1)=$PIECE(ZTREC2,U,5)
SET ZTIOS=ZTREC21
+5 ;Uses %ZTIO as the Device $I value
DO NQ^%ZTM4
IOQX ;Clear all Locks
LOCK
QUIT
+1 ;
SCHNQ ;DEVICE--if HFS or SPL or TYPE'=C, reschedule task 10 min in future (try later)
+1 SET ZTH=$$NEWH($HOROLOG,300)
+2 DO TSKSTAT(1,"rescheduled for busy device")
+3 ;ReQ count
SET $PIECE(^%ZTSK(ZTSK,.2),U,8)=$PIECE(^%ZTSK(ZTSK,.2),U,8)+1
+4 DO SCHTM(ZTH)
+5 ;May tell why couldn't get device
IF $LENGTH($GET(IO("ERROR")))
SET $PIECE(^%ZTSK(ZTSK,.12),U,2,9)=$HOROLOG_U_IO("ERROR")
+6 ;Clear all locks
LOCK
QUIT
+7 ;
SCHTM(ZTDTH) ;Set a new schedule time, See that task is updated
+1 SET $PIECE(^%ZTSK(ZTSK,0),U,6)=$$H0^%ZTM(ZTDTH)
SET ^%ZTSK(ZTSK,.04)=ZTDTH
SET ^%ZTSCH(ZTDTH,ZTSK)=""
+2 QUIT
NEWH(%H,%Y) ;Build a new schedule time, Return $H3 time.
+1 NEW %
+2 IF %H[","
SET %H=$$H3^%ZTM(%H)
+3 QUIT (%H+%Y)
+4 ;
SYNCFLG(ACT,FLAG,ZIO,STAT) ;Allocate/deallocate sync flag
+1 NEW X,DA,SYNC
+2 LOCK +^%ZISL(14.8):30
IF '$TEST
QUIT 0
+3 SET X=0
SET SYNC=FLAG_"~"_ZIO
SET DA=$ORDER(^%ZISL(14.8,"B",SYNC,0))
+4 IF ACT["A"
Begin DoDot:1
+5 IF DA
SET X=0
QUIT
+6 ;I $D(^%ZTSCH("SYNC",ZIO,FLAG)) S X=0 Q
+7 SET X=$PIECE(^%ZISL(14.8,0),"^",3)+1
FOR
if '$DATA(^%ZISL(14.8,X))
QUIT
SET X=X+1
+8 SET $PIECE(^(0),"^",3,4)=X_"^"_($PIECE(^%ZISL(14.8,0),"^",4)+1)
SET ^%ZISL(14.8,X,0)=SYNC
SET ^%ZISL(14.8,"B",SYNC,X)=""
+9 SET X=1
QUIT
End DoDot:1
+10 IF ACT["D"
Begin DoDot:1
+11 if DA'>0
QUIT
+12 KILL ^%ZISL(14.8,DA),^%ZISL(14.8,"B",SYNC,DA)
+13 SET $PIECE(^(0),"^",3,4)=(DA-1)_"^"_($PIECE(^%ZISL(14.8,0),"^",4)-1)
+14 QUIT
End DoDot:1
SET X=1
+15 IF ACT["S"
Begin DoDot:1
+16 if DA'>0
QUIT
+17 SET ^%ZISL(14.8,DA,1)=$GET(STAT)
+18 QUIT
End DoDot:1
SET X=1
+19 IF ACT["?"
SET X=(DA)!($DATA(^%ZTSCH("SYNC",ZIO,FLAG)))
+20 LOCK -^%ZISL(14.8)
+21 QUIT X
+22 ;
SYNCQ(FLAG,ZIO,ZTH,ZTSK) ;Put task on sync flag waiting list
+1 LOCK +^%ZTSCH("SYNC")
+2 SET ^%ZTSCH("SYNC",ZIO,FLAG,ZTSK)=ZTH
+3 LOCK -^%ZTSCH("SYNC")
+4 QUIT
SCHSYNC(FLAG,ZIO) ;put a waiting task in IO queue
+1 LOCK +^%ZTSCH("SYNC")
IF $DATA(^%ZTSCH("SYNC",ZIO,FLAG))
NEW ZTH,ZTSK
Begin DoDot:1
+2 SET ZTSK=$ORDER(^(FLAG,0))
SET ZTH=$GET(^(+ZTSK))
if ZTSK=""
QUIT
if $DATA(^%ZTSCH("IO",ZIO))[0
SET ^(ZIO)=IOT
+3 SET ^%ZTSCH("IO",ZIO,ZTH,ZTSK)=""
+4 KILL ^%ZTSCH("SYNC",ZIO,FLAG,ZTSK)
+5 QUIT
End DoDot:1
+6 LOCK -^%ZTSCH("SYNC")
+7 QUIT
TSKSTAT(CODE,MSG) ;Record status
+1 SET $PIECE(^%ZTSK(ZTSK,.1),U,1,3)=$GET(CODE)_U_$HOROLOG_U_$GET(MSG)
+2 QUIT
+3 ;
POST ;Post INIT cleanup for patch XU*8*167
+1 NEW T
SET T=0
+2 FOR
SET T=$ORDER(^%ZTSCH(T))
if T'>0
QUIT
IF $DATA(^%ZTSCH(T,0))
KILL ^%ZTSCH(T,0)
+3 QUIT
