XQSMDCPY ;ISC-SF/JLI - COPY ONE USER (PRIM & SEC MENUS, KEYS, FILES) TO ANOTHER USER ;07/12/10 11:12
;;8.0;KERNEL;**19,552,775**;Jul 10, 1995;Build 11
;Per VHA Directive 6402, this routine should not be modified.
N ZTDESC,ZTIO,ZTRTN,ZTSAVE
S XQBOSS=0 I $D(^XUSEC("XUMGR",DUZ)) S XQBOSS=1
I 'XQBOSS W !!,?5,"Note: You must have been delegated these options and",!,?11,"keys to transfer them from user to user.",!
;I 'XQBOSS,$O(^VA(200,DUZ,19.5,0))'>0 W !!,$C(7),"No Menus have been delegated to you to use this option",!,"If there are questions see your site manager's staff." Q
W !! S DIC("A")="Select the user to be COPIED FROM: ",DIC=200,DIC(0)="AQEM" D ^DIC Q:Y'>0 S XQUSR1=+Y
S XQUSRPM=+$G(^VA(200,XQUSR1,201)) I XQUSRPM="" S XQUSRPM=0 W !,"The donor user has no primary menu."
I 'XQBOSS,XQUSRPM>0,'$D(^VA(200,DUZ,19.5,"B",XQUSRPM)) W !,$C(7),"You are not able to give out this user's primary menu ",$P(^DIC(19,XQUSRPM,0),U) S XQUSRPM=0
S XQUSEC(0)="" F I=0:0 S I=$O(^VA(200,XQUSR1,203,I)) Q:I'>0 S X=^(I,0),XQUSEC(+X)=$P(X,U,2) I 'XQBOSS,'$D(^VA(200,DUZ,19.5,"B",+X)) W !,$C(7),"Skipping secondary menu ",$P(^DIC(19,+X,0),U) K XQUSEC(+X)
;I XQUSRPM'>0,$O(XQUSEC(0))'>0 W !!,$C(7),"No Primary or Secondary Menus to copy -- quitting.",!! G EXIT
S XQUSEK(0)="" F I=0:0 S I=$O(^VA(200,XQUSR1,51,I)) Q:I'>0 S X=+^(I,0) I $D(^DIC(19.1,+X,0)) S XQUSEK(X)=X I 'XQBOSS,'$D(^VA(200,DUZ,52,"B",X)) W !,$C(7),"Not authorized to give ",$P(^DIC(19.1,X,0),U)," key -- skipping" K XQUSEK(X)
;
I $$PSDRPH^XUSERBLK(XQUSR1) D
. N DIR
. W !!,"The PSDRPH key cannot be allocated / de-allocated by this option. Please"
. W !,"use the option 'Allocate/De-Allocate of PSDRPH Key (Audited)' if necessary."
. W !,"The PSDRPH key will not be copied to the new user.",!
. S DIR(0)="E",DIR("A")="Press ENTER to continue" D ^DIR
;
;Get recipient user
;
S DIC("A")="Select a USER to be COPIED TO: ",DIC="^VA(200,",DIC(0)="AEMQ"
F XQI=0:0 D ^DIC Q:Y'>0 S XUSR(+Y)="",DIC("A")="Select ANOTHER USER: "
K DIC
;
G:$O(XUSR(0))'>0 EXIT
R !!,"Do you want to QUEUE this job ? Y// ",X:DTIME Q:'$T!(X[U) S:X="" X="Y" I "Yy"[$E(X) D TSK G EXIT
;
DQ ;
F XQI=0:0 S XQI=$O(XUSR(XQI)) Q:XQI'>0 D COPY1
EXIT ;
K %,D,D0,DA,DI,DISYS,DIC,DIE,DR,X,XQBOSS,XQI,XQJ,XQUSEK,XQUSR1,XUSR,XQUSEC,XQUSRPM,Y,I
Q
;
COPY1 I XQUSRPM>0 S DIE=200,DA=XQI,DR="201///"_$P(^DIC(19,XQUSRPM,0),U) D ^DIE
S:'$D(^VA(200,XQI,203,0)) ^(0)="^200.03P" S DLAYGO=200
F XQJ=0:0 S XQJ=$O(XQUSEC(XQJ)) Q:XQJ'>0 S DIC="^VA(200,"_XQI_",203,",DA(1)=XQI,DIC("P")=200.03,X=$P(^DIC(19,XQJ,0),U),DIC(0)="ML" D ^DIC I Y>0,'$P(Y,U,3),XQUSEC(XQJ)'="" S DIE=DIC,DIE("P")=200.03,DA=+Y,DR="2///"_XQUSEC(XQJ)_";" D ^DIE
S:'$D(^VA(200,XQI,51,0)) ^(0)="^200.051P^"
S (DA,DA(1))=XQI F XQJ=0:0 S XQJ=$O(XQUSEK(XQJ)) Q:XQJ'>0 S DIC="^VA(200,"_XQI_",51,",DIC("P")=200.051,DIC(0)="ML",X=$P(^DIC(19.1,XQUSEK(XQJ),0),U) D
.Q:X="PSDRPH" ; XU*8.0*775
.D ^DIC
K DLAYGO
Q
;
TSK S ZTRTN="DQ^XQSMDCPY",ZTIO="",ZTSAVE("XUSR(")="",ZTDESC="XQSMD Copy User",ZTSAVE("XQUSRPM")="",ZTSAVE("XQUSEC(")="",ZTSAVE("XQUSEK(")="" D ^%ZTLOAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQSMDCPY 3125 printed Dec 13, 2024@02:06:36 Page 2
XQSMDCPY ;ISC-SF/JLI - COPY ONE USER (PRIM & SEC MENUS, KEYS, FILES) TO ANOTHER USER ;07/12/10 11:12
+1 ;;8.0;KERNEL;**19,552,775**;Jul 10, 1995;Build 11
+2 ;Per VHA Directive 6402, this routine should not be modified.
+3 NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE
+4 SET XQBOSS=0
IF $DATA(^XUSEC("XUMGR",DUZ))
SET XQBOSS=1
+5 IF 'XQBOSS
WRITE !!,?5,"Note: You must have been delegated these options and",!,?11,"keys to transfer them from user to user.",!
+6 ;I 'XQBOSS,$O(^VA(200,DUZ,19.5,0))'>0 W !!,$C(7),"No Menus have been delegated to you to use this option",!,"If there are questions see your site manager's staff." Q
+7 WRITE !!
SET DIC("A")="Select the user to be COPIED FROM: "
SET DIC=200
SET DIC(0)="AQEM"
DO ^DIC
if Y'>0
QUIT
SET XQUSR1=+Y
+8 SET XQUSRPM=+$GET(^VA(200,XQUSR1,201))
IF XQUSRPM=""
SET XQUSRPM=0
WRITE !,"The donor user has no primary menu."
+9 IF 'XQBOSS
IF XQUSRPM>0
IF '$DATA(^VA(200,DUZ,19.5,"B",XQUSRPM))
WRITE !,$CHAR(7),"You are not able to give out this user's primary menu ",$PIECE(^DIC(19,XQUSRPM,0),U)
SET XQUSRPM=0
+10 SET XQUSEC(0)=""
FOR I=0:0
SET I=$ORDER(^VA(200,XQUSR1,203,I))
if I'>0
QUIT
SET X=^(I,0)
SET XQUSEC(+X)=$PIECE(X,U,2)
IF 'XQBOSS
IF '$DATA(^VA(200,DUZ,19.5,"B",+X))
WRITE !,$CHAR(7),"Skipping secondary menu ",$PIECE(^DIC(19,+X,0),U)
KILL XQUSEC(+X)
+11 ;I XQUSRPM'>0,$O(XQUSEC(0))'>0 W !!,$C(7),"No Primary or Secondary Menus to copy -- quitting.",!! G EXIT
+12 SET XQUSEK(0)=""
FOR I=0:0
SET I=$ORDER(^VA(200,XQUSR1,51,I))
if I'>0
QUIT
SET X=+^(I,0)
IF $DATA(^DIC(19.1,+X,0))
SET XQUSEK(X)=X
IF 'XQBOSS
IF '$DATA(^VA(200,DUZ,52,"B",X))
WRITE !,$CHAR(7),"Not authorized to give ",$PIECE(^DIC(19.1,X,0),U)," key -- skipping"
KILL XQUSEK(X)
+13 ;
+14 IF $$PSDRPH^XUSERBLK(XQUSR1)
Begin DoDot:1
+15 NEW DIR
+16 WRITE !!,"The PSDRPH key cannot be allocated / de-allocated by this option. Please"
+17 WRITE !,"use the option 'Allocate/De-Allocate of PSDRPH Key (Audited)' if necessary."
+18 WRITE !,"The PSDRPH key will not be copied to the new user.",!
+19 SET DIR(0)="E"
SET DIR("A")="Press ENTER to continue"
DO ^DIR
End DoDot:1
+20 ;
+21 ;Get recipient user
+22 ;
+23 SET DIC("A")="Select a USER to be COPIED TO: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
+24 FOR XQI=0:0
DO ^DIC
if Y'>0
QUIT
SET XUSR(+Y)=""
SET DIC("A")="Select ANOTHER USER: "
+25 KILL DIC
+26 ;
+27 if $ORDER(XUSR(0))'>0
GOTO EXIT
+28 READ !!,"Do you want to QUEUE this job ? Y// ",X:DTIME
if '$TEST!(X[U)
QUIT
if X=""
SET X="Y"
IF "Yy"[$EXTRACT(X)
DO TSK
GOTO EXIT
+29 ;
DQ ;
+1 FOR XQI=0:0
SET XQI=$ORDER(XUSR(XQI))
if XQI'>0
QUIT
DO COPY1
EXIT ;
+1 KILL %,D,D0,DA,DI,DISYS,DIC,DIE,DR,X,XQBOSS,XQI,XQJ,XQUSEK,XQUSR1,XUSR,XQUSEC,XQUSRPM,Y,I
+2 QUIT
+3 ;
COPY1 IF XQUSRPM>0
SET DIE=200
SET DA=XQI
SET DR="201///"_$PIECE(^DIC(19,XQUSRPM,0),U)
DO ^DIE
+1 if '$DATA(^VA(200,XQI,203,0))
SET ^(0)="^200.03P"
SET DLAYGO=200
+2 FOR XQJ=0:0
SET XQJ=$ORDER(XQUSEC(XQJ))
if XQJ'>0
QUIT
SET DIC="^VA(200,"_XQI_",203,"
SET DA(1)=XQI
SET DIC("P")=200.03
SET X=$PIECE(^DIC(19,XQJ,0),U)
SET DIC(0)="ML"
DO ^DIC
IF Y>0
IF '$PIECE(Y,U,3)
IF XQUSEC(XQJ)'=""
SET DIE=DIC
SET DIE("P")=200.03
SET DA=+Y
SET DR="2///"_XQUSEC(XQJ)_";"
DO ^DIE
+3 if '$DATA(^VA(200,XQI,51,0))
SET ^(0)="^200.051P^"
+4 SET (DA,DA(1))=XQI
FOR XQJ=0:0
SET XQJ=$ORDER(XQUSEK(XQJ))
if XQJ'>0
QUIT
SET DIC="^VA(200,"_XQI_",51,"
SET DIC("P")=200.051
SET DIC(0)="ML"
SET X=$PIECE(^DIC(19.1,XQUSEK(XQJ),0),U)
Begin DoDot:1
+5 ; XU*8.0*775
if X="PSDRPH"
QUIT
+6 DO ^DIC
End DoDot:1
+7 KILL DLAYGO
+8 QUIT
+9 ;
TSK SET ZTRTN="DQ^XQSMDCPY"
SET ZTIO=""
SET ZTSAVE("XUSR(")=""
SET ZTDESC="XQSMD Copy User"
SET ZTSAVE("XQUSRPM")=""
SET ZTSAVE("XQUSEC(")=""
SET ZTSAVE("XQUSEK(")=""
DO ^%ZTLOAD
+1 QUIT
