- DICATTD ;SFISC/GFT - SCREEN-MODE 'MODIFY FILE ATTRIBUTES' ;22DEC2015
- ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- 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 as ^DICATTD
- DDA 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 Q:'DICATTA!'$D(^DD(DICATTA)) G FIELD ;If it's multiple...
- .N DICATT2N,DDSPAGE,DDSPARM,DDSSAVE
- .S DDSPARM="S",DDSPAGE=10 D DDS ;...we do Page 10
- .I $G(DDSSAVE) S DICATTA=+$G(DICATT2) ;Go down into multiple unless they aborted with F1-Q
- 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 ;SET UP THE VARIABLES ABOUT THIS FIELD
- 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 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 I DICATT2'["F" D UNED(20) D HLP^DDSUTL("NOTE THAT THIS FIELD'S DEFINITION IS NOT EDITABLE") Q
- D UNED^DDSUTL(20,"DICATT",1,2) ;FREE-TEXT DATA TYPE REACHABLE BUT NOT EDITABLE
- F I=68,70 D UNED^DDSUTL(I,"DICATT4",2.4,1) ;MINIMUM LENGTH & PATTERN MATCH NOT EDITABLE
- S DICATT5="$L(X)>"_$$FL^DIQGDDU(DICATTA,DICATTF)
- 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 ""
- I DICATT2["t" S N=+$P(DICATT2,"t",2)
- E F N=9:-1:5,1:1:4,100 I DICATT2[$E("DNSFWCPVK",N) Q
- E 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 DIR("S")="I Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0))" S:DUZ(0)'="@" DIR("S")=DIR("S")_",Y-9" Q ;IF FIELD IS NEW, ONLY A PROGRAMMER CAN CREATE 'MUMPS' TYPE
- 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,Y-99,Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0))"_$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&(DICATT2'["X")) ;MAX LENGTH & MIN LENGTH if we are doing a FREE TEXT (but not if UNEDITABLE)
- 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
- I X>9 S:$G(DICATT2)="" DDSBR=20.5 D Q
- .D SCREENMN^DICATTUD ;EXTENSIBLE DATA TYPE
- E S DDSSTACK="2."_X Q ;For types 1-8, go to PAGE 2.1 - 2.8
- ;
- CHNG I DICATT5N=DICATT5 K DICATTMN ;No DICATTMN means no change
- D:$D(DICATTMN) PUT^DDSVALF(98,"DICATT",1,DICATTMN) ;HELP-PROMPT prompted
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTD 5585 printed Feb 19, 2025@00:11:51 Page 2
- DICATTD ;SFISC/GFT - SCREEN-MODE 'MODIFY FILE ATTRIBUTES' ;22DEC2015
- +1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 NEW DG,DLAYGO,DIC,DICATTB,DICATTA,DICATTF,DA,DDA
- +8 ;auditing
- KILL ^UTILITY("DICATTD",$JOB),^UTILITY("DDA",$JOB)
- +9 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
- +10 IF '$DATA(DIC)
- DO DIE^DIB
- if '$DATA(DG)
- QUIT
- SET DIC=DG
- LOCK ;N.B.--There is no such Global as ^DICATTD
- SET (DA,DICATTB,DICATTA)=+$PIECE(@(DIC_"0)"),U,2)
- LOCK +^DICATTD(DA):1
- IF '$TEST
- WRITE !!,"SOMEONE ELSE IS EDITING THIS FILE"
- QUIT
- DDA ;DD auditing
- 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 NEW DICATT2N,DDSPAGE,DDSPARM,DDSSAVE
- +2 ;...we do Page 10
- SET DDSPARM="S"
- SET DDSPAGE=10
- DO DDS
- +3 ;Go down into multiple unless they aborted with F1-Q
- IF $GET(DDSSAVE)
- SET DICATTA=+$GET(DICATT2)
- End DoDot:1
- 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 ;SET UP THE VARIABLES ABOUT THIS FIELD
- +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
- 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 IF DICATT2'["F"
- DO UNED(20)
- DO HLP^DDSUTL("NOTE THAT THIS FIELD'S DEFINITION IS NOT EDITABLE")
- QUIT
- +1 ;FREE-TEXT DATA TYPE REACHABLE BUT NOT EDITABLE
- DO UNED^DDSUTL(20,"DICATT",1,2)
- +2 ;MINIMUM LENGTH & PATTERN MATCH NOT EDITABLE
- FOR I=68,70
- DO UNED^DDSUTL(I,"DICATT4",2.4,1)
- +3 SET DICATT5="$L(X)>"_$$FL^DIQGDDU(DICATTA,DICATTF)
- +4 QUIT
- +5 ;
- 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 IF DICATT2["t"
- SET N=+$PIECE(DICATT2,"t",2)
- +3 IF '$TEST
- FOR N=9:-1:5,1:1:4,100
- IF DICATT2[$EXTRACT("DNSFWCPVK",N)
- QUIT
- +4 IF '$TEST
- if N=100
- SET N=4
- +5 QUIT N
- +6 ;
- SCREEN ;
- +1 NEW N
- +2 IF DICATTF=.001
- SET DIR("S")="I Y<4!(Y=7)"
- QUIT
- +3 ;IF FIELD IS NEW, ONLY A PROGRAMMER CAN CREATE 'MUMPS' TYPE
- SET N=$$TYPE
- IF N=""
- SET DIR("S")="I Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0))"
- if DUZ(0)'="@"
- SET DIR("S")=DIR("S")_",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,Y-99,Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0))"_$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 (but not if UNEDITABLE)
- FOR I=68,69
- DO REQ^DDSUTL(I,"DICATT4",2.4,X=4&(DICATT2'["X"))
- +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 IF X>9
- if $GET(DICATT2)=""
- SET DDSBR=20.5
- Begin DoDot:1
- +7 ;EXTENSIBLE DATA TYPE
- DO SCREENMN^DICATTUD
- End DoDot:1
- QUIT
- +8 ;For types 1-8, go to PAGE 2.1 - 2.8
- IF '$TEST
- SET DDSSTACK="2."_X
- QUIT
- +9 ;
- 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 ;