- 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 Mar 13, 2025@21:11:30 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
