XUS9 ;SF/RWF,ISD/HGW - Find a user ; 1/18/12 8:20am
;;8.0;KERNEL;**258,590**;Jul 10, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified
N %,%DT,%H,DA,DIC,I,Y,X,X1,XU1,XU2,XU3,XU4,XU5,XU6,XU7,XUSER,XUJOB,XUVOL,XUCI,XUDT,XUNODE
1 X ^%ZOSF("UCI") S XU1=$P(Y,",",1),XU2=^%ZOSF("VOL"),X="T-1",%DT="" D ^%DT S XU4=Y
A S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Find User: " D ^DIC G EXIT:Y'>0 S DA=+Y,XUSER=$P(Y,"^",2)
W !!,"User: ",XUSER,$S($D(^XUSEC(0,"CUR",DA))=10:" is found on;",1:" isn't currently on the system")
F XU5=0:0 S XU5=$O(^XUSEC(0,"CUR",DA,XU5)) Q:XU5'>0 D B
W !,"DONE" G A
EXIT ;K %,%H,DA,DIC,I,Y,X
EX2 ;K XU1,XU2,XU3,XU4,XU5,XU6,XUSER,XUJOB,XUVOL,XUCI,XUDT
Q
B ;Find
G:XU5<XU4 REMOVE ;Sign-on more than 24 hours old.
S XU3=$S($D(^XUSEC(0,XU5,0)):^(0),1:"") G REMOVE:'$L(XU3),REMOVE:$P(XU3,"^",4)
S XUCI=$P(XU3,"^",8),XUVOL=$P(XU3,"^",5),Y=XU5,XUJOB=$P(XU3,"^",3),XU6=XUJOB D DD^%DT S XUDT=Y
I XUJOB>2048 S X1=16,X=XUJOB D CNV^XTBASE S XU6=XUJOB_" ("_Y_")"
D GETENV^%ZOSV S XU7=$P(Y,"^",3) ; p590 Get node of current user
S XUNODE=$S($P(XU3,"^",10)]"":$P(XU3,"^",10),1:"unknown") ; p590 Identify node in sign-on log
Q:XUCI'=XU1!(XUVOL'=XU2) ;G:$S($D(^XUTL("XQ",XUJOB,"DUZ")):^("DUZ"),1:0)'=DA REMOVE ; p590
I XU7=XUNODE G:$S($D(^XUTL("XQ",XUJOB,"DUZ")):^("DUZ"),1:0)'=DA REMOVE ; p590 XUJOB is only unique to a node
W !,"Job: ",XU6," on ",XUCI,",",XUVOL," node: ",XUNODE," from ",XUDT ; p590 Changed output format
W !,"Device: ",$P(XU3,"^",2) W:$P(XU3,"^",9)]"" " (",$P(XU3,"^",9),")"
;Q:XUCI'=XU1!(XUVOL'=XU2) G:$S($D(^XUTL("XQ",XUJOB,"DUZ")):^("DUZ"),1:0)'=DA REMOVE
W !?3,"Menu path:"
; p590 XUJOB is only unique to a node
I XU7=XUNODE I $D(^XUTL("XQ",XUJOB,"T")) F I=1:1:^XUTL("XQ",XUJOB,"T") Q:'$D(^XUTL("XQ",XUJOB,I)) S Y=^(I) W !,?I*3+2,$P(Y,"^",3)
I XU7'=XUNODE W !?3,"You must sign-on to node ",XUNODE," to see this menu path."
;I $D(^XUTL("XQ",XUJOB,"T")) F I=1:1:^XUTL("XQ",XUJOB,"T") Q:'$D(^XUTL("XQ",XUJOB,I)) S Y=^(I) W !,?I*3+2,$P(Y,"^",3) ; p590
W !
Q
REMOVE ;Questionable entry removed
;If we have a sign-off time just remove the "CUR" X-ref.
I $P($G(^XUSEC(0,XU5,0)),"^",4) K ^XUSEC(0,"CUR",DA,XU5) Q
N FDA
S FDA(3.081,XU5_",",3)=$$NOW^XLFDT,FDA(3.081,XU5_",",16)=1
D UPDATE^DIE("","FDA")
Q
INQ ;Entry from print template used by "User Inquiry" [XUSERINQ]
Q:'$D(D0) N DA X ^%ZOSF("UCI") S XU1=$P(Y,",",1),XU2=^%ZOSF("VOL"),DA=D0,XU4=DT-1
F XU5=0:0 S XU5=$O(^XUSEC(0,"CUR",DA,XU5)) Q:XU5'>0 D B
G EX2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUS9 2539 printed Apr 09, 2024@21:12:14 Page 2
XUS9 ;SF/RWF,ISD/HGW - Find a user ; 1/18/12 8:20am
+1 ;;8.0;KERNEL;**258,590**;Jul 10, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 NEW %,%DT,%H,DA,DIC,I,Y,X,X1,XU1,XU2,XU3,XU4,XU5,XU6,XU7,XUSER,XUJOB,XUVOL,XUCI,XUDT,XUNODE
1 XECUTE ^%ZOSF("UCI")
SET XU1=$PIECE(Y,",",1)
SET XU2=^%ZOSF("VOL")
SET X="T-1"
SET %DT=""
DO ^%DT
SET XU4=Y
A SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("A")="Find User: "
DO ^DIC
if Y'>0
GOTO EXIT
SET DA=+Y
SET XUSER=$PIECE(Y,"^",2)
+1 WRITE !!,"User: ",XUSER,$SELECT($DATA(^XUSEC(0,"CUR",DA))=10:" is found on;",1:" isn't currently on the system")
+2 FOR XU5=0:0
SET XU5=$ORDER(^XUSEC(0,"CUR",DA,XU5))
if XU5'>0
QUIT
DO B
+3 WRITE !,"DONE"
GOTO A
EXIT ;K %,%H,DA,DIC,I,Y,X
EX2 ;K XU1,XU2,XU3,XU4,XU5,XU6,XUSER,XUJOB,XUVOL,XUCI,XUDT
+1 QUIT
B ;Find
+1 ;Sign-on more than 24 hours old.
if XU5<XU4
GOTO REMOVE
+2 SET XU3=$SELECT($DATA(^XUSEC(0,XU5,0)):^(0),1:"")
if '$LENGTH(XU3)
GOTO REMOVE
if $PIECE(XU3,"^",4)
GOTO REMOVE
+3 SET XUCI=$PIECE(XU3,"^",8)
SET XUVOL=$PIECE(XU3,"^",5)
SET Y=XU5
SET XUJOB=$PIECE(XU3,"^",3)
SET XU6=XUJOB
DO DD^%DT
SET XUDT=Y
+4 IF XUJOB>2048
SET X1=16
SET X=XUJOB
DO CNV^XTBASE
SET XU6=XUJOB_" ("_Y_")"
+5 ; p590 Get node of current user
DO GETENV^%ZOSV
SET XU7=$PIECE(Y,"^",3)
+6 ; p590 Identify node in sign-on log
SET XUNODE=$SELECT($PIECE(XU3,"^",10)]"":$PIECE(XU3,"^",10),1:"unknown")
+7 ;G:$S($D(^XUTL("XQ",XUJOB,"DUZ")):^("DUZ"),1:0)'=DA REMOVE ; p590
if XUCI'=XU1!(XUVOL'=XU2)
QUIT
+8 ; p590 XUJOB is only unique to a node
IF XU7=XUNODE
if $SELECT($DATA(^XUTL("XQ",XUJOB,"DUZ"))
GOTO REMOVE
+9 ; p590 Changed output format
WRITE !,"Job: ",XU6," on ",XUCI,",",XUVOL," node: ",XUNODE," from ",XUDT
+10 WRITE !,"Device: ",$PIECE(XU3,"^",2)
if $PIECE(XU3,"^",9)]""
WRITE " (",$PIECE(XU3,"^",9),")"
+11 ;Q:XUCI'=XU1!(XUVOL'=XU2) G:$S($D(^XUTL("XQ",XUJOB,"DUZ")):^("DUZ"),1:0)'=DA REMOVE
+12 WRITE !?3,"Menu path:"
+13 ; p590 XUJOB is only unique to a node
+14 IF XU7=XUNODE
IF $DATA(^XUTL("XQ",XUJOB,"T"))
FOR I=1:1:^XUTL("XQ",XUJOB,"T")
if '$DATA(^XUTL("XQ",XUJOB,I))
QUIT
SET Y=^(I)
WRITE !,?I*3+2,$PIECE(Y,"^",3)
+15 IF XU7'=XUNODE
WRITE !?3,"You must sign-on to node ",XUNODE," to see this menu path."
+16 ;I $D(^XUTL("XQ",XUJOB,"T")) F I=1:1:^XUTL("XQ",XUJOB,"T") Q:'$D(^XUTL("XQ",XUJOB,I)) S Y=^(I) W !,?I*3+2,$P(Y,"^",3) ; p590
+17 WRITE !
+18 QUIT
REMOVE ;Questionable entry removed
+1 ;If we have a sign-off time just remove the "CUR" X-ref.
+2 IF $PIECE($GET(^XUSEC(0,XU5,0)),"^",4)
KILL ^XUSEC(0,"CUR",DA,XU5)
QUIT
+3 NEW FDA
+4 SET FDA(3.081,XU5_",",3)=$$NOW^XLFDT
SET FDA(3.081,XU5_",",16)=1
+5 DO UPDATE^DIE("","FDA")
+6 QUIT
INQ ;Entry from print template used by "User Inquiry" [XUSERINQ]
+1 if '$DATA(D0)
QUIT
NEW DA
XECUTE ^%ZOSF("UCI")
SET XU1=$PIECE(Y,",",1)
SET XU2=^%ZOSF("VOL")
SET DA=D0
SET XU4=DT-1
+2 FOR XU5=0:0
SET XU5=$ORDER(^XUSEC(0,"CUR",DA,XU5))
if XU5'>0
QUIT
DO B
+3 GOTO EX2
