DIU2 ;SFISC/XAK/GFT-EDIT FILE ;18SEP2010
;;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.
;
;
;from DIU0
N S X=$P(^DIC(DA,0),U,1),D=@(DIU_"0)"),^(0)=X_U_$P(D,U,2,9) K ^DD(+$P(D,U,2),0,"NM") S ^("NM",X)="" Q:$D(Y)
I DUZ(0)]"" F DR=1:1:6 S D=$P("DD^RD^WR^DEL^LAYGO^AUDIT",U,DR),Y=$S($D(^DIC(DA,0,D)):^(D),1:"") D RW G Q:X=U
S X=$G(^("AUDIT"))
I X]"",DUZ(0)'="@" G OK:$TR(X,DUZ(0))=X
DDA K DIR ;S DIR("A")="DD AUDIT",DIR(0)="YO"
;S:$D(^DD(DA,0,"DDA")) DIR("B")=$S(^("DDA")["Y":"YES",1:"NO")
;S DIR("??")="^W !!?5,""Enter 'Y' (YES) if you want to audit the Data Dictionary changes"",!?5,""for this file."""
;D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT) S ^DD(DA,0,"DDA")=$S(Y=1:"Y",1:"N")
OK S DIU(0)=$P(@(DIU_"0)"),U,2) K DIR
S %=DIU(0)'["O"+1
W !,"ASK 'OK' WHEN LOOKING UP AN ENTRY" D YN^DICN
I %>0 S $P(@(DIU_"0)"),U,2)=$P(DIU(0),"O")_$E("O",%)_$P(DIU(0),"O",2)
I '% W !?5,"Answer YES to cause a lookup into this file to verify the",!?5,"selection by prompting with '...OK? YES//'." G OK
I DUZ(0)="@",%'<0 D ^DIU21
Q K DIR,DIRUT,DTOUT,DUOUT,DIROUT Q
;
CHECKPT ;CALLED BY ^DD(1,.01,"DEL",.5,0)
N M,S,P D POINT^DIDH S M=0,P="PT"
CM S M=$O(^DD(DA,0,P,M)) I M>0 Q:M<DA G CM:M=DA S S=M F S S=$G(^DD(M,0,"UP")) Q:'S G CM:S=DA ;SET $T=0 SWITCH TO SAY THERE'S NO POINTER FILE TO THIS ONE
Q:P="PTC"!$T S P="PTC" G CM ;LOOK AT COMPUTED POINTERS AS WELL AS POINTERS
;
;
K ; CALLED BY ^DD(1,.01,"DEL",1,0)
N DIKREF,DG,DIR
S DIKREF=$$CREF^DILF(DIU),DG=@DIKREF@(0)
I $P($G(^DD(+$P(DG,U,2),0,"DI")),U,2)["Y" W $C(7)," CANNOT DELETE A RESTRICTED"_$S($P($G(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE!" Q
G G:'$O(@DIKREF@(0))
H W $C(7),!,"DO YOU WANT JUST TO DELETE THE "
I $P(DG,U,4)>1 W $P(DG,U,4)," FILE ENTRIES,"
E W "FILE CONTENTS,"
S %=2 W !?9,"& KEEP THE FILE DEFINITION" D YN^DICN
I %=0 W !,"Answer YES if you are just looking for a fast way to get rid of Entries",!! G H
I %<2 D:%=1 Q ;$T left TRUE, so FILE will not be deleted
.N S
.M S=@DIKREF@(0) K @DIKREF
.M @DIKREF@(0)=S ;save back the stuff hanging from zero node
.S $P(@DIKREF@(0),U,3,99)="",^DIC(DA,0,"GL")=DIU
G Q:$G(DIU(0))'["D"
S %=1 I $O(@DIKREF@(0)) W !?3,"IS IT OK TO DELETE THE '"_DIKREF_"' GLOBAL" D YN^DICN
I %=0 W !,"You can abort the deletion process at this point by typing '^'",!,"Answer NO if you want to save ",DIKREF," for redefinition at a later time.",!! G G
S:%=1 DIKLGLBL=DIKREF
I %<1 ;$T true means forget it!
SURE I $D(DDS),$D(DDACT) D
. F D Q:%Y'["?"
.. S %=2 W !,"SURE YOU WANT TO DELETE THE ENTIRE FILE" D YN^DICN
.. I %Y["?" D
... W !,"We are going to ",$S($D(DIKLGLBL):"Delete data associated with File #"_DA,1:"Leave the data associated with File #"_DA)
... W !,"Answer YES if want to continue with the DELETION of the DD, Templates, Forms,"
... W !,"etc. for File #"_DA
I %-1
Q
;
RW W !,$P("DATA DICTIONARY^READ^WRITE^DELETE^LAYGO^AUDIT",U,DR)," ACCESS: " G R:Y="" W Y I DUZ(0)'="@" F X=1:1:$L(Y) Q:DUZ(0)[$E(Y,X) G Q:X=$L(Y)
W "// "
R R X:DTIME S:'$T X=U,DTOUT=1 Q:X=""
I X["@" G V:Y="" W $C(7)," PROTECTION ERASED!" K ^(D) Q
Q:X[U
I X["?" W !,"ENTER CODE(S) TO RESTRICT USER'S ACCESS TO THIS FILE" G RW
V I DUZ(0)'="@" F Z=1:1:$L(X) I DUZ(0)'[$E(X,Z) W $C(7),"??" G RW
S ^(D)=X Q
EN ;
Q:'$D(DIU) G EN^DIU0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIU2 3564 printed Jun 11, 2024@22:29:18 Page 2
DIU2 ;SFISC/XAK/GFT-EDIT FILE ;18SEP2010
+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 ;
+7 ;
+8 ;from DIU0
N SET X=$PIECE(^DIC(DA,0),U,1)
SET D=@(DIU_"0)")
SET ^(0)=X_U_$PIECE(D,U,2,9)
KILL ^DD(+$PIECE(D,U,2),0,"NM")
SET ^("NM",X)=""
if $DATA(Y)
QUIT
+1 IF DUZ(0)]""
FOR DR=1:1:6
SET D=$PIECE("DD^RD^WR^DEL^LAYGO^AUDIT",U,DR)
SET Y=$SELECT($DATA(^DIC(DA,0,D)):^(D),1:"")
DO RW
if X=U
GOTO Q
+2 SET X=$GET(^("AUDIT"))
+3 IF X]""
IF DUZ(0)'="@"
if $TRANSLATE(X,DUZ(0))=X
GOTO OK
DDA ;S DIR("A")="DD AUDIT",DIR(0)="YO"
KILL DIR
+1 ;S:$D(^DD(DA,0,"DDA")) DIR("B")=$S(^("DDA")["Y":"YES",1:"NO")
+2 ;S DIR("??")="^W !!?5,""Enter 'Y' (YES) if you want to audit the Data Dictionary changes"",!?5,""for this file."""
+3 ;D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT) S ^DD(DA,0,"DDA")=$S(Y=1:"Y",1:"N")
OK SET DIU(0)=$PIECE(@(DIU_"0)"),U,2)
KILL DIR
+1 SET %=DIU(0)'["O"+1
+2 WRITE !,"ASK 'OK' WHEN LOOKING UP AN ENTRY"
DO YN^DICN
+3 IF %>0
SET $PIECE(@(DIU_"0)"),U,2)=$PIECE(DIU(0),"O")_$EXTRACT("O",%)_$PIECE(DIU(0),"O",2)
+4 IF '%
WRITE !?5,"Answer YES to cause a lookup into this file to verify the",!?5,"selection by prompting with '...OK? YES//'."
GOTO OK
+5 IF DUZ(0)="@"
IF %'<0
DO ^DIU21
Q KILL DIR,DIRUT,DTOUT,DUOUT,DIROUT
QUIT
+1 ;
CHECKPT ;CALLED BY ^DD(1,.01,"DEL",.5,0)
+1 NEW M,S,P
DO POINT^DIDH
SET M=0
SET P="PT"
CM ;SET $T=0 SWITCH TO SAY THERE'S NO POINTER FILE TO THIS ONE
SET M=$ORDER(^DD(DA,0,P,M))
IF M>0
if M<DA
QUIT
if M=DA
GOTO CM
SET S=M
FOR
SET S=$GET(^DD(M,0,"UP"))
if 'S
QUIT
if S=DA
GOTO CM
+1 ;LOOK AT COMPUTED POINTERS AS WELL AS POINTERS
if P="PTC"!$TEST
QUIT
SET P="PTC"
GOTO CM
+2 ;
+3 ;
K ; CALLED BY ^DD(1,.01,"DEL",1,0)
+1 NEW DIKREF,DG,DIR
+2 SET DIKREF=$$CREF^DILF(DIU)
SET DG=@DIKREF@(0)
+3 IF $PIECE($GET(^DD(+$PIECE(DG,U,2),0,"DI")),U,2)["Y"
WRITE $CHAR(7)," CANNOT DELETE A RESTRICTED"_$SELECT($PIECE($GET(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE!"
QUIT
+4 if '$ORDER(@DIKREF@(0))
GOTO G
H WRITE $CHAR(7),!,"DO YOU WANT JUST TO DELETE THE "
+1 IF $PIECE(DG,U,4)>1
WRITE $PIECE(DG,U,4)," FILE ENTRIES,"
+2 IF '$TEST
WRITE "FILE CONTENTS,"
+3 SET %=2
WRITE !?9,"& KEEP THE FILE DEFINITION"
DO YN^DICN
+4 IF %=0
WRITE !,"Answer YES if you are just looking for a fast way to get rid of Entries",!!
GOTO H
+5 ;$T left TRUE, so FILE will not be deleted
IF %<2
if %=1
Begin DoDot:1
+6 NEW S
+7 MERGE S=@DIKREF@(0)
KILL @DIKREF
+8 ;save back the stuff hanging from zero node
MERGE @DIKREF@(0)=S
+9 SET $PIECE(@DIKREF@(0),U,3,99)=""
SET ^DIC(DA,0,"GL")=DIU
End DoDot:1
QUIT
G if $GET(DIU(0))'["D"
QUIT
+1 SET %=1
IF $ORDER(@DIKREF@(0))
WRITE !?3,"IS IT OK TO DELETE THE '"_DIKREF_"' GLOBAL"
DO YN^DICN
+2 IF %=0
WRITE !,"You can abort the deletion process at this point by typing '^'",!,"Answer NO if you want to save ",DIKREF," for redefinition at a later time.",!!
GOTO G
+3 if %=1
SET DIKLGLBL=DIKREF
+4 ;$T true means forget it!
IF %<1
SURE IF $DATA(DDS)
IF $DATA(DDACT)
Begin DoDot:1
+1 FOR
Begin DoDot:2
+2 SET %=2
WRITE !,"SURE YOU WANT TO DELETE THE ENTIRE FILE"
DO YN^DICN
+3 IF %Y["?"
Begin DoDot:3
+4 WRITE !,"We are going to ",$SELECT($DATA(DIKLGLBL):"Delete data associated with File #"_DA,1:"Leave the data associated with File #"_DA)
+5 WRITE !,"Answer YES if want to continue with the DELETION of the DD, Templates, Forms,"
+6 WRITE !,"etc. for File #"_DA
End DoDot:3
End DoDot:2
if %Y'["?"
QUIT
End DoDot:1
+7 IF %-1
+8 QUIT
+9 ;
RW WRITE !,$PIECE("DATA DICTIONARY^READ^WRITE^DELETE^LAYGO^AUDIT",U,DR)," ACCESS: "
if Y=""
GOTO R
WRITE Y
IF DUZ(0)'="@"
FOR X=1:1:$LENGTH(Y)
if DUZ(0)[$EXTRACT(Y,X)
QUIT
if X=$LENGTH(Y)
GOTO Q
+1 WRITE "// "
R READ X:DTIME
if '$TEST
SET X=U
SET DTOUT=1
if X=""
QUIT
+1 IF X["@"
if Y=""
GOTO V
WRITE $CHAR(7)," PROTECTION ERASED!"
KILL ^(D)
QUIT
+2 if X[U
QUIT
+3 IF X["?"
WRITE !,"ENTER CODE(S) TO RESTRICT USER'S ACCESS TO THIS FILE"
GOTO RW
V IF DUZ(0)'="@"
FOR Z=1:1:$LENGTH(X)
IF DUZ(0)'[$EXTRACT(X,Z)
WRITE $CHAR(7),"??"
GOTO RW
+1 SET ^(D)=X
QUIT
EN ;
+1 if '$DATA(DIU)
QUIT
GOTO EN^DIU0
