DICATTD.m

DICATTD ;SFISC/GFT-SCREEN-MODE 'MODIFY FILE ATTRIBUTES' ;01:41 PM  24 Dec 2001 [ 04/02/2003   8:25 AM ]

 ;;22.0;VA FileMan;**1001**;APR 1, 2003

 ;;22.0;VA FileMan;**1,8,42,89**;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 N DG,DLAYGO,DIC,DICATTB,DICATTA,DICATTF,DA,DDA

 K ^UTILITY("DICATTD",$J),^UTILITY("DDA",$J) ;auditing

 S DLAYGO=1 D D^DICRW Q:Y<0  I $P($G(^DD(+Y,0,"DI")),U)["Y",$P(@(^DIC(+Y,0,"GL")_"0)"),U,4) W !!,$C(7),"DATA DICTIONARY MODIFICATIONS ON ARCHIVE FILES ARE NOT ALLOWED!" Q

 I '$D(DIC) D DIE^DIB Q:'$D(DG)  S DIC=DG

LOCK S (DA,DICATTB,DICATTA)=+$P(@(DIC_"0)"),U,2) L +^DICATTD(DA):1 E  W !!,"SOMEONE ELSE IS EDITING THIS FILE" Q  ;N.B.--There is no such Global

 I $G(^DD(DA,0,"DDA"))["Y" S DDA="" ;DD auditing

ASKLOOP F  K DICATTF D M I $S('$D(DICATTF):1,'$D(^DD(DICATTA)):1,DICATTF-.01:0,1:$P(^DD(DICATTA,DICATTF,0),U,2)["W") Q:DICATTA=DICATTB  S DICATTA=DICATTB

END L -^DICATTD(DICATTB) Q

 ;

M N DICATTVP,DICATTDK,DICATT2N,DICATTMN,DICATTDW,DDSERROR,DICS,DICATTSC

 N DICATT2,DICATT4,DICATT3,DICATT3N,DICATTL,DICATTLN,DICATT5,DICATT5N,DICATT5P

 N O,DIU0,I,J,DR,A,DQ

 N DDSFILE,DIMSG,DUOUT,DTOUT,DDSPAGE,DDSPARM,DDSSAVE,DICATTNW

FIELD W !!! K DIC,O,^UTILITY("DICATTD",$J) ;clean WP buffer

 S DIC(0)="ALEQIZ",DIC="^DD("_DICATTA_"," S:$D(DICS) DIC("S")=DICS

 S DIC("W")="S %=$P(^(0),U,2) I % W $P(""  (multiple)^  (word-processing)"",U,$P(^DD(+%,.01,0),U,2)[""W""+1)"

 I $P(^DD(DICATTA,.01,0),U,2)["W" S DIC(0)="AEQZ",DIC("B")=.01

 D ^DIC K DIC I Y<0 K DICATTF Q  ;look-up

NEWFIELD I $P(Y,U,3) S DICATTNW=1 S:$D(DDA) DDA="N"

 E  S DIU0=DICATTA,O(1)=$P(^(0),U,1,2),O(2)=$G(^(.1)) I $D(DDA) D

 .N A S A=DIU0 S DDA="E" D SV^DICATTA

 S:$D(DDA) DDA(1)=DICATTA

 S DICATTF=+Y

 D GET

MUL I DICATT2 D  S DICATTA=+$G(DICATT2) Q:'DICATTA!'$D(^DD(DICATTA))  G FIELD ;If it's multiple...

 .N DICATT2N,DDSPAGE S DDSPAGE=10 D DDS ;...we do Page 10

DDS K DDSSAVE,DIMSG S DDSPARM="S",DA="",DR="[DICATT]",DDSFILE=1

 D ^DDS ;invoke SCREENMAN!

 Q:'$D(^DD(DICATTA,DICATTF,0))

 S DICATT2N=$P(^(0),U,2) I DICATT2N="",DICATTF-.01 D DELFLD^DICATTDK(DICATTA,DICATTF) Q  ;delete field

VERIFY I '$D(DTOUT),'$D(DIMSG),$D(DDSSAVE) D N^DICATTDE I 'DICATT2N,'$G(DICATTNW),$D(DICATTMN) D DIVR^DIUTL(DICATTA,DICATTF) ;re-verify fields

 Q

 ;

GET ;

 K DICATT2N,DICATT3N,DICATT5N,DICATTLN,DICATT5P

 S DICATT2=$P(^DD(DICATTA,DICATTF,0),U,2),DICATT3=$P(^(0),U,3),DICATT4=$P(^(0),U,4),DICATT5=$P(^(0),U,5,99)

 I $D(^DD(DICATTA,DICATTF,"V")) D GET^DICATTD8 ;Variable-pointer

 Q

 ;

PRE ;PRE-ACTION of first block

 N DIAC,DIFILE

 I DICATTF=.01 D REQ^DDSUTL(1,"DICATT",1,1) ;for now

 I DICATT2["C" D CUNED^DICATTD6(DICATT2)

 I DICATT2["W" F X=18,3,4 D UNED(X)

 S X=1 I DICATTF=.01,DICATTA-DICATTB S X=2

 D UNED^DDSUTL(20.5,"DICATT",1,X) ;2 means REACHABLE but not EDITABLE

 S DIAC="AUDIT",DIFILE=DICATTB D ^DIAC I %-1 D UNED(3) ;check AUDIT ACCESS

 I DUZ(0)'="@" D  ;only programmers can...

 .D UNED(4),UNED(99) ; ..edit AUDIT CONDITION, XECUTABLE HELP, or ...

 .I DICATT2["X" D X,UNED(1),UNED(2) ;edit LABEL of 'X' field,  or ...

 .I $$TYPE=9 D UNED(20) ;edit a MUMPS type

 .F I=4,5 D UNED^DDSUTL(I,"DICATTVP",8,1) ;build VARIABLE-POINTER SCREEN

 .F I=16,17 D UNED^DDSUTL(I,"DICATTM",3,1) ;specify location of

 .F I=76,76.1 D UNED^DDSUTL(I,"DICATTS",4,1) ;...data

 Q:DICATT2'["X"

X D UNED(20) D HLP^DDSUTL("NOTE THAT THIS FIELD'S DEFINITION IS NOT EDITABLE")

 Q

 ;

UNED(I) D UNED^DDSUTL(I,"DICATT",1,1) Q

 ;

NUMBER ;

 D IJ^DIUTL(DICATTA) S Y=" File #"_J(0)

 F I=1:1 Q:'$D(J(I))  S Y=" Sub-File #"_J(I)_" of"_Y

 S Y="Field #"_DICATTF_" in"_Y

 I $P($G(^DD(DICATTA,DICATTF,0)),U,2) S Y="Multiple "_Y

 S Y=$J("",78-$L(Y)\2)_Y Q

 ;

TYPE() ;Figure out TYPE from the second piece of the zero node

 I DICATT2="" Q ""

 N N F N=9:-1:5,1:1:4,100 I DICATT2[$E("DNSFWCPVK",N) Q

 S:N=100 N=4 Q N

 ;

SCREEN ;

 N N

 I DICATTF=.001 S DIR("S")="I Y<4!(Y=7)" Q

 S N=$$TYPE I N="" S:DUZ(0)'="@" DIR("S")="I Y-9" Q

 I N=6 S DIR("S")="I Y=6" Q  ;can't change a COMPUTED FIELD's type

 S DIR("S")="I Y-6,Y-9"_$P(",Y-5",U,N\2-2!'$D(^DD(DICATTA,0,"UP"))!(DICATTF-.01)!($O(^DD(DICATTA,DICATTF))>0))_$S(N=7:",Y-8",N=8:",Y-7",1:"")

 Q

 ;

BRANCH ;given X=TYPE

 F I=31,32 D REQ^DDSUTL(I,"DICATT2",2.2,X=2) ;UPPER BOUND & LOWER BOUND if we are doing a NUMERIC

 F I=68,69 D REQ^DDSUTL(I,"DICATT4",2.4,X=4) ;MAX LENGTH & MIN LENGTH if we are doing a FREE TEXT

 I X=9 G ^DICATTD9

 I DICATT4="",DICATTF>.001 D UNED^DDSUTL(20.5,"DICATT",1,X=5) ;W-P doesn't ask MULTIPLE

 K DICATTSC

 S DDSSTACK="2."_X Q  ;For types 1-8, we have Pages

 ;

CHNG I DICATT5N=DICATT5 K DICATTMN ;No DICATTMN means no change

 D:$D(DICATTMN) PUT^DDSVALF(98,"DICATT",1,DICATTMN) ;HELP-PROMPT prompted

 Q

 ;

DICATTD   ;SFISC/GFT-SCREEN-MODE 'MODIFY FILE ATTRIBUTES' ;01:41 PM  24 Dec 2001 [ 04/02/2003   8:25 AM ]

 +1       ;;22.0;VA FileMan;**1001**;APR 1, 2003

 +2       ;;22.0;VA FileMan;**1,8,42,89**;Mar 30, 1999

 +3       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +4       ;

 +5        NEW DG,DLAYGO,DIC,DICATTB,DICATTA,DICATTF,DA,DDA

 +6       ;auditing

           KILL ^UTILITY("DICATTD",$JOB),^UTILITY("DDA",$JOB)

 +7        SET DLAYGO=1

           DO D^DICRW

           IF Y<0

               QUIT 

           IF $PIECE($GET(^DD(+Y,0,"DI")),U)["Y"

               IF $PIECE(@(^DIC(+Y,0,"GL")_"0)"),U,4)

                   WRITE !!,$CHAR(7),"DATA DICTIONARY MODIFICATIONS ON ARCHIVE FILES ARE NOT ALLOWED!"

                   QUIT 

 +8        IF '$DATA(DIC)

               DO DIE^DIB

               IF '$DATA(DG)

                   QUIT 

               SET DIC=DG

LOCK      ;N.B.--There is no such Global

           SET (DA,DICATTB,DICATTA)=+$PIECE(@(DIC_"0)"),U,2)

           LOCK +^DICATTD(DA):1

          IF '$TEST

               WRITE !!,"SOMEONE ELSE IS EDITING THIS FILE"

               QUIT 

 +1       ;DD auditing

           IF $GET(^DD(DA,0,"DDA"))["Y"

               SET DDA=""

ASKLOOP    FOR 

               KILL DICATTF

               DO M

               IF $SELECT('$DATA(DICATTF):1,'$DATA(^DD(DICATTA)):1,DICATTF-.01:0,1:$PIECE(^DD(DICATTA,DICATTF,0),U,2)["W")

                   IF DICATTA=DICATTB

                       QUIT 

                   SET DICATTA=DICATTB

END        LOCK -^DICATTD(DICATTB)

           QUIT 

 +1       ;

M          NEW DICATTVP,DICATTDK,DICATT2N,DICATTMN,DICATTDW,DDSERROR,DICS,DICATTSC

 +1        NEW DICATT2,DICATT4,DICATT3,DICATT3N,DICATTL,DICATTLN,DICATT5,DICATT5N,DICATT5P

 +2        NEW O,DIU0,I,J,DR,A,DQ

 +3        NEW DDSFILE,DIMSG,DUOUT,DTOUT,DDSPAGE,DDSPARM,DDSSAVE,DICATTNW

FIELD     ;clean WP buffer

           WRITE !!!

           KILL DIC,O,^UTILITY("DICATTD",$JOB)

 +1        SET DIC(0)="ALEQIZ"

           SET DIC="^DD("_DICATTA_","

           IF $DATA(DICS)

               SET DIC("S")=DICS

 +2        SET DIC("W")="S %=$P(^(0),U,2) I % W $P(""  (multiple)^  (word-processing)"",U,$P(^DD(+%,.01,0),U,2)[""W""+1)"

 +3        IF $PIECE(^DD(DICATTA,.01,0),U,2)["W"

               SET DIC(0)="AEQZ"

               SET DIC("B")=.01

 +4       ;look-up

           DO ^DIC

           KILL DIC

           IF Y<0

               KILL DICATTF

               QUIT 

NEWFIELD   IF $PIECE(Y,U,3)

               SET DICATTNW=1

               IF $DATA(DDA)

                   SET DDA="N"

 +1       IF '$TEST

               SET DIU0=DICATTA

               SET O(1)=$PIECE(^(0),U,1,2)

               SET O(2)=$GET(^(.1))

               IF $DATA(DDA)

                   Begin DoDot:1

 +2                    NEW A

                       SET A=DIU0

                       SET DDA="E"

                       DO SV^DICATTA

                   End DoDot:1

 +3        IF $DATA(DDA)

               SET DDA(1)=DICATTA

 +4        SET DICATTF=+Y

 +5        DO GET

MUL       ;If it's multiple...

           IF DICATT2

               Begin DoDot:1

 +1       ;...we do Page 10

                   NEW DICATT2N,DDSPAGE

                   SET DDSPAGE=10

                   DO DDS

               End DoDot:1

               SET DICATTA=+$GET(DICATT2)

               IF 'DICATTA!'$DATA(^DD(DICATTA))

                   QUIT 

               GOTO FIELD

DDS        KILL DDSSAVE,DIMSG

           SET DDSPARM="S"

           SET DA=""

           SET DR="[DICATT]"

           SET DDSFILE=1

 +1       ;invoke SCREENMAN!

           DO ^DDS

 +2        IF '$DATA(^DD(DICATTA,DICATTF,0))

               QUIT 

 +3       ;delete field

           SET DICATT2N=$PIECE(^(0),U,2)

           IF DICATT2N=""

               IF DICATTF-.01

                   DO DELFLD^DICATTDK(DICATTA,DICATTF)

                   QUIT 

VERIFY    ;re-verify fields

           IF '$DATA(DTOUT)

               IF '$DATA(DIMSG)

                   IF $DATA(DDSSAVE)

                       DO N^DICATTDE

                       IF 'DICATT2N

                           IF '$GET(DICATTNW)

                               IF $DATA(DICATTMN)

                                   DO DIVR^DIUTL(DICATTA,DICATTF)

 +1        QUIT 

 +2       ;

GET       ;

 +1        KILL DICATT2N,DICATT3N,DICATT5N,DICATTLN,DICATT5P

 +2        SET DICATT2=$PIECE(^DD(DICATTA,DICATTF,0),U,2)

           SET DICATT3=$PIECE(^(0),U,3)

           SET DICATT4=$PIECE(^(0),U,4)

           SET DICATT5=$PIECE(^(0),U,5,99)

 +3       ;Variable-pointer

           IF $DATA(^DD(DICATTA,DICATTF,"V"))

               DO GET^DICATTD8

 +4        QUIT 

 +5       ;

PRE       ;PRE-ACTION of first block

 +1        NEW DIAC,DIFILE

 +2       ;for now

           IF DICATTF=.01

               DO REQ^DDSUTL(1,"DICATT",1,1)

 +3        IF DICATT2["C"

               DO CUNED^DICATTD6(DICATT2)

 +4        IF DICATT2["W"

               FOR X=18,3,4

                   DO UNED(X)

 +5        SET X=1

           IF DICATTF=.01

               IF DICATTA-DICATTB

                   SET X=2

 +6       ;2 means REACHABLE but not EDITABLE

           DO UNED^DDSUTL(20.5,"DICATT",1,X)

 +7       ;check AUDIT ACCESS

           SET DIAC="AUDIT"

           SET DIFILE=DICATTB

           DO ^DIAC

           IF %-1

               DO UNED(3)

 +8       ;only programmers can...

           IF DUZ(0)'="@"

               Begin DoDot:1

 +9       ; ..edit AUDIT CONDITION, XECUTABLE HELP, or ...

                   DO UNED(4)

                   DO UNED(99)

 +10      ;edit LABEL of 'X' field,  or ...

                   IF DICATT2["X"

                       DO X

                       DO UNED(1)

                       DO UNED(2)

 +11      ;edit a MUMPS type

                   IF $$TYPE=9

                       DO UNED(20)

 +12      ;build VARIABLE-POINTER SCREEN

                   FOR I=4,5

                       DO UNED^DDSUTL(I,"DICATTVP",8,1)

 +13      ;specify location of

                   FOR I=16,17

                       DO UNED^DDSUTL(I,"DICATTM",3,1)

 +14      ;...data

                   FOR I=76,76.1

                       DO UNED^DDSUTL(I,"DICATTS",4,1)

               End DoDot:1

 +15       IF DICATT2'["X"

               QUIT 

X          DO UNED(20)

           DO HLP^DDSUTL("NOTE THAT THIS FIELD'S DEFINITION IS NOT EDITABLE")

 +1        QUIT 

 +2       ;

UNED(I)    DO UNED^DDSUTL(I,"DICATT",1,1)

           QUIT 

 +1       ;

NUMBER    ;

 +1        DO IJ^DIUTL(DICATTA)

           SET Y=" File #"_J(0)

 +2        FOR I=1:1

               IF '$DATA(J(I))

                   QUIT 

               SET Y=" Sub-File #"_J(I)_" of"_Y

 +3        SET Y="Field #"_DICATTF_" in"_Y

 +4        IF $PIECE($GET(^DD(DICATTA,DICATTF,0)),U,2)

               SET Y="Multiple "_Y

 +5        SET Y=$JUSTIFY("",78-$LENGTH(Y)\2)_Y

           QUIT 

 +6       ;

TYPE()    ;Figure out TYPE from the second piece of the zero node

 +1        IF DICATT2=""

               QUIT ""

 +2        NEW N

           FOR N=9:-1:5,1:1:4,100

               IF DICATT2[$EXTRACT("DNSFWCPVK",N)

                   QUIT 

 +3        IF N=100

               SET N=4

           QUIT N

 +4       ;

SCREEN    ;

 +1        NEW N

 +2        IF DICATTF=.001

               SET DIR("S")="I Y<4!(Y=7)"

               QUIT 

 +3        SET N=$$TYPE

           IF N=""

               IF DUZ(0)'="@"

                   SET DIR("S")="I Y-9"

               QUIT 

 +4       ;can't change a COMPUTED FIELD's type

           IF N=6

               SET DIR("S")="I Y=6"

               QUIT 

 +5        SET DIR("S")="I Y-6,Y-9"_$PIECE(",Y-5",U,N\2-2!'$DATA(^DD(DICATTA,0,"UP"))!(DICATTF-.01)!($ORDER(^DD(DICATTA,DICATTF))>0))_$SELECT(N=7:",Y-8",N=8:",Y-7",1:"")

 +6        QUIT 

 +7       ;

BRANCH    ;given X=TYPE

 +1       ;UPPER BOUND & LOWER BOUND if we are doing a NUMERIC

           FOR I=31,32

               DO REQ^DDSUTL(I,"DICATT2",2.2,X=2)

 +2       ;MAX LENGTH & MIN LENGTH if we are doing a FREE TEXT

           FOR I=68,69

               DO REQ^DDSUTL(I,"DICATT4",2.4,X=4)

 +3        IF X=9

               GOTO ^DICATTD9

 +4       ;W-P doesn't ask MULTIPLE

           IF DICATT4=""

               IF DICATTF>.001

                   DO UNED^DDSUTL(20.5,"DICATT",1,X=5)

 +5        KILL DICATTSC

 +6       ;For types 1-8, we have Pages

           SET DDSSTACK="2."_X

           QUIT 

 +7       ;

CHNG      ;No DICATTMN means no change

           IF DICATT5N=DICATT5

               KILL DICATTMN

 +1       ;HELP-PROMPT prompted

           IF $DATA(DICATTMN)

               DO PUT^DDSVALF(98,"DICATT",1,DICATTMN)

 +2        QUIT 

 +3       ;