DIU20 ;SFISC/GFT-SCREEN-EDIT FILE ;11JUN2010
;;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 -- DA=FILE NUMBER
N DR
S DDSFILE=1,DR="[DIEDIT]"
D ^DDS
Q
;
PRE ;
I DUZ(0)'="@" D
.F I=9.5,10,11,12 D UNED ;non-programmer cannot put in SCREEN, ACTION, LOOKUP, or CROSS-REF ROUTINE
.F I=2:1:7 D
..S X=$G(^DIC(DA,0,$P("^DD^RD^WR^DEL^LAYGO^AUDIT",U,I)))
..I X]"",$TR(X,DUZ(0))=X D UNED
D:'$D(DISYS) OS^DII I $G(^DD("OS",DISYS,18))="" F I=11,12 D UNED
Q
;
UNED D UNED^DDSUTL(I,"DIEDIT",1,1)
Q
;
ACCVAL(X) ;
I DUZ(0)'="@",$TR(X,DUZ(0))]"" S DDSERROR=1 D HLP^DDSUTL("MUST MATCH YOUR OWN ACCESS CODE") Q
I (X["?") S DDSERROR=1 D HLP^DDSUTL("CANNOT CONTAIN '?'") Q
Q
;
POST ;
N I,NAMENOW,ROOT,SP
MAYBGONE Q:'$G(DA)
S NAMENOW=$P(^DIC(DA,0),U) ;has FILE NAME changed?
S X=$$G(.2) I X="" G KILLFILE
S ROOT=^DIC(DA,0,"GL")_"0)",SP=$P(@ROOT,U,2)
I X'=NAMENOW K I D PUT^DDSVAL(1,DA,.01,X,.I) Q:$D(I)>1 D
.S $P(@ROOT,U)=X
.K ^DD(DA,0,"NM") S ^("NM",X)=""
F I=2:1:7 D ;handle the 6 ACCESS CODEs
.S X=$$G(I)
.S ^DIC(DA,0,$P("^DD^RD^WR^DEL^LAYGO^AUDIT",U,I))=X
;S X=$$G(8) S ^DD(D0,0,"DDA")=$E("NY",X+1)
S X=$$G(9),SP=$TR(SP,"O")_$E("O",X) ;'ASK OK'?'
S X=$$G(9.5),^DD(DA,0,"SCR")=X,SP=$TR(SP,"s") I X="" K ^("SCR")
E S SP=SP_"s"
S $P(@ROOT,U,2)=SP
ACTION S X=$$G(10),^DD(DA,0,"ACT")=X I X="" K ^("ACT")
S X=$$G(11),^DD(DA,0,"DIC")=X I X="" K ^("DIC")
D:$G(^DD(DA,0,"DIK"))]"" QA^DIU21
S X=$$G(12) I X]"" D
.N DMAX,DIR,DICMP,DIKPGM,Y
.S Y=DA,DMAX=^DD("ROU") D EN^DIKZ
Q
;
G(I) Q $$GET^DDSVALF(I,"DIEDIT",1)
;
DIU S DIU=^DIC(DA,0,"GL"),DIU(0)="EDT" Q
;
KILLFILE ;
N DIK,DIC,DQ,DIER,A,DIU
S DIC="^DIC("
D DIU F DIK=0:0 S DIK=$O(^DD(1,.01,"DEL",DIK)) Q:'DIK I $D(^(DIK,0)) X ^(0) I S DDSERROR=1,DDSBR=.2 D PUT^DDSVALF(.2,"DIEDIT",1,NAMENOW) H 3 G Q ;DELETE logic
S A=DA,DIK="^DIC(" D
.N A,DIU D ^DIK ;kill off the File 1 entry
D 61^DIU0
Q Q
;
TEST ;
S DIC=1,DIC(0)="AEQM" D ^DIC Q:Y<0 S DA=+Y G DIU20
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIU20 2273 printed Oct 16, 2024@18:55:07 Page 2
DIU20 ;SFISC/GFT-SCREEN-EDIT FILE ;11JUN2010
+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 -- DA=FILE NUMBER
+9 NEW DR
+10 SET DDSFILE=1
SET DR="[DIEDIT]"
+11 DO ^DDS
+12 QUIT
+13 ;
PRE ;
+1 IF DUZ(0)'="@"
Begin DoDot:1
+2 ;non-programmer cannot put in SCREEN, ACTION, LOOKUP, or CROSS-REF ROUTINE
FOR I=9.5,10,11,12
DO UNED
+3 FOR I=2:1:7
Begin DoDot:2
+4 SET X=$GET(^DIC(DA,0,$PIECE("^DD^RD^WR^DEL^LAYGO^AUDIT",U,I)))
+5 IF X]""
IF $TRANSLATE(X,DUZ(0))=X
DO UNED
End DoDot:2
End DoDot:1
+6 if '$DATA(DISYS)
DO OS^DII
IF $GET(^DD("OS",DISYS,18))=""
FOR I=11,12
DO UNED
+7 QUIT
+8 ;
UNED DO UNED^DDSUTL(I,"DIEDIT",1,1)
+1 QUIT
+2 ;
ACCVAL(X) ;
+1 IF DUZ(0)'="@"
IF $TRANSLATE(X,DUZ(0))]""
SET DDSERROR=1
DO HLP^DDSUTL("MUST MATCH YOUR OWN ACCESS CODE")
QUIT
+2 IF (X["?")
SET DDSERROR=1
DO HLP^DDSUTL("CANNOT CONTAIN '?'")
QUIT
+3 QUIT
+4 ;
POST ;
+1 NEW I,NAMENOW,ROOT,SP
MAYBGONE if '$GET(DA)
QUIT
+1 ;has FILE NAME changed?
SET NAMENOW=$PIECE(^DIC(DA,0),U)
+2 SET X=$$G(.2)
IF X=""
GOTO KILLFILE
+3 SET ROOT=^DIC(DA,0,"GL")_"0)"
SET SP=$PIECE(@ROOT,U,2)
+4 IF X'=NAMENOW
KILL I
DO PUT^DDSVAL(1,DA,.01,X,.I)
if $DATA(I)>1
QUIT
Begin DoDot:1
+5 SET $PIECE(@ROOT,U)=X
+6 KILL ^DD(DA,0,"NM")
SET ^("NM",X)=""
End DoDot:1
+7 ;handle the 6 ACCESS CODEs
FOR I=2:1:7
Begin DoDot:1
+8 SET X=$$G(I)
+9 SET ^DIC(DA,0,$PIECE("^DD^RD^WR^DEL^LAYGO^AUDIT",U,I))=X
End DoDot:1
+10 ;S X=$$G(8) S ^DD(D0,0,"DDA")=$E("NY",X+1)
+11 ;'ASK OK'?'
SET X=$$G(9)
SET SP=$TRANSLATE(SP,"O")_$EXTRACT("O",X)
+12 SET X=$$G(9.5)
SET ^DD(DA,0,"SCR")=X
SET SP=$TRANSLATE(SP,"s")
IF X=""
KILL ^("SCR")
+13 IF '$TEST
SET SP=SP_"s"
+14 SET $PIECE(@ROOT,U,2)=SP
ACTION SET X=$$G(10)
SET ^DD(DA,0,"ACT")=X
IF X=""
KILL ^("ACT")
+1 SET X=$$G(11)
SET ^DD(DA,0,"DIC")=X
IF X=""
KILL ^("DIC")
+2 if $GET(^DD(DA,0,"DIK"))]""
DO QA^DIU21
+3 SET X=$$G(12)
IF X]""
Begin DoDot:1
+4 NEW DMAX,DIR,DICMP,DIKPGM,Y
+5 SET Y=DA
SET DMAX=^DD("ROU")
DO EN^DIKZ
End DoDot:1
+6 QUIT
+7 ;
G(I) QUIT $$GET^DDSVALF(I,"DIEDIT",1)
+1 ;
DIU SET DIU=^DIC(DA,0,"GL")
SET DIU(0)="EDT"
QUIT
+1 ;
KILLFILE ;
+1 NEW DIK,DIC,DQ,DIER,A,DIU
+2 SET DIC="^DIC("
+3 ;DELETE logic
DO DIU
FOR DIK=0:0
SET DIK=$ORDER(^DD(1,.01,"DEL",DIK))
if 'DIK
QUIT
IF $DATA(^(DIK,0))
XECUTE ^(0)
IF $TEST
SET DDSERROR=1
SET DDSBR=.2
DO PUT^DDSVALF(.2,"DIEDIT",1,NAMENOW)
HANG 3
GOTO Q
+4 SET A=DA
SET DIK="^DIC("
Begin DoDot:1
+5 ;kill off the File 1 entry
NEW A,DIU
DO ^DIK
End DoDot:1
+6 DO 61^DIU0
Q QUIT
+1 ;
TEST ;
+1 SET DIC=1
SET DIC(0)="AEQM"
DO ^DIC
if Y<0
QUIT
SET DA=+Y
GOTO DIU20
