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 ;
