DIU0 ;SFISC/XAK-EDIT/DELETE A FILE ;12NOV2008
;;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.
;
DIPZ ;
D PZ,DIEZ Q
PZ ;Recompile PRINT Template routines
S DIU2=$G(J(0)) N DIC,C,F,I,J,M,O,Q,S,T,V,W,Y
F DIU0=0:0 S DIU0=$O(^DIPT("AF",DI,DA,DIU0)) Q:DIU0'>0 K ^(DIU0),^DIPT(DIU0,"ROU") S DMAX=^DD("ROU"),X=^DIPT(DIU0,"ROUOLD"),Y=DIU0,DIU1=DI D EN^DIPZ S DI=DIU1
S J(0)=DIU2 D DT Q
;
IN(DI,DA) ;Recompile INput Templates containing Field DA, File DI
N J,I D IJ^DIUTL(DI)
DIEZ N DL,DH,DQ,DIE,DIC,DNM,DR,M,T,F,Q,Y
F DIU0=0:0 S DIU0=$O(^DIE("AF",DI,DA,DIU0)) Q:DIU0'>0 D
. S X=$G(^DIE(DIU0,"ROUOLD"))
. I X'?1(1A,1"%").7AN D I X'?1(1A,1"%").7AN D UNC^DIEZ(DIU0) Q
.. S X=$P($G(^DIE(DIU0,"ROU")),U,2)
. K ^DIE("AF",DI,DA,DIU0),^DIE(DIU0,"ROU")
. S DMAX=^DD("ROU"),Y=DIU0,DIU1=DI
. D EN^DIEZ S DI=DIU1
DT I $D(^DD(DI,DA)) S:$P($G(^DIC(J(0),"%A")),U,2)-DT ^DD(DI,DA,"DT")=DT
K DIU0,DIU1,DIU2 W ! Q
;
EN ;
I DIU,DIU(0)["S" G SUB
I DIU,$D(^DIC(DIU,0,"GL")) S DIU=^("GL")
G Q:"(,"'[$E($RE(DIU))!DIU S DIK="^DIC(",DG=$G(@(DIU_"0)")),(A,DA)=+$P(DG,U,2) G Q:'A
N DIKLGLBL I DIU(0)["D" S DIKLGLBL=$$CREF^DILF(DIU)
D ^DIK G 61
6 ;
N DIKLGLBL
S DA=DI,%=$$SCREEN^DIBT("^D SCREENQ^DICATT") Q:%=U G SCROLL:'%
G ^DIU20
;
SCROLL S DR=".01:10;"_$P(20,U,$S($D(^DIC(200,0)):^(0)["NEW PERSON",$D(^DIC(3,0)):^(0)["USER"!(^(0)["EMPLOY"),1:0))
S DIE=1,(A,DA)=DI,DIER=1 D K DIER G N^DIU2:$D(DA)
.N A D ^DIE
61 ; delete a FILE!
S DQ(A)=0 K ^DIA(A) I $G(DIKLGLBL)]"" K @DIKLGLBL
63 W:DIU(0)["E" !?3,"Deleting the DATA DICTIONARY..." D KDD^DICATT4
Q:DIU(0)["S" G Q:DIU(0)'["T"
F DIK="^DIE(","^DIPT(","^DIBT(" K @(DIK_"""F""_A)") W:DIU(0)["E" !?3,"Deleting the "_$P(^(0),U)_"S..." S DA=.9 F S DA=$O(@(DIK_"DA)")) Q:DA'>0 I $D(^(DA,0)) S %=$P(^(0),U,4) I %=""!'$D(^DD(+%)) W:DIU(0)["E" "." D ^DIK
D FORM^DDSDEL(A,DIU(0)["E")
Q K A,DA,DG,DIK,DQ Q
;
SUB G Q:'$D(^DD(DIU,0,"UP")) S DA(1)=^("UP"),DQ(DIU)=0
I DIU(0)'["D" S A=DA(1) D 63 S A=DIU G SE
S D0=DIU,S=";",Q=""""
F I=1:1 Q:'$D(^DD(DIU,0,"UP")) S A=^("UP"),%=$O(^DD(A,"SB",DIU,0)) Q:%="" Q:'$D(^DD(A,%,0))#2 S %(I)=$P($P(^(0),U,4),S),DIU=A S:+%(I)'=%(I) %(I)=Q_%(I)_Q I I=1 S (O,M)=^(0)
S DICL=I-2 F I=1:1:DICL+1 S I(I)=%(DICL-I+2)
S I(0)=^DIC(DIU,0,"GL") K %
D
. N DIU0TOP,DIU0SFIL S DIU0TOP=A,DIU0SFIL=D0
. N A,DA,D0,DICL,DIU,DQ,I,O,M,S,Q
. D INDEX^DIKC(DIU0TOP,"","","","KiRW"_DIU0SFIL)
D 63 S A=D0 D EN^DICATT4
SE S DIK="^DD("_DA(1)_",",DA=$O(^DD(DA(1),"SB",A,0)) D ^DIK:DA
K D0,DICL,E,I,M,O,Q,S,T,X,Y G Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIU0 2794 printed Jan 18, 2025@03:55:31 Page 2
DIU0 ;SFISC/XAK-EDIT/DELETE A FILE ;12NOV2008
+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 ;
DIPZ ;
+1 DO PZ
DO DIEZ
QUIT
PZ ;Recompile PRINT Template routines
+1 SET DIU2=$GET(J(0))
NEW DIC,C,F,I,J,M,O,Q,S,T,V,W,Y
+2 FOR DIU0=0:0
SET DIU0=$ORDER(^DIPT("AF",DI,DA,DIU0))
if DIU0'>0
QUIT
KILL ^(DIU0),^DIPT(DIU0,"ROU")
SET DMAX=^DD("ROU")
SET X=^DIPT(DIU0,"ROUOLD")
SET Y=DIU0
SET DIU1=DI
DO EN^DIPZ
SET DI=DIU1
+3 SET J(0)=DIU2
DO DT
QUIT
+4 ;
IN(DI,DA) ;Recompile INput Templates containing Field DA, File DI
+1 NEW J,I
DO IJ^DIUTL(DI)
DIEZ NEW DL,DH,DQ,DIE,DIC,DNM,DR,M,T,F,Q,Y
+1 FOR DIU0=0:0
SET DIU0=$ORDER(^DIE("AF",DI,DA,DIU0))
if DIU0'>0
QUIT
Begin DoDot:1
+2 SET X=$GET(^DIE(DIU0,"ROUOLD"))
+3 IF X'?1(1A,1"%").7AN
Begin DoDot:2
+4 SET X=$PIECE($GET(^DIE(DIU0,"ROU")),U,2)
End DoDot:2
IF X'?1(1A,1"%").7AN
DO UNC^DIEZ(DIU0)
QUIT
+5 KILL ^DIE("AF",DI,DA,DIU0),^DIE(DIU0,"ROU")
+6 SET DMAX=^DD("ROU")
SET Y=DIU0
SET DIU1=DI
+7 DO EN^DIEZ
SET DI=DIU1
End DoDot:1
DT IF $DATA(^DD(DI,DA))
if $PIECE($GET(^DIC(J(0),"%A")),U,2)-DT
SET ^DD(DI,DA,"DT")=DT
+1 KILL DIU0,DIU1,DIU2
WRITE !
QUIT
+2 ;
EN ;
+1 IF DIU
IF DIU(0)["S"
GOTO SUB
+2 IF DIU
IF $DATA(^DIC(DIU,0,"GL"))
SET DIU=^("GL")
+3 if "(,"'[$EXTRACT($REVERSE(DIU))!DIU
GOTO Q
SET DIK="^DIC("
SET DG=$GET(@(DIU_"0)"))
SET (A,DA)=+$PIECE(DG,U,2)
if 'A
GOTO Q
+4 NEW DIKLGLBL
IF DIU(0)["D"
SET DIKLGLBL=$$CREF^DILF(DIU)
+5 DO ^DIK
GOTO 61
6 ;
+1 NEW DIKLGLBL
+2 SET DA=DI
SET %=$$SCREEN^DIBT("^D SCREENQ^DICATT")
if %=U
QUIT
if '%
GOTO SCROLL
+3 GOTO ^DIU20
+4 ;
SCROLL SET DR=".01:10;"_$PIECE(20,U,$SELECT($DATA(^DIC(200,0)):^(0)["NEW PERSON",$DATA(^DIC(3,0)):^(0)["USER"!(^(0)["EMPLOY"),1:0))
+1 SET DIE=1
SET (A,DA)=DI
SET DIER=1
Begin DoDot:1
+2 NEW A
DO ^DIE
End DoDot:1
KILL DIER
if $DATA(DA)
GOTO N^DIU2
61 ; delete a FILE!
+1 SET DQ(A)=0
KILL ^DIA(A)
IF $GET(DIKLGLBL)]""
KILL @DIKLGLBL
63 if DIU(0)["E"
WRITE !?3,"Deleting the DATA DICTIONARY..."
DO KDD^DICATT4
+1 if DIU(0)["S"
QUIT
if DIU(0)'["T"
GOTO Q
+2 FOR DIK="^DIE(","^DIPT(","^DIBT("
KILL @(DIK_"""F""_A)")
if DIU(0)["E"
WRITE !?3,"Deleting the "_$PIECE(^(0),U)_"S..."
SET DA=.9
FOR
SET DA=$ORDER(@(DIK_"DA)"))
if DA'>0
QUIT
IF $DATA(^(DA,0))
SET %=$PIECE(^(0),U,4)
IF %=""!'$DATA(^DD(+%))
if DIU(0)["E"
WRITE "."
DO ^DIK
+3 DO FORM^DDSDEL(A,DIU(0)["E")
Q KILL A,DA,DG,DIK,DQ
QUIT
+1 ;
SUB if '$DATA(^DD(DIU,0,"UP"))
GOTO Q
SET DA(1)=^("UP")
SET DQ(DIU)=0
+1 IF DIU(0)'["D"
SET A=DA(1)
DO 63
SET A=DIU
GOTO SE
+2 SET D0=DIU
SET S=";"
SET Q=""""
+3 FOR I=1:1
if '$DATA(^DD(DIU,0,"UP"))
QUIT
SET A=^("UP")
SET %=$ORDER(^DD(A,"SB",DIU,0))
if %=""
QUIT
if '$DATA(^DD(A,%,0))#2
QUIT
SET %(I)=$PIECE($PIECE(^(0),U,4),S)
SET DIU=A
if +%(I)'=%(I)
SET %(I)=Q_%(I)_Q
IF I=1
SET (O,M)=^(0)
+4 SET DICL=I-2
FOR I=1:1:DICL+1
SET I(I)=%(DICL-I+2)
+5 SET I(0)=^DIC(DIU,0,"GL")
KILL %
+6 Begin DoDot:1
+7 NEW DIU0TOP,DIU0SFIL
SET DIU0TOP=A
SET DIU0SFIL=D0
+8 NEW A,DA,D0,DICL,DIU,DQ,I,O,M,S,Q
+9 DO INDEX^DIKC(DIU0TOP,"","","","KiRW"_DIU0SFIL)
End DoDot:1
+10 DO 63
SET A=D0
DO EN^DICATT4
SE SET DIK="^DD("_DA(1)_","
SET DA=$ORDER(^DD(DA(1),"SB",A,0))
if DA
DO ^DIK
+1 KILL D0,DICL,E,I,M,O,Q,S,T,X,Y
GOTO Q
