XUSTERM1 ;SEA/WDE - DEACTIVATE USER ;09/18/18
;;8.0;KERNEL;**102,180,208,222,274,313,332,360,384,436,514,693**;Jul 10, 1995;Build 13
;;Per VHA Directive 6402, this routine should not be modified.
ENALL ;Interactive scan all
S U="^",DTIME=$G(DTIME,60)
W !!,"This option can purge all access & verify codes, mail baskets, messages,",!,"authorized senders access, keys, and electronic signature codes of users who have been terminated."
RD1 W !!,"Do you wish to proceed "
S %=2 D YN^DICN G:%=2!(%=-1) END I %=0 S XQH="XUUSER-PURGEATT" D EN^XQH G RD1
RD2 W !,"Do you wish to verify each user "
S %=2,XUVE=0 D YN^DICN S:%=1 XUVE=1 G:%=1 CHECK G:%=-1 END I %=0 S XQH="XUUSER-PURGEATT-VER" D EN^XQH G RD2
QUE W !,"Do you wish to have this queued for a later time "
S %=1 D YN^DICN I %=1 D Q
. S ZTDESC="USER DEACTIVATION",ZTRTN="CHECK^XUSTERM1",ZTIO="",ZTSAVE("DUZ*")=""
. D ^%ZTLOAD
. Q
I %=0 K X,XUVE Q
;Fall thru if user doesn't queue
CHECK ;Entry point for taskman.
N XUDT540,XUDT90,XUDT30,FDA,XUDT,XUAAW
S U="^",DT=$$DT^XLFDT(),XUDT90=$$HTFM^XLFDT($H-90,1),XUDT30=$$HTFM^XLFDT($H-30,1)
S XUAAW=+$P($G(^XTV(8989.3,1,3)),U,4) ;Academic Waiver
S XUDT540=$$HTFM^XLFDT($H-540,1) ;*p332
S XUDA=.6,XUVE=$G(XUVE,0)
F S XUDA=$O(^VA(200,XUDA)) Q:XUDA'>0 S XUJ=$G(^(XUDA,0)) D
. S XUDT=$P(XUJ,U,11)
. I $P(XUJ,U,3)]"",$L(XUDT),(XUDT'>DT) D
. . D GET
. . I 'XUEMP K Y D:XUVE DISP Q:$D(Y) D ACT ;XUEMP=any data to remove
. . Q
. I $P(XUJ,U,3)]"",'$P(XUJ,U,8),$$NOSIGNON D DISUSER(XUDA)
. I $P(XUJ,U,7) D AUSER(XUDA) ;*p332
. Q
;
END K XUEMP,XUDA,XUI,XUJ,XUK,XUACT,XUKEY,XUGRP,XUSUR,XUNAM,XUF,XUDT,XUIN,XUVE,X,DIC,XUDB,XUDC,XUDP
Q
;
DISUSER(XUDA) ;Set DISUSER flag and reason, Remove last menu option
Q:$P(XUJ,U,7) ;DISUSER already set *p332
N %,FDA S %=XUDA_","
S FDA(200,%,7)=1,FDA(200,%,9.4)="User Inactive for too long"
D FILE^DIE("","FDA"),CONTCL(XUDA) ;Set Disuser
Q
;
AUSER(XUDA) ;If DISUSERed and Last Sign > 540[18Mo.*30] days, then remove"AUSER" xref
I $D(^XUSEC("XUORES",XUDA)) Q ;Owner of XUORES key ;p*436
N Q S Q=$P($G(^VA(200,XUDA,1.1)),U) ;Get last sign-on
I $L(Q),Q<XUDT540 K ^VA(200,"AUSER",$P(XUJ,U),XUDA) ;*p360;*p384
Q
;
;If site has an Academic Affiliation Waiver the last sign-on moves to 90 days from 30.
NOSIGNON() ;Check last signon. Return 1 if should disable account
N Q S Q=$P($G(^VA(200,XUDA,1.1)),U) ;Get last sign-on
I $L(Q),Q>$S('XUAAW:XUDT30,1:XUDT90) Q 0 ;Last sign-on within 30/90 days VA Handbook 6500 ;p514
S Q=$P($G(^VA(200,XUDA,1.1)),U,4) ;Get last Edit date
I $L(Q),Q>XUDT30 Q 0 ;User edited in last 30 days
S Q=$P($G(^VA(200,XUDA,1)),U,7) ;Create Date
I $L(Q),Q>XUDT30 Q 0 ;User set up in last 30 days
S Q=$P($G(^VA(200,XUDA,.1)),U) ;Get verify code change date
I $L(Q),(Q+30)>$H Q 0 ;Verify code changed in last 30 days
Q 1
;
CONTCL(XUDA) ;Clear the fields for Menu "Continue"
N FDA
S FDA(200,XUDA_",",202.1)="@",FDA(200,XUDA_",",202.2)="@"
D FILE^DIE("","FDA") ;Clear 202.1 and 202.2
Q
;
ACT ;
D ACT^XUSTERM
S XUJ=^VA(200,XUDA,0) ;Get new copy of zero node
Q
;
GET ;Kill ^DISV entries each time, should get all CPUs at some point
N XUJ
D GET^XUSTERM K ^DISV(XUDA),Y
Q
DISP ;Display info and get responses.
N DA,DIE,DR,XUJ
S DA=XUDA
L +^VA(200,DA,0):6 D DISP2 L -^VA(200,DA,0)
Q
DISP2 ;Do the work.
W !!,$S(XUTX1(1)["User":XUNAM_$P(XUTX1(1),"User",2),1:XUTX1(1)) ;*p360
S DR="9.21//YES",DIE=200 D ^DIE Q:$D(Y) G:'$D(XUSUR) KEYS
W !!,XUNAM," acts as surrogate for the following users:"
S XUJ=0,XUI=3 F XUK=0:1 S XUJ=$O(XUSUR(XUJ)) Q:XUJ'>0 W:'(XUK#XUI) ! W ?(XUK#XUI*26),$P(^VA(200,XUJ,0),U,1) W !,"These surrogate privileges will be deleted on deactivation."
KEYS ;This section checks for authorized senders of mail groups and security keys.
W !,"User will no longer be an authorized sender to any mail groups."
I '$D(XUKEY) W !!,XUNAM," currently holds no keys." G KEYS1
W !!,XUNAM," holds the following keys: "
S XUJ=0,XUI=5 F XUK=0:1 S XUJ=$O(XUKEY(XUJ)) Q:XUJ'>0 W:'(XUK#XUI) ! W ?(XUK#XUI*15),$P($G(^DIC(19.1,XUJ,0)),U,1)
KEYS1 W ! S DR="9.22//YES" D ^DIE Q:$D(Y)
GROUP I '$D(XUGRP) W !!,XUNAM," currently is not a member of any MAIL GROUP." G GROUP1
W !!,XUNAM," is a member of the following Mail Groups:"
S XUI="" F XUI=0:0 S XUI=$O(XUGRP(XUI)) Q:XUI'>0 D
. S XUJ=XUGRP(XUI)
. I $P(XUJ,U,2)="PU"!$D(^XMB(3.8,"AB",XUDA,XUI)) W !?2,$P(XUJ,U,1) W:$P(XUJ,U,3) " (Organizer)" W ?40,$S(($P(XUJ,U,2)="PR"):"(Private)",1:"(Public)")
. Q
GROUP1 W ! S DR="9.23//YES" D ^DIE Q:$D(Y)
Q
;
DQ1 ;Terminate one person.
N XUJ,XUDT,XUVE
S XUJ=$G(^VA(200,XUDA,0)),XUDT=$P(XUJ,U,11) I XUDT,(XUDT'>DT) D
. S XUVE=0 D GET I 'XUEMP D ACT
. Q
Q
;
SEND ; send deactivated message to assigned mail group
K XMB,XMY
N XUSTN S XUSTN=""
S XMB(1)=$$GET1^DIQ(200,XUDA,.01)
S XMB(2)=$$GET1^DIQ(200,XUDA,8)
S XMB(3)=$$GET1^DIQ(200,XUDA,29)
S XMB(4)=XUDA
S XMB(5)=""
S XUSTN=$$SITE^VASITE
S XMB(5)=$P(XUSTN,"^",3)_" STATION NAME: "_$P(XUSTN,"^",2)
S XMB(6)=$$FMTE^XLFDT(XUDT)
S XMB="XUSERDEAC" D ^XMB:$D(^XMB(3.6,"B",XMB))
K XMB,XMY
Q
;
SEND1(XUDA,X) ; send disusered message to assigned mail group p693
K XMB,XMY
I +$G(X)'>0 Q
N XUSTN S XUSTN=""
S XMB(1)=$$GET1^DIQ(200,XUDA,.01)
S XMB(2)=$$GET1^DIQ(200,XUDA,8)
S XMB(3)=$$GET1^DIQ(200,XUDA,29)
S XMB(4)=XUDA
S XMB(5)=""
S XUSTN=$$SITE^VASITE
S XMB(5)=$P(XUSTN,"^",3)_" "_$P(XUSTN,"^",2)
S XMB(6)=$$FMTE^XLFDT($$DT^XLFDT())
S XMB="XUSERDIS" D ^XMB:$D(^XMB(3.6,"B",XMB))
K XMB,XMY
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSTERM1 5601 printed Dec 13, 2024@02:13:04 Page 2
XUSTERM1 ;SEA/WDE - DEACTIVATE USER ;09/18/18
+1 ;;8.0;KERNEL;**102,180,208,222,274,313,332,360,384,436,514,693**;Jul 10, 1995;Build 13
+2 ;;Per VHA Directive 6402, this routine should not be modified.
ENALL ;Interactive scan all
+1 SET U="^"
SET DTIME=$GET(DTIME,60)
+2 WRITE !!,"This option can purge all access & verify codes, mail baskets, messages,",!,"authorized senders access, keys, and electronic signature codes of users who have been terminated."
RD1 WRITE !!,"Do you wish to proceed "
+1 SET %=2
DO YN^DICN
if %=2!(%=-1)
GOTO END
IF %=0
SET XQH="XUUSER-PURGEATT"
DO EN^XQH
GOTO RD1
RD2 WRITE !,"Do you wish to verify each user "
+1 SET %=2
SET XUVE=0
DO YN^DICN
if %=1
SET XUVE=1
if %=1
GOTO CHECK
if %=-1
GOTO END
IF %=0
SET XQH="XUUSER-PURGEATT-VER"
DO EN^XQH
GOTO RD2
QUE WRITE !,"Do you wish to have this queued for a later time "
+1 SET %=1
DO YN^DICN
IF %=1
Begin DoDot:1
+2 SET ZTDESC="USER DEACTIVATION"
SET ZTRTN="CHECK^XUSTERM1"
SET ZTIO=""
SET ZTSAVE("DUZ*")=""
+3 DO ^%ZTLOAD
+4 QUIT
End DoDot:1
QUIT
+5 IF %=0
KILL X,XUVE
QUIT
+6 ;Fall thru if user doesn't queue
CHECK ;Entry point for taskman.
+1 NEW XUDT540,XUDT90,XUDT30,FDA,XUDT,XUAAW
+2 SET U="^"
SET DT=$$DT^XLFDT()
SET XUDT90=$$HTFM^XLFDT($HOROLOG-90,1)
SET XUDT30=$$HTFM^XLFDT($HOROLOG-30,1)
+3 ;Academic Waiver
SET XUAAW=+$PIECE($GET(^XTV(8989.3,1,3)),U,4)
+4 ;*p332
SET XUDT540=$$HTFM^XLFDT($HOROLOG-540,1)
+5 SET XUDA=.6
SET XUVE=$GET(XUVE,0)
+6 FOR
SET XUDA=$ORDER(^VA(200,XUDA))
if XUDA'>0
QUIT
SET XUJ=$GET(^(XUDA,0))
Begin DoDot:1
+7 SET XUDT=$PIECE(XUJ,U,11)
+8 IF $PIECE(XUJ,U,3)]""
IF $LENGTH(XUDT)
IF (XUDT'>DT)
Begin DoDot:2
+9 DO GET
+10 ;XUEMP=any data to remove
IF 'XUEMP
KILL Y
if XUVE
DO DISP
if $DATA(Y)
QUIT
DO ACT
+11 QUIT
End DoDot:2
+12 IF $PIECE(XUJ,U,3)]""
IF '$PIECE(XUJ,U,8)
IF $$NOSIGNON
DO DISUSER(XUDA)
+13 ;*p332
IF $PIECE(XUJ,U,7)
DO AUSER(XUDA)
+14 QUIT
End DoDot:1
+15 ;
END KILL XUEMP,XUDA,XUI,XUJ,XUK,XUACT,XUKEY,XUGRP,XUSUR,XUNAM,XUF,XUDT,XUIN,XUVE,X,DIC,XUDB,XUDC,XUDP
+1 QUIT
+2 ;
DISUSER(XUDA) ;Set DISUSER flag and reason, Remove last menu option
+1 ;DISUSER already set *p332
if $PIECE(XUJ,U,7)
QUIT
+2 NEW %,FDA
SET %=XUDA_","
+3 SET FDA(200,%,7)=1
SET FDA(200,%,9.4)="User Inactive for too long"
+4 ;Set Disuser
DO FILE^DIE("","FDA")
DO CONTCL(XUDA)
+5 QUIT
+6 ;
AUSER(XUDA) ;If DISUSERed and Last Sign > 540[18Mo.*30] days, then remove"AUSER" xref
+1 ;Owner of XUORES key ;p*436
IF $DATA(^XUSEC("XUORES",XUDA))
QUIT
+2 ;Get last sign-on
NEW Q
SET Q=$PIECE($GET(^VA(200,XUDA,1.1)),U)
+3 ;*p360;*p384
IF $LENGTH(Q)
IF Q<XUDT540
KILL ^VA(200,"AUSER",$PIECE(XUJ,U),XUDA)
+4 QUIT
+5 ;
+6 ;If site has an Academic Affiliation Waiver the last sign-on moves to 90 days from 30.
NOSIGNON() ;Check last signon. Return 1 if should disable account
+1 ;Get last sign-on
NEW Q
SET Q=$PIECE($GET(^VA(200,XUDA,1.1)),U)
+2 ;Last sign-on within 30/90 days VA Handbook 6500 ;p514
IF $LENGTH(Q)
IF Q>$SELECT('XUAAW:XUDT30,1:XUDT90)
QUIT 0
+3 ;Get last Edit date
SET Q=$PIECE($GET(^VA(200,XUDA,1.1)),U,4)
+4 ;User edited in last 30 days
IF $LENGTH(Q)
IF Q>XUDT30
QUIT 0
+5 ;Create Date
SET Q=$PIECE($GET(^VA(200,XUDA,1)),U,7)
+6 ;User set up in last 30 days
IF $LENGTH(Q)
IF Q>XUDT30
QUIT 0
+7 ;Get verify code change date
SET Q=$PIECE($GET(^VA(200,XUDA,.1)),U)
+8 ;Verify code changed in last 30 days
IF $LENGTH(Q)
IF (Q+30)>$HOROLOG
QUIT 0
+9 QUIT 1
+10 ;
CONTCL(XUDA) ;Clear the fields for Menu "Continue"
+1 NEW FDA
+2 SET FDA(200,XUDA_",",202.1)="@"
SET FDA(200,XUDA_",",202.2)="@"
+3 ;Clear 202.1 and 202.2
DO FILE^DIE("","FDA")
+4 QUIT
+5 ;
ACT ;
+1 DO ACT^XUSTERM
+2 ;Get new copy of zero node
SET XUJ=^VA(200,XUDA,0)
+3 QUIT
+4 ;
GET ;Kill ^DISV entries each time, should get all CPUs at some point
+1 NEW XUJ
+2 DO GET^XUSTERM
KILL ^DISV(XUDA),Y
+3 QUIT
DISP ;Display info and get responses.
+1 NEW DA,DIE,DR,XUJ
+2 SET DA=XUDA
+3 LOCK +^VA(200,DA,0):6
DO DISP2
LOCK -^VA(200,DA,0)
+4 QUIT
DISP2 ;Do the work.
+1 ;*p360
WRITE !!,$SELECT(XUTX1(1)["User":XUNAM_$PIECE(XUTX1(1),"User",2),1:XUTX1(1))
+2 SET DR="9.21//YES"
SET DIE=200
DO ^DIE
if $DATA(Y)
QUIT
if '$DATA(XUSUR)
GOTO KEYS
+3 WRITE !!,XUNAM," acts as surrogate for the following users:"
+4 SET XUJ=0
SET XUI=3
FOR XUK=0:1
SET XUJ=$ORDER(XUSUR(XUJ))
if XUJ'>0
QUIT
if '(XUK#XUI)
WRITE !
WRITE ?(XUK#XUI*26),$PIECE(^VA(200,XUJ,0),U,1)
WRITE !,"These surrogate privileges will be deleted on deactivation."
KEYS ;This section checks for authorized senders of mail groups and security keys.
+1 WRITE !,"User will no longer be an authorized sender to any mail groups."
+2 IF '$DATA(XUKEY)
WRITE !!,XUNAM," currently holds no keys."
GOTO KEYS1
+3 WRITE !!,XUNAM," holds the following keys: "
+4 SET XUJ=0
SET XUI=5
FOR XUK=0:1
SET XUJ=$ORDER(XUKEY(XUJ))
if XUJ'>0
QUIT
if '(XUK#XUI)
WRITE !
WRITE ?(XUK#XUI*15),$PIECE($GET(^DIC(19.1,XUJ,0)),U,1)
KEYS1 WRITE !
SET DR="9.22//YES"
DO ^DIE
if $DATA(Y)
QUIT
GROUP IF '$DATA(XUGRP)
WRITE !!,XUNAM," currently is not a member of any MAIL GROUP."
GOTO GROUP1
+1 WRITE !!,XUNAM," is a member of the following Mail Groups:"
+2 SET XUI=""
FOR XUI=0:0
SET XUI=$ORDER(XUGRP(XUI))
if XUI'>0
QUIT
Begin DoDot:1
+3 SET XUJ=XUGRP(XUI)
+4 IF $PIECE(XUJ,U,2)="PU"!$DATA(^XMB(3.8,"AB",XUDA,XUI))
WRITE !?2,$PIECE(XUJ,U,1)
if $PIECE(XUJ,U,3)
WRITE " (Organizer)"
WRITE ?40,$SELECT(($PIECE(XUJ,U,2)="PR"):"(Private)",1:"(Public)")
+5 QUIT
End DoDot:1
GROUP1 WRITE !
SET DR="9.23//YES"
DO ^DIE
if $DATA(Y)
QUIT
+1 QUIT
+2 ;
DQ1 ;Terminate one person.
+1 NEW XUJ,XUDT,XUVE
+2 SET XUJ=$GET(^VA(200,XUDA,0))
SET XUDT=$PIECE(XUJ,U,11)
IF XUDT
IF (XUDT'>DT)
Begin DoDot:1
+3 SET XUVE=0
DO GET
IF 'XUEMP
DO ACT
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
SEND ; send deactivated message to assigned mail group
+1 KILL XMB,XMY
+2 NEW XUSTN
SET XUSTN=""
+3 SET XMB(1)=$$GET1^DIQ(200,XUDA,.01)
+4 SET XMB(2)=$$GET1^DIQ(200,XUDA,8)
+5 SET XMB(3)=$$GET1^DIQ(200,XUDA,29)
+6 SET XMB(4)=XUDA
+7 SET XMB(5)=""
+8 SET XUSTN=$$SITE^VASITE
+9 SET XMB(5)=$PIECE(XUSTN,"^",3)_" STATION NAME: "_$PIECE(XUSTN,"^",2)
+10 SET XMB(6)=$$FMTE^XLFDT(XUDT)
+11 SET XMB="XUSERDEAC"
if $DATA(^XMB(3.6,"B",XMB))
DO ^XMB
+12 KILL XMB,XMY
+13 QUIT
+14 ;
SEND1(XUDA,X) ; send disusered message to assigned mail group p693
+1 KILL XMB,XMY
+2 IF +$GET(X)'>0
QUIT
+3 NEW XUSTN
SET XUSTN=""
+4 SET XMB(1)=$$GET1^DIQ(200,XUDA,.01)
+5 SET XMB(2)=$$GET1^DIQ(200,XUDA,8)
+6 SET XMB(3)=$$GET1^DIQ(200,XUDA,29)
+7 SET XMB(4)=XUDA
+8 SET XMB(5)=""
+9 SET XUSTN=$$SITE^VASITE
+10 SET XMB(5)=$PIECE(XUSTN,"^",3)_" "_$PIECE(XUSTN,"^",2)
+11 SET XMB(6)=$$FMTE^XLFDT($$DT^XLFDT())
+12 SET XMB="XUSERDIS"
if $DATA(^XMB(3.6,"B",XMB))
DO ^XMB
+13 KILL XMB,XMY
+14 QUIT
+15 ;
