- DICATT ;SFISC/GFT,XAK - MODIFY FILE ATTR ;25MAY2012
- ;;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.
- I $D(DIAX) S %=2
- E S %=$$SCREEN^DIBT("^D SCREENQ^DICATT") Q:%=U S %=2-%
- G ^DICATTD:%=1 Q:%<2 ;JUMP TO THE SCREENMAN EDITOR
- 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
- S:$D(DIAX) DIAXDIC=+$P(@(DIC_"0)"),U,2)
- EN ;
- K I S Q="""",I(0)=DIC,B=+$P(@(DIC_"0)"),U,2),S=";"
- B ;
- K DA,J,DIU0,DDA S A=B,DICL=0,J(0)=B,DDA=""
- M ;
- I $G(Z)["W",A-B G B
- W !!! K O,DQ,DIC,DIE,DG,M G Q^DIB:$D(DTOUT)
- S O=1,E=0,DIC(0)="ALEQIZ",DIC="^DD("_A_"," 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(A,.01,0),U,2)["W" S DIC(0)="AEQZ",DIC("B")=.01
- E I $D(DA),$D(^DD(A,DA,0)),'$P(^(0),U,2),$P(^(0),U,4)'?.P S E=DA
- D ^DIC S:$P(Y,U,3) DDA="N" I Y<0 G B:A-B,Q^DICATT2 ;IF NO FIELD IS CHOSEN, POP UP. IF AT TOP LEVEL OF FILE, QUIT OUT
- SV I '$P(Y,U,3) S DIU0=A,O(1)=$P(^DD(A,+Y,0),U,1,2),O(2)=$S($D(^(.1)):$P(^(.1),U),1:""),DDA="E" D SV^DICATTA
- S DDA(1)=A
- S DIAC="AUDIT",DIFILE=A D ^DIAC S O=+% K DIAC,DIFILE
- SKP S (D0,DA)=+Y,DA(1)=A,DIE=DIC,M=Y(0),T=$P(M,U,2) S:T["C"!(T["W") O=0
- S DR=$P(".01:.1;",U,DUZ(0)="@"!'$F(T,"X"))_$P("1.1;",U,T'["C")_$S(DUZ(0)="@"&(T'["C"):"1.2;",1:"")_$S(T["C":"8;",1:"8:9;10:")_"11;20:29"
- S O=$S($P(Y,U,3):0,1:1_U_$P(M,U,2,99)),F=$P(M,U) K DIC,DQI
- S X=0 F S X=$O(^DD(A,DA,1,X)) Q:X'>0 I +^(X,0)=B,$P(^(0),B,2)?1"^"1.A S DQI=$P(^(0),U,2)
- G MULTIPLE:T
- I O D Q:$D(DTOUT) I '$D(DA) G N:$P(O,U,4)?.P,^DICATT4 ;IF DELETING THE FIELD, CLEANUP IN 'DICATT4' UNLESS IT WAS A COMPUTED FIELD
- .N DICASPEC S DICASPEC=$P(^DD(A,DA,0),U,2)
- .D DIE ;EDIT THE CHARACTERISTICS OF A SINGLE-VALUED FIELD
- .I '$D(DA) S DDA="D" Q
- .I DICASPEC'=$P(^DD(A,DA,0),U,2),$G(^DD(B,0,"DIK"))]"" D
- ..N A D EN2^DIKZ(B,"",^("DIK")) ;Recompile CROSS-REFS if auditing changes
- G TYPE^DICATT2
- ;
- MULTIPLE ;EDIT THE CHARACTERISTICS OF A MULTIPLE FIELD
- S DR=".01;8;9;10:11;20:29" D DIE I '$D(DA) S DDA="D" S DQ(+T)=0 G NEW^DICATT4
- S X=$P($P(M,U,4),";"),M=^DD(A,DA,0),E=$P(M,U),A=+T,DICL=DICL+1,J(DICL)=A,Y=$E(Q,+X'=X),I(DICL)=Y_X_Y I E'=F S ^(0)=E_" SUB-FIELD^"_$P(^DD(A,0),U,2,9) K ^(0,"NM") S ^("NM",E)=""
- G 5:$P(M,U,2)["W",N ;NOW WE ARE DOWN TO LOWER-LEVEL MULTIPLE
- ;
- ;
- E S DE=^DD(A,E,0) W $P(DE,U) Q
- ;
- P S DI=DIU0 D:$D(O(1))
- .I '$D(DA) S DA=D0 D DIPZ^DIU0 Q
- .I $D(^DD(DI,DA,0)),O(1)'=$P(^(0),U,1,2) D DIPZ^DIU0 Q
- .I $D(^(.1)),O(2)'=$P(^(.1),U) D DIPZ^DIU0 Q
- K DIU0 Q
- ;
- N ;COME BACK HERE FROM DICATT22
- D:DDA]"" AUDIT^DICATT22(DDA(1),D0,DDA) ;FINISH THIS FIELD, GO BACK TO RE-ASK ANOTHER FIELD
- D:$D(DIU0) P S DIZZ=$S(('O&$D(DIZ)):DIZ,1:$P(O,U,2,3)) G M
- ;
- X W $C(7)," '",F,"' DELETED!" S DDA=$S(DDA="":"D",1:"")
- S DIK="^DD(A,",DA(1)=A D ^DIK G N
- ;
- CHECK G:$P(^DD(A,DA,0),U,2)']"" X:$D(DTOUT) G NO^DICATT2
- ;
- DIE ;
- N I,J,DICATTED,A,B
- S DICATTED=1 D ^DIE ;'DA' VARIABLE IS KILLED IF USER KILLS THE FIELD BY DELETING THE LABEL
- Q
- ;
- ;
- ;
- 0 S C=$P(O,U,5,99) I N>10 G ^DICATTUD ;COME HERE FROM 2 PLACES IN DICATT2.
- G @N ;GO DEPENDS ON DATA TYPE (1-9 or FILE .81)
- 1 ;
- 2 G ^DICATT0
- 3 ;
- 4 G ^DICATT6
- 5 S W="0;1",(Z,DIZ)="W^",C="Q",V=1,L=1 G ^DICATT2:O,SUB^DICATT1
- 6 G ^DICATT3 ;COMPUTED
- 7 G ^DICATT5
- 8 G VP^DICATT4
- 9 S (Z,DIZ)="K^",V=0,C="K:$L(X)>245 X D:$D(X) ^DIM",L=245
- S:$P(^DD(A,DA,0),U,4)]"" W=$P(^(0),U,4) G ^DICATT2:O,SUB^DICATT1
- ;
- SCREENQ ;
- W !,"'YES' will invoke the ScreenMan editor.",!,"The same questions are asked in both screen & scrolling mode."
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATT 3974 printed Jan 18, 2025@03:46:26 Page 2
- DICATT ;SFISC/GFT,XAK - MODIFY FILE ATTR ;25MAY2012
- +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 IF $DATA(DIAX)
- SET %=2
- +7 IF '$TEST
- SET %=$$SCREEN^DIBT("^D SCREENQ^DICATT")
- if %=U
- QUIT
- SET %=2-%
- +8 ;JUMP TO THE SCREENMAN EDITOR
- if %=1
- GOTO ^DICATTD
- if %<2
- QUIT
- +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
- +11 if $DATA(DIAX)
- SET DIAXDIC=+$PIECE(@(DIC_"0)"),U,2)
- EN ;
- +1 KILL I
- SET Q=""""
- SET I(0)=DIC
- SET B=+$PIECE(@(DIC_"0)"),U,2)
- SET S=";"
- B ;
- +1 KILL DA,J,DIU0,DDA
- SET A=B
- SET DICL=0
- SET J(0)=B
- SET DDA=""
- M ;
- +1 IF $GET(Z)["W"
- IF A-B
- GOTO B
- +2 WRITE !!!
- KILL O,DQ,DIC,DIE,DG,M
- if $DATA(DTOUT)
- GOTO Q^DIB
- +3 SET O=1
- SET E=0
- SET DIC(0)="ALEQIZ"
- SET DIC="^DD("_A_","
- if $DATA(DICS)
- SET DIC("S")=DICS
- +4 SET DIC("W")="S %=$P(^(0),U,2) I % W $P("" (multiple)^ (word-processing)"",U,$P(^DD(+%,.01,0),U,2)[""W""+1)"
- +5 IF $PIECE(^DD(A,.01,0),U,2)["W"
- SET DIC(0)="AEQZ"
- SET DIC("B")=.01
- +6 IF '$TEST
- IF $DATA(DA)
- IF $DATA(^DD(A,DA,0))
- IF '$PIECE(^(0),U,2)
- IF $PIECE(^(0),U,4)'?.P
- SET E=DA
- +7 ;IF NO FIELD IS CHOSEN, POP UP. IF AT TOP LEVEL OF FILE, QUIT OUT
- DO ^DIC
- if $PIECE(Y,U,3)
- SET DDA="N"
- IF Y<0
- if A-B
- GOTO B
- GOTO Q^DICATT2
- SV IF '$PIECE(Y,U,3)
- SET DIU0=A
- SET O(1)=$PIECE(^DD(A,+Y,0),U,1,2)
- SET O(2)=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:"")
- SET DDA="E"
- DO SV^DICATTA
- +1 SET DDA(1)=A
- +2 SET DIAC="AUDIT"
- SET DIFILE=A
- DO ^DIAC
- SET O=+%
- KILL DIAC,DIFILE
- SKP SET (D0,DA)=+Y
- SET DA(1)=A
- SET DIE=DIC
- SET M=Y(0)
- SET T=$PIECE(M,U,2)
- if T["C"!(T["W")
- SET O=0
- +1 SET DR=$PIECE(".01:.1;",U,DUZ(0)="@"!'$FIND(T,"X"))_$PIECE("1.1;",U,T'["C")_$SELECT(DUZ(0)="@"&(T'["C"):"1.2;",1:"")_$SELECT(T["C":"8;",1:"8:9;10:")_"11;20:29"
- +2 SET O=$SELECT($PIECE(Y,U,3):0,1:1_U_$PIECE(M,U,2,99))
- SET F=$PIECE(M,U)
- KILL DIC,DQI
- +3 SET X=0
- FOR
- SET X=$ORDER(^DD(A,DA,1,X))
- if X'>0
- QUIT
- IF +^(X,0)=B
- IF $PIECE(^(0),B,2)?1"^"1.A
- SET DQI=$PIECE(^(0),U,2)
- +4 if T
- GOTO MULTIPLE
- +5 ;IF DELETING THE FIELD, CLEANUP IN 'DICATT4' UNLESS IT WAS A COMPUTED FIELD
- IF O
- Begin DoDot:1
- +6 NEW DICASPEC
- SET DICASPEC=$PIECE(^DD(A,DA,0),U,2)
- +7 ;EDIT THE CHARACTERISTICS OF A SINGLE-VALUED FIELD
- DO DIE
- +8 IF '$DATA(DA)
- SET DDA="D"
- QUIT
- +9 IF DICASPEC'=$PIECE(^DD(A,DA,0),U,2)
- IF $GET(^DD(B,0,"DIK"))]""
- Begin DoDot:2
- +10 ;Recompile CROSS-REFS if auditing changes
- NEW A
- DO EN2^DIKZ(B,"",^("DIK"))
- End DoDot:2
- End DoDot:1
- if $DATA(DTOUT)
- QUIT
- IF '$DATA(DA)
- if $PIECE(O,U,4)?.P
- GOTO N
- GOTO ^DICATT4
- +11 GOTO TYPE^DICATT2
- +12 ;
- MULTIPLE ;EDIT THE CHARACTERISTICS OF A MULTIPLE FIELD
- +1 SET DR=".01;8;9;10:11;20:29"
- DO DIE
- IF '$DATA(DA)
- SET DDA="D"
- SET DQ(+T)=0
- GOTO NEW^DICATT4
- +2 SET X=$PIECE($PIECE(M,U,4),";")
- SET M=^DD(A,DA,0)
- SET E=$PIECE(M,U)
- SET A=+T
- SET DICL=DICL+1
- SET J(DICL)=A
- SET Y=$EXTRACT(Q,+X'=X)
- SET I(DICL)=Y_X_Y
- IF E'=F
- SET ^(0)=E_" SUB-FIELD^"_$PIECE(^DD(A,0),U,2,9)
- KILL ^(0,"NM")
- SET ^("NM",E)=""
- +3 ;NOW WE ARE DOWN TO LOWER-LEVEL MULTIPLE
- if $PIECE(M,U,2)["W"
- GOTO 5
- GOTO N
- +4 ;
- +5 ;
- E SET DE=^DD(A,E,0)
- WRITE $PIECE(DE,U)
- QUIT
- +1 ;
- P SET DI=DIU0
- if $DATA(O(1))
- Begin DoDot:1
- +1 IF '$DATA(DA)
- SET DA=D0
- DO DIPZ^DIU0
- QUIT
- +2 IF $DATA(^DD(DI,DA,0))
- IF O(1)'=$PIECE(^(0),U,1,2)
- DO DIPZ^DIU0
- QUIT
- +3 IF $DATA(^(.1))
- IF O(2)'=$PIECE(^(.1),U)
- DO DIPZ^DIU0
- QUIT
- End DoDot:1
- +4 KILL DIU0
- QUIT
- +5 ;
- N ;COME BACK HERE FROM DICATT22
- +1 ;FINISH THIS FIELD, GO BACK TO RE-ASK ANOTHER FIELD
- if DDA]""
- DO AUDIT^DICATT22(DDA(1),D0,DDA)
- +2 if $DATA(DIU0)
- DO P
- SET DIZZ=$SELECT(('O&$DATA(DIZ)):DIZ,1:$PIECE(O,U,2,3))
- GOTO M
- +3 ;
- X WRITE $CHAR(7)," '",F,"' DELETED!"
- SET DDA=$SELECT(DDA="":"D",1:"")
- +1 SET DIK="^DD(A,"
- SET DA(1)=A
- DO ^DIK
- GOTO N
- +2 ;
- CHECK if $PIECE(^DD(A,DA,0),U,2)']""
- if $DATA(DTOUT)
- GOTO X
- GOTO NO^DICATT2
- +1 ;
- DIE ;
- +1 NEW I,J,DICATTED,A,B
- +2 ;'DA' VARIABLE IS KILLED IF USER KILLS THE FIELD BY DELETING THE LABEL
- SET DICATTED=1
- DO ^DIE
- +3 QUIT
- +4 ;
- +5 ;
- +6 ;
- 0 ;COME HERE FROM 2 PLACES IN DICATT2.
- SET C=$PIECE(O,U,5,99)
- IF N>10
- GOTO ^DICATTUD
- +1 ;GO DEPENDS ON DATA TYPE (1-9 or FILE .81)
- GOTO @N
- 1 ;
- 2 GOTO ^DICATT0
- 3 ;
- 4 GOTO ^DICATT6
- 5 SET W="0;1"
- SET (Z,DIZ)="W^"
- SET C="Q"
- SET V=1
- SET L=1
- if O
- GOTO ^DICATT2
- GOTO SUB^DICATT1
- 6 ;COMPUTED
- GOTO ^DICATT3
- 7 GOTO ^DICATT5
- 8 GOTO VP^DICATT4
- 9 SET (Z,DIZ)="K^"
- SET V=0
- SET C="K:$L(X)>245 X D:$D(X) ^DIM"
- SET L=245
- +1 if $PIECE(^DD(A,DA,0),U,4)]""
- SET W=$PIECE(^(0),U,4)
- if O
- GOTO ^DICATT2
- GOTO SUB^DICATT1
- +2 ;
- SCREENQ ;
- +1 WRITE !,"'YES' will invoke the ScreenMan editor.",!,"The same questions are asked in both screen & scrolling mode."