- XUSTERM ;SEA/AMF/WDE - DEACTIVATE USER ;10/01/18
- ;;8.0;KERNEL;**36,73,135,148,169,222,313,384,489,527,588,645,693**;Jul 10, 1995;Build 13
- ;;"Per VHA Directive 2004-038, this routine should not be modified".
- LKUP N DIRUT,DIC,DIR,XUDA,DA
- S DIC=200,DIC("S")="I $L($P(^(0),U,3))",DIC(0)="AEQMZ",DIC("A")="Select USER to be deactivated: "
- D ^DIC K DIC G END:Y<0 S XUDA=+Y
- D INQ Q:$D(DIRUT)
- S DA=XUDA,DIE=200,DR="["_$$GET^XUPARAM("XUSERDEACT","N")_"]" D GET,XUDIE^XUS5
- S XUDT=$P(^VA(200,DA,0),U,11),XUACT=XUDT&(XUDT>DT) G END:'XUDT
- G:XUACT WHEN G NOW
- ;
- WHEN W !!,XUNAM," will be deactivated on date specified."
- S ZTDTH=XUDT,ZTRTN="DQ1^XUSTERM1",ZTDESC="DEACTIVATE USER",ZTSAVE("XUDA")="",ZTIO="" D ^%ZTLOAD
- G END
- ;
- NOW S DIR("A")=XUNAM_" will be deactivated now. Do you wish to proceed",DIR("B")="YES",DIR("??")="XUUSER-DEACT",DIR(0)="Y"
- D ^DIR I "Yy"'[$E(X_U) S XUDT=$$NOW^XLFDT G WHEN
- W ! S XUVE=1 D ACT
- G END
- ;
- INQ ;Ask to show User Inquiry
- N DIR,DIC,FLDS,BY,FR,TO,Y,L
- S DIR(0)="Y",DIR("A")="View/Print User Inquiry Data",DIR("B")="Yes" D ^DIR Q:$D(DIRUT)!('Y)
- S L=0,DIC=200,FLDS="[XUSERINQ]",BY="NUMBER",(TO,FR)=XUDA D EN1^DIP K DIC
- K DIR S DIR(0)="E" D ^DIR
- Q
- ;
- GET ;XUGRP=mail group, XUKEY=keys, XUSUR=mail surrogates, XUJ=# baskets, XUK=# mail msg, XUIN=# in-basket msg
- ;XUTX1, XUTX2 used in edit templates
- K XUGRP,XUKEY,XUSUR,XUTX1,XUTX2 N %,XU10,XU11,XU20,XU21,XU30,XU31
- S (XU10,XU20)=0,(XU11,XU21,XU31)=""
- S DA=XUDA,XUNAM=$P(^VA(200,XUDA,0),U,1)
- F XUI=0:0 S XUI=$O(^XMB(3.8,"AB",XUDA,XUI)) Q:XUI'>0 D ;Mail groups
- . S XUK=$G(^XMB(3.8,XUI,0)) I XUK="" Q S:'$L($P(XUK,U,2)) $P(XUK,U,2)="PU" ;588 added $G and I XUK="" Q
- . S XUGRP(XUI)=$P(XUK,U,1,2)_U_$S('$D(^XMB(3.8,XUI,3)):0,1:^(3)=XUDA)
- . S XU10=XU10+1 S:$L(XU11)<70 XU11=XU11_","_$P(XUK,U)
- F XUI=0:0 S XUI=$O(^VA(200,XUDA,51,XUI)) Q:XUI'>0 D ;Get keys
- . S %=$G(^DIC(19.1,XUI,0)),XU20=XU20+1
- . S:$L(XU21)<70 XU21=XU21_","_$P(%,U)
- . Q:$P(%,U,4)="y" ;Don't count keep at terminate keys
- . S XUKEY(XUI)=""
- F XUI=0:0 S XUI=$O(^XMB(3.7,"AB",XUDA,XUI)) Q:XUI'>0 D
- . S XUSUR(XUI)="" S:$L(XU31)<70 XU31=XU31_","_$P(^VA(200,XUI,0),U)
- S (XUJ,XUK,XUIN,XUNUM)=0
- F I=.9:0 S I=$O(^XMB(3.7,XUDA,2,I)) Q:I'>0 D
- . S XUJ=XUJ+1,XUNUM=$P($G(^XMB(3.7,XUDA,2,I,1,0)),U,4)
- . S:XUNUM>0 XUK=XUK+XUNUM S:I=1 XUIN=XUNUM
- . Q
- S XUTX1(1)="User has "_XUK_" messages in "_XUJ_" baskets, Member of "_XU10_" Mail Groups."
- S:XU10 XUTX1(2)="Mail Groups: "_$E(XU11,2,80) S:$L(XU31) XUTX1(3)="Surrogate for: "_$E(XU31,2,80)
- S XUTX2(1)="User has "_XU20_" keys" S:XU20 XUTX2(2)=$E(XU21,2,80)
- S XUEMP='($D(XUSUR)!$D(XUKEY)!$D(XUGRP)!XUJ!XUK!XUIN!$L($P(^VA(200,XUDA,0),U,3)))
- Q
- ACT ;First let others clean-up, Then do our part.
- ;D ^XUSTERM2 ;Cleanup by other packages.
- N DIC,DA,DIE,DR
- L +^VA(200,XUDA,0):6
- ;Delete Verify code, prevents user from logging on p645
- ;need Access code for XUSTERM1 to find terminated users
- N XUSVC S XUSVC=$$GET1^DIQ(200,XUDA,11) ;p693 prevent the Bulletin fires for users had already been deactivated
- S DIE=200,DA=XUDA,DR="11///@" D ^DIE
- ;send a bullentin to ISO SECURITY mail group, p693
- I $L(XUSVC)>0 D SEND^XUSTERM1
- ;check Purge flag, quit if no p645
- I '$$GET^XPAR("SYS","XU645",1,"Q") L -^VA(200,XUDA,0) Q
- ;Delete other fields
- ;Access code;Verify Code;PAC;Last signon;SMD delegate;electronic signature,Primary menu,Hinq Employee #
- S DIE=200,DA=XUDA,DR="2///@;11///@;14///@;1.1///@;19///@;19.2///@;20.4///@;201///@;14.9///@" D ^DIE
- L -^VA(200,XUDA,0)
- D DEQUE^XUSERP(XUDA,3) ;Cleanup by other packages.
- ;
- K DIC S DA=XUDA,XUJ=^VA(200,XUDA,0),XUNAM=$P(XUJ,U,1),XUACT(19)=$S($D(^VA(200,XUDA,19)):^(19),1:"") F XUI=5,6,10 S XUACT(XUI)=$P(XUJ,U,XUI)
- ACT1 K ^DISV(XUDA) ; WARNING: This only gets ^DISV entries on current CPU
- ;keys
- I XUACT(6)'="n" F XUI=0:0 S XUI=$O(^VA(200,XUDA,51,XUI)) Q:XUI'>0 I $P($G(^DIC(19.1,XUI,0)),U,4)'="y" S DA=XUI,DA(1)=XUDA,DIK="^VA(200,XUDA,51," D ^DIK W:XUVE "..."
- ;delegated keys
- I XUACT(6)'="n" F XUI=0:0 S XUI=$O(^VA(200,XUDA,52,XUI)) Q:XUI'>0 S DA=XUI,DA(1)=XUDA,DIK="^VA(200,XUDA,52," D ^DIK W:XUVE "..."
- ;Delegated options
- S DIK="^VA(200,XUDA,19.5,",DA(1)=XUDA F XUI=0:0 S XUI=$O(^VA(200,XUDA,19.5,XUI)) Q:XUI'>0 S DA=XUI D ^DIK
- ;Menu templates
- S DIK="^VA(200,XUDA,19.8,",DA(1)=XUDA F XUI=0:0 S XUI=$O(^VA(200,XUDA,19.8,XUI)) Q:XUI'>0 S DA=XUI D ^DIK
- ;Secondary Menus
- S DIK="^VA(200,XUDA,203,",DA(1)=XUDA F XUI=0:0 S XUI=$O(^VA(200,XUDA,203,XUI)) Q:XUI'>0 S DA=XUI D ^DIK
- S DA=0,DA(1)=XUDA D D2^XUFILE1 ;Remove all access to files.
- ;Terminate Person Class
- D TERM^XUA4A72(XUDA,XUDT)
- ;Remove all parameters for the user.
- D DELUSR^XPAR3(XUDA)
- ;
- ACT2 ;XUACT(5) All Mail access, Mail groups
- D MAIL
- W:XUVE "... DONE"
- Q
- ;
- END K C,D,D0,DI,DR,DIC,DIE,DA,DIR,XUEMP,XUDA,XUI,XUJ,XUK,XUACT,XUKEY,XUGRP,XUSUR,XUNAM,XUF,XUDT,XUIN,DIC,XUDB,XUDC,XUDP,XUGP,XUNUM,XUVE,Y
- K XUTX1,XUTX2,DIRUT,DIR
- Q
- MAIL ;Remove mail access
- I XUACT(5)'="n" D TERMINAT^XMUTERM1(XUDA)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSTERM 5027 printed Feb 18, 2025@23:39:30 Page 2
- XUSTERM ;SEA/AMF/WDE - DEACTIVATE USER ;10/01/18
- +1 ;;8.0;KERNEL;**36,73,135,148,169,222,313,384,489,527,588,645,693**;Jul 10, 1995;Build 13
- +2 ;;"Per VHA Directive 2004-038, this routine should not be modified".
- LKUP NEW DIRUT,DIC,DIR,XUDA,DA
- +1 SET DIC=200
- SET DIC("S")="I $L($P(^(0),U,3))"
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select USER to be deactivated: "
- +2 DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- SET XUDA=+Y
- +3 DO INQ
- if $DATA(DIRUT)
- QUIT
- +4 SET DA=XUDA
- SET DIE=200
- SET DR="["_$$GET^XUPARAM("XUSERDEACT","N")_"]"
- DO GET
- DO XUDIE^XUS5
- +5 SET XUDT=$PIECE(^VA(200,DA,0),U,11)
- SET XUACT=XUDT&(XUDT>DT)
- if 'XUDT
- GOTO END
- +6 if XUACT
- GOTO WHEN
- GOTO NOW
- +7 ;
- WHEN WRITE !!,XUNAM," will be deactivated on date specified."
- +1 SET ZTDTH=XUDT
- SET ZTRTN="DQ1^XUSTERM1"
- SET ZTDESC="DEACTIVATE USER"
- SET ZTSAVE("XUDA")=""
- SET ZTIO=""
- DO ^%ZTLOAD
- +2 GOTO END
- +3 ;
- NOW SET DIR("A")=XUNAM_" will be deactivated now. Do you wish to proceed"
- SET DIR("B")="YES"
- SET DIR("??")="XUUSER-DEACT"
- SET DIR(0)="Y"
- +1 DO ^DIR
- IF "Yy"'[$EXTRACT(X_U)
- SET XUDT=$$NOW^XLFDT
- GOTO WHEN
- +2 WRITE !
- SET XUVE=1
- DO ACT
- +3 GOTO END
- +4 ;
- INQ ;Ask to show User Inquiry
- +1 NEW DIR,DIC,FLDS,BY,FR,TO,Y,L
- +2 SET DIR(0)="Y"
- SET DIR("A")="View/Print User Inquiry Data"
- SET DIR("B")="Yes"
- DO ^DIR
- if $DATA(DIRUT)!('Y)
- QUIT
- +3 SET L=0
- SET DIC=200
- SET FLDS="[XUSERINQ]"
- SET BY="NUMBER"
- SET (TO,FR)=XUDA
- DO EN1^DIP
- KILL DIC
- +4 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +5 QUIT
- +6 ;
- GET ;XUGRP=mail group, XUKEY=keys, XUSUR=mail surrogates, XUJ=# baskets, XUK=# mail msg, XUIN=# in-basket msg
- +1 ;XUTX1, XUTX2 used in edit templates
- +2 KILL XUGRP,XUKEY,XUSUR,XUTX1,XUTX2
- NEW %,XU10,XU11,XU20,XU21,XU30,XU31
- +3 SET (XU10,XU20)=0
- SET (XU11,XU21,XU31)=""
- +4 SET DA=XUDA
- SET XUNAM=$PIECE(^VA(200,XUDA,0),U,1)
- +5 ;Mail groups
- FOR XUI=0:0
- SET XUI=$ORDER(^XMB(3.8,"AB",XUDA,XUI))
- if XUI'>0
- QUIT
- Begin DoDot:1
- +6 ;588 added $G and I XUK="" Q
- SET XUK=$GET(^XMB(3.8,XUI,0))
- IF XUK=""
- QUIT
- if '$LENGTH($PIECE(XUK,U,2))
- SET $PIECE(XUK,U,2)="PU"
- +7 SET XUGRP(XUI)=$PIECE(XUK,U,1,2)_U_$SELECT('$DATA(^XMB(3.8,XUI,3)):0,1:^(3)=XUDA)
- +8 SET XU10=XU10+1
- if $LENGTH(XU11)<70
- SET XU11=XU11_","_$PIECE(XUK,U)
- End DoDot:1
- +9 ;Get keys
- FOR XUI=0:0
- SET XUI=$ORDER(^VA(200,XUDA,51,XUI))
- if XUI'>0
- QUIT
- Begin DoDot:1
- +10 SET %=$GET(^DIC(19.1,XUI,0))
- SET XU20=XU20+1
- +11 if $LENGTH(XU21)<70
- SET XU21=XU21_","_$PIECE(%,U)
- +12 ;Don't count keep at terminate keys
- if $PIECE(%,U,4)="y"
- QUIT
- +13 SET XUKEY(XUI)=""
- End DoDot:1
- +14 FOR XUI=0:0
- SET XUI=$ORDER(^XMB(3.7,"AB",XUDA,XUI))
- if XUI'>0
- QUIT
- Begin DoDot:1
- +15 SET XUSUR(XUI)=""
- if $LENGTH(XU31)<70
- SET XU31=XU31_","_$PIECE(^VA(200,XUI,0),U)
- End DoDot:1
- +16 SET (XUJ,XUK,XUIN,XUNUM)=0
- +17 FOR I=.9:0
- SET I=$ORDER(^XMB(3.7,XUDA,2,I))
- if I'>0
- QUIT
- Begin DoDot:1
- +18 SET XUJ=XUJ+1
- SET XUNUM=$PIECE($GET(^XMB(3.7,XUDA,2,I,1,0)),U,4)
- +19 if XUNUM>0
- SET XUK=XUK+XUNUM
- if I=1
- SET XUIN=XUNUM
- +20 QUIT
- End DoDot:1
- +21 SET XUTX1(1)="User has "_XUK_" messages in "_XUJ_" baskets, Member of "_XU10_" Mail Groups."
- +22 if XU10
- SET XUTX1(2)="Mail Groups: "_$EXTRACT(XU11,2,80)
- if $LENGTH(XU31)
- SET XUTX1(3)="Surrogate for: "_$EXTRACT(XU31,2,80)
- +23 SET XUTX2(1)="User has "_XU20_" keys"
- if XU20
- SET XUTX2(2)=$EXTRACT(XU21,2,80)
- +24 SET XUEMP='($DATA(XUSUR)!$DATA(XUKEY)!$DATA(XUGRP)!XUJ!XUK!XUIN!$LENGTH($PIECE(^VA(200,XUDA,0),U,3)))
- +25 QUIT
- ACT ;First let others clean-up, Then do our part.
- +1 ;D ^XUSTERM2 ;Cleanup by other packages.
- +2 NEW DIC,DA,DIE,DR
- +3 LOCK +^VA(200,XUDA,0):6
- +4 ;Delete Verify code, prevents user from logging on p645
- +5 ;need Access code for XUSTERM1 to find terminated users
- +6 ;p693 prevent the Bulletin fires for users had already been deactivated
- NEW XUSVC
- SET XUSVC=$$GET1^DIQ(200,XUDA,11)
- +7 SET DIE=200
- SET DA=XUDA
- SET DR="11///@"
- DO ^DIE
- +8 ;send a bullentin to ISO SECURITY mail group, p693
- +9 IF $LENGTH(XUSVC)>0
- DO SEND^XUSTERM1
- +10 ;check Purge flag, quit if no p645
- +11 IF '$$GET^XPAR("SYS","XU645",1,"Q")
- LOCK -^VA(200,XUDA,0)
- QUIT
- +12 ;Delete other fields
- +13 ;Access code;Verify Code;PAC;Last signon;SMD delegate;electronic signature,Primary menu,Hinq Employee #
- +14 SET DIE=200
- SET DA=XUDA
- SET DR="2///@;11///@;14///@;1.1///@;19///@;19.2///@;20.4///@;201///@;14.9///@"
- DO ^DIE
- +15 LOCK -^VA(200,XUDA,0)
- +16 ;Cleanup by other packages.
- DO DEQUE^XUSERP(XUDA,3)
- +17 ;
- +18 KILL DIC
- SET DA=XUDA
- SET XUJ=^VA(200,XUDA,0)
- SET XUNAM=$PIECE(XUJ,U,1)
- SET XUACT(19)=$SELECT($DATA(^VA(200,XUDA,19)):^(19),1:"")
- FOR XUI=5,6,10
- SET XUACT(XUI)=$PIECE(XUJ,U,XUI)
- ACT1 ; WARNING: This only gets ^DISV entries on current CPU
- KILL ^DISV(XUDA)
- +1 ;keys
- +2 IF XUACT(6)'="n"
- FOR XUI=0:0
- SET XUI=$ORDER(^VA(200,XUDA,51,XUI))
- if XUI'>0
- QUIT
- IF $PIECE($GET(^DIC(19.1,XUI,0)),U,4)'="y"
- SET DA=XUI
- SET DA(1)=XUDA
- SET DIK="^VA(200,XUDA,51,"
- DO ^DIK
- if XUVE
- WRITE "..."
- +3 ;delegated keys
- +4 IF XUACT(6)'="n"
- FOR XUI=0:0
- SET XUI=$ORDER(^VA(200,XUDA,52,XUI))
- if XUI'>0
- QUIT
- SET DA=XUI
- SET DA(1)=XUDA
- SET DIK="^VA(200,XUDA,52,"
- DO ^DIK
- if XUVE
- WRITE "..."
- +5 ;Delegated options
- +6 SET DIK="^VA(200,XUDA,19.5,"
- SET DA(1)=XUDA
- FOR XUI=0:0
- SET XUI=$ORDER(^VA(200,XUDA,19.5,XUI))
- if XUI'>0
- QUIT
- SET DA=XUI
- DO ^DIK
- +7 ;Menu templates
- +8 SET DIK="^VA(200,XUDA,19.8,"
- SET DA(1)=XUDA
- FOR XUI=0:0
- SET XUI=$ORDER(^VA(200,XUDA,19.8,XUI))
- if XUI'>0
- QUIT
- SET DA=XUI
- DO ^DIK
- +9 ;Secondary Menus
- +10 SET DIK="^VA(200,XUDA,203,"
- SET DA(1)=XUDA
- FOR XUI=0:0
- SET XUI=$ORDER(^VA(200,XUDA,203,XUI))
- if XUI'>0
- QUIT
- SET DA=XUI
- DO ^DIK
- +11 ;Remove all access to files.
- SET DA=0
- SET DA(1)=XUDA
- DO D2^XUFILE1
- +12 ;Terminate Person Class
- +13 DO TERM^XUA4A72(XUDA,XUDT)
- +14 ;Remove all parameters for the user.
- +15 DO DELUSR^XPAR3(XUDA)
- +16 ;
- ACT2 ;XUACT(5) All Mail access, Mail groups
- +1 DO MAIL
- +2 if XUVE
- WRITE "... DONE"
- +3 QUIT
- +4 ;
- END KILL C,D,D0,DI,DR,DIC,DIE,DA,DIR,XUEMP,XUDA,XUI,XUJ,XUK,XUACT,XUKEY,XUGRP,XUSUR,XUNAM,XUF,XUDT,XUIN,DIC,XUDB,XUDC,XUDP,XUGP,XUNUM,XUVE,Y
- +1 KILL XUTX1,XUTX2,DIRUT,DIR
- +2 QUIT
- MAIL ;Remove mail access
- +1 IF XUACT(5)'="n"
- DO TERMINAT^XMUTERM1(XUDA)
- +2 QUIT