DIU3 ;SFISC/GFT-IDENTIFIERS ;2015-01-02 12:12 PM
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
3 ;
S %=2,DA=+Y
I $D(^DD(DI,0,"ID",DA)) W !,"'",$P(Y,U,2),"' is already an Identifier; Want to delete it" D YN^DICN Q:%'=1 K ^DD(DI,0,"ID",DA) D A Q
I $D(^DD(DI,0,"ID","W"_DA)) W !,"'",$P(Y,U,2),"' is already an Identifier; Want to delete it" D YN^DICN Q:%'=1 K ^DD(DI,0,"ID","W"_DA) D A Q
S %=$O(^DD("KEY","AP",DI,"P",0)) I %,$O(^DD("KEY",%,2,"B",+Y,0)) D
. W !!,$C(7)," **NOTE:'"_$P(Y,U,2)_"' is part of the PRIMARY KEY for this file."
. W !," Making it an Identifier is redundant.",! Q
S %=2 W !,"Want to make '",$P(Y,U,2),"' an Identifier" D YN^DICN Q:%-1
;
N DIWID,DIFILENM,X
S DIFILENM=$O(^DD(DI,0,"NM",0)),X="W """""
W !,"Want to require that a value for '",$P(Y,U,2),"' be asked",!," whenever a new '",DIFILENM,"' is created" S %=1 D YN^DICN
Q:%<1 S DIWID=%=2 ;DIWID true means we are only going to display, with a "W" node under ^DD(DI,0,"ID")
W !,"Want to display '"_$P(Y,U,2)_"' value whenever a lookup is done",!," on an entry in the '"_DIFILENM_"' File" S %=1 D YN^DICN
I %-1 G S:%=2&(Y-.001)&'DIWID W $C(7),"??" Q
;Now build the WRITE code
S V=$P(Y(0),U,2),X=$P(Y(0),U,4),D="W",%="(^(0)",%Y=$P(X,";")
I %Y'=0 S D=$S(+%Y=%Y:"",V["S":"""""",1:""""),%="(^("_D_%Y_D_")",D="W"_$S(+Y'=.001:":$D(^("_$E(D)_%Y_$E(D)_"))",1:"")
S %Y=$P(X,";",2),X=$S(+Y=.001:"Y",%Y:"$P"_%_",U,"_%Y_")",1:"$E"_%_","_+$E(%Y,2,9)_","_$P(%Y,",",2)_")")
EGP I V["D" S X="$$NAKED^DIUTL(""$$DATE^DIUTL("_X_")"")" ;**CCO/NI DATE-TYPE IDENTIFIER USES ^DD("DD")!
I V["P" S X="S %I=Y,Y=$S('$D"_%_"):"""",$D(^"_$P(Y(0),U,3)_"+"_X_",0))#2:$P(^(0),U,1),1:""""),C=$P(^DD("_+$P(V,"P",2)_",.01,0),U,2) D Y^DIQ:Y]"""" W "" "",Y,@(""$E(""_DIC_""%I,0),0)"") S Y=%I K %I" G S
I V["V" S X=$P(Y(0),U,4),X="S DIY=$S($D(@(DIC_(+Y)_"","""""_$P(X,";",1)_""""")"")):$P(^("""_$P(X,";",1)_"""),U,"_$P(X,";",2)_"),1:"""") D NAME^DICM2 W "" "",DINAME,@(""$E(""_DIC_""Y,0),0)"")" G S
I V["S" S X="@(""$P($P($C(59)_$S($D(^DD("_DI_","_+Y_",0)):$P(^(0),U,3),1:0)_$E(""_DIC_""Y,0),0),$C(59)_"_X_"_"""":"""",2),$C(59),1)"")"
S X=D_" "" "","_X
S ;'X' at this point is the WRITE code
S Y=+Y I DIWID S Y="W"_Y ;associate it with the field number, or with "W" concatenated with the field numbber
S ^DD(DI,0,"ID",Y)=X,X=DIU I $D(DDA) S A0="IDENTIFIER^",A1="",A2="ID" D IT^DICATTA
I N S V=N,P=$O(^DD(J(N-1),"SB",DI,0)) S:P="" P=-1 S X="^DD(J(N-1),P," ;N means that we are at a lower multiple level
S @("X="_X_"0)"),%=$P(X,U,2) I %'["I" S ^(0)=$P(X,U)_U_%_"I"_U_$P(X,U,3,99)
I N S DIFLD=+Y D WAIT^DICD,0^DIVR S:DE?.E1" " DE=$E(DE,1,$L(DE)-2) X DE K DE,DA,X,W,DIFLD
Q
;
A S A0="IDENTIFIER^",A1="ID",A2="" D IT^DICATTA ;In the audit of the DD, remember that IDENTIFIER was removed.
K A0,A1,A2 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIU3 3077 printed Nov 22, 2024@18:04:33 Page 2
DIU3 ;SFISC/GFT-IDENTIFIERS ;2015-01-02 12:12 PM
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
3 ;
+1 SET %=2
SET DA=+Y
+2 IF $DATA(^DD(DI,0,"ID",DA))
WRITE !,"'",$PIECE(Y,U,2),"' is already an Identifier; Want to delete it"
DO YN^DICN
if %'=1
QUIT
KILL ^DD(DI,0,"ID",DA)
DO A
QUIT
+3 IF $DATA(^DD(DI,0,"ID","W"_DA))
WRITE !,"'",$PIECE(Y,U,2),"' is already an Identifier; Want to delete it"
DO YN^DICN
if %'=1
QUIT
KILL ^DD(DI,0,"ID","W"_DA)
DO A
QUIT
+4 SET %=$ORDER(^DD("KEY","AP",DI,"P",0))
IF %
IF $ORDER(^DD("KEY",%,2,"B",+Y,0))
Begin DoDot:1
+5 WRITE !!,$CHAR(7)," **NOTE:'"_$PIECE(Y,U,2)_"' is part of the PRIMARY KEY for this file."
+6 WRITE !," Making it an Identifier is redundant.",!
QUIT
End DoDot:1
+7 SET %=2
WRITE !,"Want to make '",$PIECE(Y,U,2),"' an Identifier"
DO YN^DICN
if %-1
QUIT
+8 ;
+9 NEW DIWID,DIFILENM,X
+10 SET DIFILENM=$ORDER(^DD(DI,0,"NM",0))
SET X="W """""
+11 WRITE !,"Want to require that a value for '",$PIECE(Y,U,2),"' be asked",!," whenever a new '",DIFILENM,"' is created"
SET %=1
DO YN^DICN
+12 ;DIWID true means we are only going to display, with a "W" node under ^DD(DI,0,"ID")
if %<1
QUIT
SET DIWID=%=2
+13 WRITE !,"Want to display '"_$PIECE(Y,U,2)_"' value whenever a lookup is done",!," on an entry in the '"_DIFILENM_"' File"
SET %=1
DO YN^DICN
+14 IF %-1
if %=2&(Y-.001)&'DIWID
GOTO S
WRITE $CHAR(7),"??"
QUIT
+15 ;Now build the WRITE code
+16 SET V=$PIECE(Y(0),U,2)
SET X=$PIECE(Y(0),U,4)
SET D="W"
SET %="(^(0)"
SET %Y=$PIECE(X,";")
+17 IF %Y'=0
SET D=$SELECT(+%Y=%Y:"",V["S":"""""",1:"""")
SET %="(^("_D_%Y_D_")"
SET D="W"_$SELECT(+Y'=.001:":$D(^("_$EXTRACT(D)_%Y_$EXTRACT(D)_"))",1:"")
+18 SET %Y=$PIECE(X,";",2)
SET X=$SELECT(+Y=.001:"Y",%Y:"$P"_%_",U,"_%Y_")",1:"$E"_%_","_+$EXTRACT(%Y,2,9)_","_$PIECE(%Y,",",2)_")")
EGP ;**CCO/NI DATE-TYPE IDENTIFIER USES ^DD("DD")!
IF V["D"
SET X="$$NAKED^DIUTL(""$$DATE^DIUTL("_X_")"")"
+1 IF V["P"
SET X="S %I=Y,Y=$S('$D"_%_"):"""",$D(^"_$PIECE(Y(0),U,3)_"+"_X_",0))#2:$P(^(0),U,1),1:""""),C=$P(^DD("_+$PIECE(V,"P",2)_",.01,0),U,2) D Y^DIQ:Y]"""" W "" "",Y,@(""$E(""_DIC_""%I,0),0)"") S Y=%I K %I"
GOTO S
+2 IF V["V"
SET X=$PIECE(Y(0),U,4)
SET X="S DIY=$S($D(@(DIC_(+Y)_"","""""_$PIECE(X,";",1)_""""")"")):$P(^("""_$PIECE(X,";",1)_"""),U,"_$PIECE(X,";",2)_"),1:"""") D NAME^DICM2 W "" "",DINAME,@(""$E(""_DIC_""Y,0),0)"")"
GOTO S
+3 IF V["S"
SET X="@(""$P($P($C(59)_$S($D(^DD("_DI_","_+Y_",0)):$P(^(0),U,3),1:0)_$E(""_DIC_""Y,0),0),$C(59)_"_X_"_"""":"""",2),$C(59),1)"")"
+4 SET X=D_" "" "","_X
S ;'X' at this point is the WRITE code
+1 ;associate it with the field number, or with "W" concatenated with the field numbber
SET Y=+Y
IF DIWID
SET Y="W"_Y
+2 SET ^DD(DI,0,"ID",Y)=X
SET X=DIU
IF $DATA(DDA)
SET A0="IDENTIFIER^"
SET A1=""
SET A2="ID"
DO IT^DICATTA
+3 ;N means that we are at a lower multiple level
IF N
SET V=N
SET P=$ORDER(^DD(J(N-1),"SB",DI,0))
if P=""
SET P=-1
SET X="^DD(J(N-1),P,"
+4 SET @("X="_X_"0)")
SET %=$PIECE(X,U,2)
IF %'["I"
SET ^(0)=$PIECE(X,U)_U_%_"I"_U_$PIECE(X,U,3,99)
+5 IF N
SET DIFLD=+Y
DO WAIT^DICD
DO 0^DIVR
if DE?.E1" "
SET DE=$EXTRACT(DE,1,$LENGTH(DE)-2)
XECUTE DE
KILL DE,DA,X,W,DIFLD
+6 QUIT
+7 ;
A ;In the audit of the DD, remember that IDENTIFIER was removed.
SET A0="IDENTIFIER^"
SET A1="ID"
SET A2=""
DO IT^DICATTA
+1 KILL A0,A1,A2
QUIT
