XUINTSK1 ;ISCSF/RWF - TASKMAN POST INIT ;01/03/95 09:29
;;8.0;KERNEL;;Jul 10, 1995
SCH ;Move and build new schedule
N DIFROM
F X19=0:0 S X19=$O(^DIC(19,X19)) Q:X19'>0 D
. S XUTASK=0,XUNEW=0
. I $G(^DIC(19,X19,200)) D SCH1
. I $G(^DIC(19,X19,1916))["S" D SCH2
. Q
Q
SCH1 ;Move regular options
N DUZ S DUZ=0,DUZ(0)="@"
S DA=X19,XV19=^DIC(19,DA,200),X=+XV19 D K200 ;KILL OLD
S:'$D(^DIC(19,X19,200.9))&($P(XV19,U,3)]"") ^DIC(19,X19,200.9)="y"
K DD,DO
S X=X19,DIC="^DIC(19.2,",DIC(0)="L",DLAYGO=19.2 D FILE^DICN
S (DA,XUNEW)=+Y,X=X19_U_$P(XV19,U,1,2)_U_U_$P(XV19,U,4)_U_$P(XV19,U,3)
S ^DIC(19.2,DA,0)=X,DIK=DIC,DIK(1)=2 I (+XV19)'<DT D EN1^DIK
D MES^XPDUTL("Option: "_$P(^DIC(19,X19,0),U)_" move to new file.")
SCH1X K ^DIC(19,X19,200)
Q
SCH2 ;Move Special queueing
S DA=X19,XV19=$G(^DIC(19,DA,200)),XV1916=^DIC(19,DA,1916)
S:'$D(^DIC(19,X19,200.9)) ^DIC(19,X19,200.9)="s"
D K1916 K DD,DO,Y S Y=XUNEW
I 'Y S X=X19,DIC="^DIC(19.2,",DIC(0)="L",DLAYGO=19.2 D FILE^DICN
S DA=+Y,X=^DIC(19.2,DA,0),$P(X,U,5)=$P(XV19,U,4),$P(X,U,9)=$P(XV1916,U)
S ^DIC(19.2,DA,0)=X,DIK=DIC,DIK(1)=9 D EN1^DIK
D MES^XPDUTL("Option: "_$P(^DIC(19,X19,0),U)_" startup moved.")
K ^DIC(19,X19,200),^DIC(19,X19,1916)
Q
FIND ;subroutine--find scheduled task that will run this option
N DV,X,X1,Y X ^%ZOSF("UCI") S %=0,XUTASK=0,Y=$P(Y,","),OPNM=$$GET(19,DA,.01)
S X=+$S($D(ZTMQDT):ZTMQDT,$D(^DIC(19,DA,200)):$$GET(19,DA,200),1:0) I 'X Q
D H^%DTC S X=%H_","_%T,%=0
F S %=$O(^%ZTSCH(X,%)) Q:%'>0 S X1=$G(^%ZTSK(%,0)) I $P(X1,"^",1,2)="ZTSK^XQ1" D Q:XUTASK
. Q:$P(X1,"^",11)'=Y Q:$P(X1,"^",13)'[OPNM
. S:$G(^%ZTSK(%,.3,"XQY"))=DA XUTASK=% Q
Q
;
GET(FN,IEN,FE) ;
N A,B,C S A=$G(^DD(19,FE,0)),A=$P(A,"^",4)
S B=$P(A,";"),C=$P(A,";",2)
Q $P($G(^DIC(19,IEN,B)),"^",C)
;--------------------------------------------------------------------
;
K200 ;kill logic for AZTM cross-reference on field 200
S ZTMQDT=X D FIND K ZTMQDT I XUTASK'>0 Q
S DUZ=+$P($G(^%ZTSK(XUTASK,0)),"^",3) ;Set DUZ to the old owner
K ^%ZTSK(XUTASK),^%ZTSCH(X,XUTASK)
Q
;
K1916 ;kill logic for ASTARTUP cross-reference of field 1916
S ZTVOL=$$GET(19,DA,203)
X ^%ZOSF("UCI") I ZTVOL]"" S $P(Y,",",2)=ZTVOL
K ^%ZTSCH("STARTUP",Y,DA),ZTVOL
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUINTSK1 2276 printed Nov 22, 2024@17:20:01 Page 2
XUINTSK1 ;ISCSF/RWF - TASKMAN POST INIT ;01/03/95 09:29
+1 ;;8.0;KERNEL;;Jul 10, 1995
SCH ;Move and build new schedule
+1 NEW DIFROM
+2 FOR X19=0:0
SET X19=$ORDER(^DIC(19,X19))
if X19'>0
QUIT
Begin DoDot:1
+3 SET XUTASK=0
SET XUNEW=0
+4 IF $GET(^DIC(19,X19,200))
DO SCH1
+5 IF $GET(^DIC(19,X19,1916))["S"
DO SCH2
+6 QUIT
End DoDot:1
+7 QUIT
SCH1 ;Move regular options
+1 NEW DUZ
SET DUZ=0
SET DUZ(0)="@"
+2 ;KILL OLD
SET DA=X19
SET XV19=^DIC(19,DA,200)
SET X=+XV19
DO K200
+3 if '$DATA(^DIC(19,X19,200.9))&($PIECE(XV19,U,3)]"")
SET ^DIC(19,X19,200.9)="y"
+4 KILL DD,DO
+5 SET X=X19
SET DIC="^DIC(19.2,"
SET DIC(0)="L"
SET DLAYGO=19.2
DO FILE^DICN
+6 SET (DA,XUNEW)=+Y
SET X=X19_U_$PIECE(XV19,U,1,2)_U_U_$PIECE(XV19,U,4)_U_$PIECE(XV19,U,3)
+7 SET ^DIC(19.2,DA,0)=X
SET DIK=DIC
SET DIK(1)=2
IF (+XV19)'<DT
DO EN1^DIK
+8 DO MES^XPDUTL("Option: "_$PIECE(^DIC(19,X19,0),U)_" move to new file.")
SCH1X KILL ^DIC(19,X19,200)
+1 QUIT
SCH2 ;Move Special queueing
+1 SET DA=X19
SET XV19=$GET(^DIC(19,DA,200))
SET XV1916=^DIC(19,DA,1916)
+2 if '$DATA(^DIC(19,X19,200.9))
SET ^DIC(19,X19,200.9)="s"
+3 DO K1916
KILL DD,DO,Y
SET Y=XUNEW
+4 IF 'Y
SET X=X19
SET DIC="^DIC(19.2,"
SET DIC(0)="L"
SET DLAYGO=19.2
DO FILE^DICN
+5 SET DA=+Y
SET X=^DIC(19.2,DA,0)
SET $PIECE(X,U,5)=$PIECE(XV19,U,4)
SET $PIECE(X,U,9)=$PIECE(XV1916,U)
+6 SET ^DIC(19.2,DA,0)=X
SET DIK=DIC
SET DIK(1)=9
DO EN1^DIK
+7 DO MES^XPDUTL("Option: "_$PIECE(^DIC(19,X19,0),U)_" startup moved.")
+8 KILL ^DIC(19,X19,200),^DIC(19,X19,1916)
+9 QUIT
FIND ;subroutine--find scheduled task that will run this option
+1 NEW DV,X,X1,Y
XECUTE ^%ZOSF("UCI")
SET %=0
SET XUTASK=0
SET Y=$PIECE(Y,",")
SET OPNM=$$GET(19,DA,.01)
+2 SET X=+$SELECT($DATA(ZTMQDT):ZTMQDT,$DATA(^DIC(19,DA,200)):$$GET(19,DA,200),1:0)
IF 'X
QUIT
+3 DO H^%DTC
SET X=%H_","_%T
SET %=0
+4 FOR
SET %=$ORDER(^%ZTSCH(X,%))
if %'>0
QUIT
SET X1=$GET(^%ZTSK(%,0))
IF $PIECE(X1,"^",1,2)="ZTSK^XQ1"
Begin DoDot:1
+5 if $PIECE(X1,"^",11)'=Y
QUIT
if $PIECE(X1,"^",13)'[OPNM
QUIT
+6 if $GET(^%ZTSK(%,.3,"XQY"))=DA
SET XUTASK=%
QUIT
End DoDot:1
if XUTASK
QUIT
+7 QUIT
+8 ;
GET(FN,IEN,FE) ;
+1 NEW A,B,C
SET A=$GET(^DD(19,FE,0))
SET A=$PIECE(A,"^",4)
+2 SET B=$PIECE(A,";")
SET C=$PIECE(A,";",2)
+3 QUIT $PIECE($GET(^DIC(19,IEN,B)),"^",C)
+4 ;--------------------------------------------------------------------
+5 ;
K200 ;kill logic for AZTM cross-reference on field 200
+1 SET ZTMQDT=X
DO FIND
KILL ZTMQDT
IF XUTASK'>0
QUIT
+2 ;Set DUZ to the old owner
SET DUZ=+$PIECE($GET(^%ZTSK(XUTASK,0)),"^",3)
+3 KILL ^%ZTSK(XUTASK),^%ZTSCH(X,XUTASK)
+4 QUIT
+5 ;
K1916 ;kill logic for ASTARTUP cross-reference of field 1916
+1 SET ZTVOL=$$GET(19,DA,203)
+2 XECUTE ^%ZOSF("UCI")
IF ZTVOL]""
SET $PIECE(Y,",",2)=ZTVOL
+3 KILL ^%ZTSCH("STARTUP",Y,DA),ZTVOL
+4 QUIT
+5 ;
