DICATT22 ;SFISC/GFT - CREATE A SUBFILE ;23JUN2017
;;22.2;VA FileMan;**2,13**;Jan 05, 2016;Build 4
;;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.
;;GFT;**42,52,89,999,1004,1024**
;
;FINISH MODIFYING A FIELD'S ATTRIBUTES
;
G M:V I P,$D(^DD(J(N-1),P,0)) S I=A_$E("I",$P(^(0),U,2)["I") D P
I O,DA=.01,'N S I=$P(@(I(0)_"0)"),U,2) D P
1 ;
S %=$L(F)+$L(W)+$L(C)+$L(Z) I %>242 W $C(7),!?5,"Field Definition is TOO LONG by ",%-242," characters!" G TYPE^DICATT2
;READY TO SAVE IT!
I O K DIK,^DD(A,DA,101),^(201) S DA(1)=A,DIK="^DD("_A_",",DIK(1)=.2 D EN2^DIK K DIK ;DO THE KILL LOGIC FOR THE OLD SPECIFIER!
S ^DD(A,DA,0)=F_U_Z_U_W_U_C S:$P(Z,U)["K" ^(9)="@" ;SET THE FIELD. IF IT IS 'MUMPS' TYPE, ONLY PROGRAMMERS HAVE WRITE ACCESS
M101 I Z["t" M ^DD(A,DA)=DICATTPM K DICATTPM ;PROPERTIES (101) AND METHODS (102)
D SDIK,I G N^DICATT ;CROSS-REFERENCE FIELD ATTRIBUTES
;
Q W $C(7),!,"NUMBER MUST BE BETWEEN ",A," & ",%+1," AND NOT ALREADY IN USE"
M S %=$P(A,"."),DE=%_"."_+$P(A,".",2)_DA I +DE'=DE!$D(^DD(DE)) F DE=A+.01:.01:%+.7,%+.7:.001:%+.9,%+.9:.0001 Q:DE>A&'$D(^DD(DE))
I DUZ(0)="@" W !,"SUB-DICTIONARY NUMBER: "_DE_"// " R DG:DTIME S:'$T DTOUT=1 G:DG=U!'$T ^DICATT2 S:DG]"" DE=DG G Q:+DE'=DE!(DE<A)
G Q:%+1'>DE!$D(^DD(DE)) S I=DE,^(I,0)=F_" SUB-FIELD^^.01^1",^(0,"UP")=A,^("NM",F)="",%X="^DD("_A_","_DA_")",@%X@(0)=F_"^^^"_W D P
S W=$P(W,";") D SDIK S:+W'=W W=""""_W_""""
S DICATT22=DA,(N,DICL)=N+1,I(N)=W,J(N)=DE,DA=.01,^DD(DE,DA,0)=F_U_Z_"^0;1^"_C,%Y="^DD("_DE_",.01)"
VARPOINT I T["V" D
. N I,FI,FD,P
. S FI=$QS(%X,1),FD=$QS(%X,2)
. S I=0
. F S I=$O(@%X@("V",I)) Q:'I S P=+$G(^(I,0)) K:P ^DD(P,0,"PT",FI,FD)
. M @%Y@("V")=@%X@("V") K @%X@("V")
POINT I T["P" F %=12,12.1 I $D(@%X@(%)) S @%Y@(%)=@%X@(%) K @%X@(%)
I Z["t" M @%Y=DICATTPM K DICATTPM ;PROPERTIES (101) AND METHODS (102) FOR A MULTIPLE FIELD
K %X,%Y
I T'["W" D
.S ^DD(DE,DA,1,0)="^.1",^(1,0)=DE_"^B",DIK=W_",""B"",$E(X,1,30),DA)"
.F %=DICL-1:-1 S DIK=I(%)_$E(",",1,%)_"DA("_(DICL-%)_"),"_DIK I '% S ^(1)="S "_DIK_"=""""",^(2)="K "_DIK S:T["V" ^(3)="Required Index for Variable Pointer" Q
D SDIK,I S DICL=DICL-1
D AUDIT(DA(1),.01,"N") S DA=DICATT22 K DICATT22 ;AUDIT THE NEW .01 FIELD AT THE LOWER LEVEL
G N^DICATT
;
AUDIT(DIFILE,DIFIELD,DITYPE) ;DATA DICTIONARY AUDIT
N DDA,DA,B0,A0
S DDA(1)=DIFILE,DA=DIFIELD,DDA=$G(DITYPE,"E")
D AUDT^DICATTA
Q
;
;
;
I K DR,DG,DB,DQ,DQI,^DD(U,$J),^UTILITY("DIVR",$J) S DG=$P(^DD(J(N),DA,0),U,2,99)
I $P(O,U,2,99)'=DG S:$D(M)#2 ^DD(J(N),DA,3)=M S M(1)=0 ;IF WE HAVE NEW DEFINITION, WE HAVE A NEW HELP-PROMPT
S DIE=DIK,DR=$P(";21",U,'O) ;IF FIELD IS NEW, ASK DESCRIPTION
S DR=$S(DUZ(0)="@"&($P(DG,U)'["t"):"3;4",1:3)_DR ;EXTENSIBLE DATA TYPE WILL HOLD XECUTABLE HELP. OTHERWISE ASK THEM
D
.N I,J,T
.D ^DIE
I T="W" K DE
I $D(M)>9,O S V=DICL,DR=$P(Z,U),Z=$P(Z,U,2) D ;It's not clear that we need these variables set, now we are calling DIVR^DIUTL 12/01
V .N D0 S DI=J(N) D DIPZ^DIU0 Q:$D(DTOUT)!'$D(DIZ) ;NEEDS 'DI' & 'DA'
.D DIVR^DIUTL(A,DA)
K DR,M Q
;
;
P F Y="S","D","P","A","V" S:I[Y I=$P(I,Y)_$P(I,Y,2)_$P(I,Y,3) S:T[Y I=I_Y
S ^(0)=$P(^(0),U)_U_I_U_$P(^(0),U,3,99) Q
;
SDIK N %X
S DA(1)=J(DICL),DIK="^DD("_DA(1)_"," I O K ^DD(DA(1),"RQ",DA)
W !,"...." G IX1^DIK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATT22 3500 printed Dec 13, 2024@02:45:31 Page 2
DICATT22 ;SFISC/GFT - CREATE A SUBFILE ;23JUN2017
+1 ;;22.2;VA FileMan;**2,13**;Jan 05, 2016;Build 4
+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 ;;GFT;**42,52,89,999,1004,1024**
+7 ;
+8 ;FINISH MODIFYING A FIELD'S ATTRIBUTES
+9 ;
+10 if V
GOTO M
IF P
IF $DATA(^DD(J(N-1),P,0))
SET I=A_$EXTRACT("I",$PIECE(^(0),U,2)["I")
DO P
+11 IF O
IF DA=.01
IF 'N
SET I=$PIECE(@(I(0)_"0)"),U,2)
DO P
1 ;
+1 SET %=$LENGTH(F)+$LENGTH(W)+$LENGTH(C)+$LENGTH(Z)
IF %>242
WRITE $CHAR(7),!?5,"Field Definition is TOO LONG by ",%-242," characters!"
GOTO TYPE^DICATT2
+2 ;READY TO SAVE IT!
+3 ;DO THE KILL LOGIC FOR THE OLD SPECIFIER!
IF O
KILL DIK,^DD(A,DA,101),^(201)
SET DA(1)=A
SET DIK="^DD("_A_","
SET DIK(1)=.2
DO EN2^DIK
KILL DIK
+4 ;SET THE FIELD. IF IT IS 'MUMPS' TYPE, ONLY PROGRAMMERS HAVE WRITE ACCESS
SET ^DD(A,DA,0)=F_U_Z_U_W_U_C
if $PIECE(Z,U)["K"
SET ^(9)="@"
M101 ;PROPERTIES (101) AND METHODS (102)
IF Z["t"
MERGE ^DD(A,DA)=DICATTPM
KILL DICATTPM
+1 ;CROSS-REFERENCE FIELD ATTRIBUTES
DO SDIK
DO I
GOTO N^DICATT
+2 ;
Q WRITE $CHAR(7),!,"NUMBER MUST BE BETWEEN ",A," & ",%+1," AND NOT ALREADY IN USE"
M SET %=$PIECE(A,".")
SET DE=%_"."_+$PIECE(A,".",2)_DA
IF +DE'=DE!$DATA(^DD(DE))
FOR DE=A+.01:.01:%+.7,%+.7:.001:%+.9,%+.9:.0001
if DE>A&'$DATA(^DD(DE))
QUIT
+1 IF DUZ(0)="@"
WRITE !,"SUB-DICTIONARY NUMBER: "_DE_"// "
READ DG:DTIME
if '$TEST
SET DTOUT=1
if DG=U!'$TEST
GOTO ^DICATT2
if DG]""
SET DE=DG
if +DE'=DE!(DE<A)
GOTO Q
+2 if %+1'>DE!$DATA(^DD(DE))
GOTO Q
SET I=DE
SET ^(I,0)=F_" SUB-FIELD^^.01^1"
SET ^(0,"UP")=A
SET ^("NM",F)=""
SET %X="^DD("_A_","_DA_")"
SET @%X@(0)=F_"^^^"_W
DO P
+3 SET W=$PIECE(W,";")
DO SDIK
if +W'=W
SET W=""""_W_""""
+4 SET DICATT22=DA
SET (N,DICL)=N+1
SET I(N)=W
SET J(N)=DE
SET DA=.01
SET ^DD(DE,DA,0)=F_U_Z_"^0;1^"_C
SET %Y="^DD("_DE_",.01)"
VARPOINT IF T["V"
Begin DoDot:1
+1 NEW I,FI,FD,P
+2 SET FI=$QSUBSCRIPT(%X,1)
SET FD=$QSUBSCRIPT(%X,2)
+3 SET I=0
+4 FOR
SET I=$ORDER(@%X@("V",I))
if 'I
QUIT
SET P=+$GET(^(I,0))
if P
KILL ^DD(P,0,"PT",FI,FD)
+5 MERGE @%Y@("V")=@%X@("V")
KILL @%X@("V")
End DoDot:1
POINT IF T["P"
FOR %=12,12.1
IF $DATA(@%X@(%))
SET @%Y@(%)=@%X@(%)
KILL @%X@(%)
+1 ;PROPERTIES (101) AND METHODS (102) FOR A MULTIPLE FIELD
IF Z["t"
MERGE @%Y=DICATTPM
KILL DICATTPM
+2 KILL %X,%Y
+3 IF T'["W"
Begin DoDot:1
+4 SET ^DD(DE,DA,1,0)="^.1"
SET ^(1,0)=DE_"^B"
SET DIK=W_",""B"",$E(X,1,30),DA)"
+5 FOR %=DICL-1:-1
SET DIK=I(%)_$EXTRACT(",",1,%)_"DA("_(DICL-%)_"),"_DIK
IF '%
SET ^(1)="S "_DIK_"="""""
SET ^(2)="K "_DIK
if T["V"
SET ^(3)="Required Index for Variable Pointer"
QUIT
End DoDot:1
+6 DO SDIK
DO I
SET DICL=DICL-1
+7 ;AUDIT THE NEW .01 FIELD AT THE LOWER LEVEL
DO AUDIT(DA(1),.01,"N")
SET DA=DICATT22
KILL DICATT22
+8 GOTO N^DICATT
+9 ;
AUDIT(DIFILE,DIFIELD,DITYPE) ;DATA DICTIONARY AUDIT
+1 NEW DDA,DA,B0,A0
+2 SET DDA(1)=DIFILE
SET DA=DIFIELD
SET DDA=$GET(DITYPE,"E")
+3 DO AUDT^DICATTA
+4 QUIT
+5 ;
+6 ;
+7 ;
I KILL DR,DG,DB,DQ,DQI,^DD(U,$JOB),^UTILITY("DIVR",$JOB)
SET DG=$PIECE(^DD(J(N),DA,0),U,2,99)
+1 ;IF WE HAVE NEW DEFINITION, WE HAVE A NEW HELP-PROMPT
IF $PIECE(O,U,2,99)'=DG
if $DATA(M)#2
SET ^DD(J(N),DA,3)=M
SET M(1)=0
+2 ;IF FIELD IS NEW, ASK DESCRIPTION
SET DIE=DIK
SET DR=$PIECE(";21",U,'O)
+3 ;EXTENSIBLE DATA TYPE WILL HOLD XECUTABLE HELP. OTHERWISE ASK THEM
SET DR=$SELECT(DUZ(0)="@"&($PIECE(DG,U)'["t"):"3;4",1:3)_DR
+4 Begin DoDot:1
+5 NEW I,J,T
+6 DO ^DIE
End DoDot:1
+7 IF T="W"
KILL DE
+8 ;It's not clear that we need these variables set, now we are calling DIVR^DIUTL 12/01
IF $DATA(M)>9
IF O
SET V=DICL
SET DR=$PIECE(Z,U)
SET Z=$PIECE(Z,U,2)
Begin DoDot:1
V ;NEEDS 'DI' & 'DA'
NEW D0
SET DI=J(N)
DO DIPZ^DIU0
if $DATA(DTOUT)!'$DATA(DIZ)
QUIT
+1 DO DIVR^DIUTL(A,DA)
End DoDot:1
+2 KILL DR,M
QUIT
+3 ;
+4 ;
P FOR Y="S","D","P","A","V"
if I[Y
SET I=$PIECE(I,Y)_$PIECE(I,Y,2)_$PIECE(I,Y,3)
if T[Y
SET I=I_Y
+1 SET ^(0)=$PIECE(^(0),U)_U_I_U_$PIECE(^(0),U,3,99)
QUIT
+2 ;
SDIK NEW %X
+1 SET DA(1)=J(DICL)
SET DIK="^DD("_DA(1)_","
IF O
KILL ^DD(DA(1),"RQ",DA)
+2 WRITE !,"...."
GOTO IX1^DIK
