- 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 Feb 18, 2025@23:39:31 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 ;