- 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 Mar 13, 2025@21:59:26 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
