XUFILE.m

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 ---XUFILE   3212     printed  Feb 18, 2025@23:35:54                                                                                                                                                                                                      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