XUFILE ;SF/XAK-ASSIGN, DEL FILE ACCESS ;4/3/20 3:37pm
;;8.0;KERNEL;**1,707**;Jul 05, 1995;Build 7
;Per VHA Directive 2004-038, this routine should not be modified.
;
D KIL
EN I DUZ(0)'="@",'$D(^VA(200,DUZ,"FOF")) G OUT
D GETU G:X[U!'$D(XUSR) KIL S XUA=2 S:'$D(XUW) XUW="Add "
RD K DIR S DIR(0)="LCOA^1.1::5",DIR("??")="^D H1^XUFILE" ;p707 -include "1.1"
S DIR("?",2)=$P($T(H0),";;",2),DIR("?")=" ",DIR("?",1)=$P($T(H),";;",2)
S %=$P("^DICTIONARY^DELETE^LAYGO^READ^WRITE^AUDIT",U,XUA)
S DIR("A")=$E(" ",1,(10-$L(%)))_XUW_%_" ACCESS to files: "
D ^DIR I $D(DTOUT)!$D(DUOUT) G KIL
X S XUA(XUA)=Y,XUA=XUA+1 G RD:XUA<8 D QUE G KIL:%<2,GO
QUE S %=1 W !,"Would you like to Queue this Job " D YN^DICN Q:%<0 G QHP:'%
I %=1 S ZTRTN="GO^XUFILE",ZTSAVE("XUW")="",ZTSAVE("XUA(")="",ZTSAVE("XUSR(")="",ZTDESC=XUW_"Access to Files",ZTIO="" D ^%ZTLOAD S %=1
Q
GO ;
K ^TMP($J) G DQ:XUW["Copy" S XUW=$S(XUW["Del":"",1:1)
F I=2:1:7 S XUA=XUA(I) F %=1:1 S J=$P(XUA,",",%) Q:J="" S K=$P(J,"-",2),J=$S(J<.19:.2,1:J) S:K="" K=J D L:DUZ(0)'="@",LAT:DUZ(0)="@"
F I=0:0 S I=$O(XUSR(I)) Q:I'>0 S:'$D(^VA(200,I,"FOF",0)) ^(0)="^200.032P^^" D S S DA(1)=I,DIK="^VA(200,"_I_",""FOF""," D IXALL^DIK
I $D(ZTSK) S ZTREQ="@"
KIL K P,X,Y,XUA,DIC,DA,DIK,XUSR,XUW,^TMP($J),DIR,DIRUT,DTOUT,DUOUT
K %,%T,%X,%Y,I,J,K,%DT,B,DCC,DIPT,DISYS,F,FLDS,L,W,X1,ZISI
K %H,DIJ,DP,ZTSK,%ZISI Q
L F J=J-.000001:0 S J=$O(^VA(200,DUZ,"FOF",J)) Q:J'>0!(J>K) I $D(^(J,0))#2,$P(^(0),U,I),$D(^DIC(J,0)) S ^TMP($J,J,1)=J,^(I)=XUW
Q
LAT F J=J-.000001:0 S J=$O(^DIC(J)) Q:J'>0!(J>K) I $D(^DIC(J,0)) S ^TMP($J,J,1)=J,^(I)=XUW
Q
S F J=0:0 S J=$O(^TMP($J,J)) Q:J'>0 S X=$S($D(^VA(200,I,"FOF",J,0)):^(0),1:J) F K=1:0 S K=$O(^TMP($J,J,K)) S:K>0 $P(X,U,K)=^(K) I K'>0 D SD Q
Q
SD I $P(X,U,2,7)'?1.6"^" S ^VA(200,I,"FOF",J,0)=X Q
S DA(1)=I,DA=J,DIK="^VA(200,"_I_",""FOF""," D ^DIK
Q
GETU ;
S DIC="^VA(200,",DIC(0)="AEMQ",DIC("S")="I $S($P(^(0),U,11):$P(^(0),U,11)>DT,1:1),$P(^(0),U,3)]"""""
F I=0:0 D ^DIC Q:Y'>0 S XUSR(+Y)="",DIC("A")="Select ANOTHER USER: "
K DIC Q
;
OUT W !?5,"You do not have the correct access to run this option."
W !?5,"Please contact your site manager for help." Q
;
H ;;Answer with a File Number, a List, or a Range of Files.
;p707 -included "1.1"
H0 ;;For example: 1.1 or 50-59 or 33,42-61,88,220-240.
;
H1 I DUZ(0)'="@" S DIC="^VA(200,DUZ,""FOF"",",DIC(0)="NEQ",DIC("S")="I $P(^(0),U,XUA)"
E S DIC="^DIC(",DIC(0)="EQ",DIC("S")="I Y>.19"_$S(XUA=6:",Y-1,Y-1.1",XUA=5:"",1:",Y>1.1")
S D="B",DZ=X D DQ^DICQ K DIC,DO,DIX,DIY,DZ
Q
QHP W !!?5,"This could take some time to run depending on the number of"
W !?5,"files and users selected. It is definitely best to QUEUE the job." G QUE
;
XUDEL D KIL S XUW="Delete " G EN
COPY ;
S DIC("A")="Select USER whose Access you want to copy: "
S DIC("S")="I $O(^VA(200,Y,""FOF"",0))>0"
S DIC=200,DIC(0)="QEAM" D ^DIC G KIL:Y<0 S XUSR(0)=+Y K DIC
S DIC("A")="Select USER to receive Access: "
D GETU G KIL:$O(XUSR(0))'>0!(X[U) S XUW="Copy " D QUE G KIL:%<2
DQ S %X="^VA(200,"_XUSR(0)_",""FOF"","
F I=0:0 S I=$O(XUSR(I)) Q:I'>0 S %Y="^VA(200,"_I_",""FOF""," D %XY^%RCR S DA(1)=I,DIK=%Y D IXALL^DIK
G KIL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUFILE 3212 printed Dec 13, 2024@02:09:27 Page 2
XUFILE ;SF/XAK-ASSIGN, DEL FILE ACCESS ;4/3/20 3:37pm
+1 ;;8.0;KERNEL;**1,707**;Jul 05, 1995;Build 7
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 DO KIL
EN IF DUZ(0)'="@"
IF '$DATA(^VA(200,DUZ,"FOF"))
GOTO OUT
+1 DO GETU
if X[U!'$DATA(XUSR)
GOTO KIL
SET XUA=2
if '$DATA(XUW)
SET XUW="Add "
RD ;p707 -include "1.1"
KILL DIR
SET DIR(0)="LCOA^1.1::5"
SET DIR("??")="^D H1^XUFILE"
+1 SET DIR("?",2)=$PIECE($TEXT(H0),";;",2)
SET DIR("?")=" "
SET DIR("?",1)=$PIECE($TEXT(H),";;",2)
+2 SET %=$PIECE("^DICTIONARY^DELETE^LAYGO^READ^WRITE^AUDIT",U,XUA)
+3 SET DIR("A")=$EXTRACT(" ",1,(10-$LENGTH(%)))_XUW_%_" ACCESS to files: "
+4 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO KIL
X SET XUA(XUA)=Y
SET XUA=XUA+1
if XUA<8
GOTO RD
DO QUE
if %<2
GOTO KIL
GOTO GO
QUE SET %=1
WRITE !,"Would you like to Queue this Job "
DO YN^DICN
if %<0
QUIT
if '%
GOTO QHP
+1 IF %=1
SET ZTRTN="GO^XUFILE"
SET ZTSAVE("XUW")=""
SET ZTSAVE("XUA(")=""
SET ZTSAVE("XUSR(")=""
SET ZTDESC=XUW_"Access to Files"
SET ZTIO=""
DO ^%ZTLOAD
SET %=1
+2 QUIT
GO ;
+1 KILL ^TMP($JOB)
if XUW["Copy"
GOTO DQ
SET XUW=$SELECT(XUW["Del":"",1:1)
+2 FOR I=2:1:7
SET XUA=XUA(I)
FOR %=1:1
SET J=$PIECE(XUA,",",%)
if J=""
QUIT
SET K=$PIECE(J,"-",2)
SET J=$SELECT(J<.19:.2,1:J)
if K=""
SET K=J
if DUZ(0)'="@"
DO L
if DUZ(0)="@"
DO LAT
+3 FOR I=0:0
SET I=$ORDER(XUSR(I))
if I'>0
QUIT
if '$DATA(^VA(200,I,"FOF",0))
SET ^(0)="^200.032P^^"
DO S
SET DA(1)=I
SET DIK="^VA(200,"_I_",""FOF"","
DO IXALL^DIK
+4 IF $DATA(ZTSK)
SET ZTREQ="@"
KIL KILL P,X,Y,XUA,DIC,DA,DIK,XUSR,XUW,^TMP($JOB),DIR,DIRUT,DTOUT,DUOUT
+1 KILL %,%T,%X,%Y,I,J,K,%DT,B,DCC,DIPT,DISYS,F,FLDS,L,W,X1,ZISI
+2 KILL %H,DIJ,DP,ZTSK,%ZISI
QUIT
L FOR J=J-.000001:0
SET J=$ORDER(^VA(200,DUZ,"FOF",J))
if J'>0!(J>K)
QUIT
IF $DATA(^(J,0))#2
IF $PIECE(^(0),U,I)
IF $DATA(^DIC(J,0))
SET ^TMP($JOB,J,1)=J
SET ^(I)=XUW
+1 QUIT
LAT FOR J=J-.000001:0
SET J=$ORDER(^DIC(J))
if J'>0!(J>K)
QUIT
IF $DATA(^DIC(J,0))
SET ^TMP($JOB,J,1)=J
SET ^(I)=XUW
+1 QUIT
S FOR J=0:0
SET J=$ORDER(^TMP($JOB,J))
if J'>0
QUIT
SET X=$SELECT($DATA(^VA(200,I,"FOF",J,0)):^(0),1:J)
FOR K=1:0
SET K=$ORDER(^TMP($JOB,J,K))
if K>0
SET $PIECE(X,U,K)=^(K)
IF K'>0
DO SD
QUIT
+1 QUIT
SD IF $PIECE(X,U,2,7)'?1.6"^"
SET ^VA(200,I,"FOF",J,0)=X
QUIT
+1 SET DA(1)=I
SET DA=J
SET DIK="^VA(200,"_I_",""FOF"","
DO ^DIK
+2 QUIT
GETU ;
+1 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $S($P(^(0),U,11):$P(^(0),U,11)>DT,1:1),$P(^(0),U,3)]"""""
+2 FOR I=0:0
DO ^DIC
if Y'>0
QUIT
SET XUSR(+Y)=""
SET DIC("A")="Select ANOTHER USER: "
+3 KILL DIC
QUIT
+4 ;
OUT WRITE !?5,"You do not have the correct access to run this option."
+1 WRITE !?5,"Please contact your site manager for help."
QUIT
+2 ;
H ;;Answer with a File Number, a List, or a Range of Files.
+1 ;p707 -included "1.1"
H0 ;;For example: 1.1 or 50-59 or 33,42-61,88,220-240.
+1 ;
H1 IF DUZ(0)'="@"
SET DIC="^VA(200,DUZ,""FOF"","
SET DIC(0)="NEQ"
SET DIC("S")="I $P(^(0),U,XUA)"
+1 IF '$TEST
SET DIC="^DIC("
SET DIC(0)="EQ"
SET DIC("S")="I Y>.19"_$SELECT(XUA=6:",Y-1,Y-1.1",XUA=5:"",1:",Y>1.1")
+2 SET D="B"
SET DZ=X
DO DQ^DICQ
KILL DIC,DO,DIX,DIY,DZ
+3 QUIT
QHP WRITE !!?5,"This could take some time to run depending on the number of"
+1 WRITE !?5,"files and users selected. It is definitely best to QUEUE the job."
GOTO QUE
+2 ;
XUDEL DO KIL
SET XUW="Delete "
GOTO EN
COPY ;
+1 SET DIC("A")="Select USER whose Access you want to copy: "
+2 SET DIC("S")="I $O(^VA(200,Y,""FOF"",0))>0"
+3 SET DIC=200
SET DIC(0)="QEAM"
DO ^DIC
if Y<0
GOTO KIL
SET XUSR(0)=+Y
KILL DIC
+4 SET DIC("A")="Select USER to receive Access: "
+5 DO GETU
if $ORDER(XUSR(0))'>0!(X[U)
GOTO KIL
SET XUW="Copy "
DO QUE
if %<2
GOTO KIL
DQ SET %X="^VA(200,"_XUSR(0)_",""FOF"","
+1 FOR I=0:0
SET I=$ORDER(XUSR(I))
if I'>0
QUIT
SET %Y="^VA(200,"_I_",""FOF"","
DO %XY^%RCR
SET DA(1)=I
SET DIK=%Y
DO IXALL^DIK
+2 GOTO KIL
