DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;28MAY2008
;;22.2;VA FileMan;**20**;Jan 05, 2016;Build 2
;;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.
;
K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q
S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";")=DU
I DU'<0 S ^(DU)=DV,DU=-2
G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y
PC S $P(DV,"^",DW)=DG(DQ) G Y
;
IX S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2)
S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1)
D:$D(DIEFXREF) FIREFLD
E1 K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q
;
B ;
I '$D(DB(DQ)) S X="?BAD" G ^DIEQ
S DC=DQ,DIK="",DL=1
OUT ;
D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY
;
E ;
I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1
Q K Y
QY I $D(DTOUT),$D(DIEDA) D
. N % K DA
. F %=1:1 Q:'$D(DIEDA(%)) S DA(%)=DIEDA(%)
. S DA=DIEDA
. Q
K:$D(DTOUT) DG,DQ
I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP
K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS,DIE1,DIESP
K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD,DLAYGO ;p20 added DLAYGO
Q
;
M ;
S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$P($P(DQ(DQ),U)," ",2,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX")
DIC S D="B",DLAYGO=DP,X=DD D K DIC("PTRIX") ;p20 change DLAYGO=DP\1
.N DIETMP,DICR D X^DIC
I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1
S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1
;
DOWN D S,DIE1,DDA S DIE=DIC Q
;
S ;CALLED BY O+1^DIE0
S DIOV(DL)=$G(DOV,0) K DOV
S DIE1N(DL)=$G(DIE1N),DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U_$G(DQ(DQ,"CAPTION"))),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR
S DM(DL)=DM,DK=0,DIE1(DL)=DIE1,DL=DL+1,DIE1=$S($G(DIE1N):DIE1N,1:DL),DIEL=DIEL+1,DM=9999999,DR=""
I $D(DR(DIE1,DP)) S DM=0,DR=DR(DIE1,DP)
Q
;
DDA N T,X
S T=$T
F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X)
K DA(1) S:$D(DA)#2 DA(1)=DA
S DIC=DIE_DA_","""_$P(DC,U,3)_""","
S:$D(DIETMP)#2 DIIENS=","_DIIENS
I T
Q
;
UDA N T,X
S T=$T
S DA=$G(DA(1)) ;K DA(1)
F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X)
S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999)
I T
Q
N ;
D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
D1 S @("D"_DIEL)=DA
G G MORE^DIE
;
UP ;
Q:$D(DTOUT)
S DP(0)=DP_U_DK(DL-1) I $D(DIEC(DL)) D DIEC G U
U1 D UDA S DIEL=DIEL-1
U S DQ=0,DL=DL-1,DIE1N=DIE1N(DL),DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL),DIE1=DIE1(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL)
G G
;
DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%)) S DA(%)=DIEC(DL,%)
F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL)) S @("D"_DIEL)=DIEC(DL,0,DIEL)
S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS")
S DIEL=DIEL-1 K DIEC(DL)
Q
;
FIREFLD ;Fire field-level xrefs stored in DIEFXREF
D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A"))
K DIEFXREF
Q
;
FIREREC ;Fire record-level xrefs accumulated in ^TMP
Q:$D(DIETMP)[0 Q:$D(@DIETMP@("R"))<2
N DP,DIIENS,DIE,DA,DIKEY,Y
;
S DP=0 F S DP=$O(@DIETMP@("R",DP)) Q:'DP D
. S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D
.. D DA^DILF(DIIENS,.DA)
.. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A"))
;
;If any keys are invalid, restore values
D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP)
;
K DIEFIRE,@DIETMP@("R"),@DIETMP@("V")
Q
;
RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values
N DA
K DIEBADK
S:$D(DIEFIRE)#2 X="BADKEY"
;
;Set "write" and "restore" flags
N DIEWR,DIEREST
I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1
E S DIEWR=0
I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0
E S DIEREST=1
I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q
;
N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA
N DINEW,DIOLD,DIRFIL,X
;
;Loop through all keys that are not unique and build FDA
K DIEFDA
S DIRFIL=0 F S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL D
. S DIEKK=0 F S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK D
.. Q:$D(^DD("KEY",DIEKK,0))[0
.. K DIFLD
.. S DIFLDI=0 F S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI D
... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2)
... Q:'DIFLD!'DIFIL
... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL)
.. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS="" D
... S DIFIL=0 F S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL D
.... S DIFLD=0 F S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD D
..... Q:$D(^DD(DIFIL,DIFLD,0))[0
..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999)
..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/")) S DIOLD=^("F")
..... K DA D DA^DILF(DIIENSA,.DA)
..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X="" X X S DINEW=X
..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD
..... I DIEWR!($G(DIEFIRE)["L") D
...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD
...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW
;
I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR
I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST)
;
I $G(DIEFIRE)'["L" K DIEBADK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIE1 5998 printed Apr 09, 2024@21:48:19 Page 2
DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;28MAY2008
+1 ;;22.2;VA FileMan;**20**;Jan 05, 2016;Build 2
+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 KILL DQ,DB
if $DATA(DG)<9
GOTO E1
IF DP<0
KILL DG
SET DQ=0
QUIT
+8 SET DQ=""
SET DU=-2
SET DG="$D("_DIE_DA_",DU))"
Y SET DQ=$ORDER(DG(DQ))
SET DW=$PIECE(DQ,";",2)
if $PIECE(DQ,";")=DU
GOTO DE
+1 IF DU'<0
SET ^(DU)=DV
SET DU=-2
+2 if DQ=""
GOTO IX
SET DU=$PIECE(DQ,";",1)
SET DV=""
IF @DG
SET DV=^(DU)
DE IF 'DW
SET DW=$EXTRACT(DW,2,99)
SET DE=DW-$LENGTH(DV)-1
SET %=$PIECE(DW,",",2)+1
SET X=$EXTRACT(DV,%,999)
SET DV=$EXTRACT(DV,0,DW-1)_$JUSTIFY("",$SELECT(DE>0:DE,1:0))_DG(DQ)
if X'?." "
SET DV=DV_$JUSTIFY("",%-DW-$LENGTH(DG(DQ)))_X
GOTO Y
PC SET $PIECE(DV,"^",DW)=DG(DQ)
GOTO Y
+1 ;
IX SET DICRREC="LOADXR^DIED"
SET DQ=$ORDER(DE(" "))
if DQ=""
GOTO E1
if '$DATA(DG(DQ))
GOTO E1
IF $DATA(DE(DE(DQ)))#2
FOR DG=1:1
if '$DATA(DE(DQ,DG))
QUIT
SET DIC=DIE
SET X=DE(DE(DQ))
XECUTE DE(DQ,DG,2)
+1 SET X=""
IF DG(DQ)]""
FOR DG=1:1
if '$DATA(DE(DQ,DG))
QUIT
SET DIC=DIE
SET X=DG(DQ)
XECUTE DE(DQ,DG,1)
+2 if $DATA(DIEFXREF)
DO FIREFLD
E1 KILL DICRREC,DIFLD,DG,DB,DE,DIANUM
SET DQ=0
QUIT
+1 ;
B ;
+1 IF '$DATA(DB(DQ))
SET X="?BAD"
GOTO ^DIEQ
+2 SET DC=DQ
SET DIK=""
SET DL=1
OUT ;
+1 DO DIE1
SET Y(DC)=DIK
if DL>1
GOTO UP
if DC=0
GOTO Q
GOTO QY
+2 ;
E ;
+1 IF DP'<0
SET DC=$SELECT($DATA(X)#2:X,1:"")
DO DIE1
SET X=DC
if DI>0
GOTO G
if DL>1
GOTO UP
Q KILL Y
QY IF $DATA(DTOUT)
IF $DATA(DIEDA)
Begin DoDot:1
+1 NEW %
KILL DA
+2 FOR %=1:1
if '$DATA(DIEDA(%))
QUIT
SET DA(%)=DIEDA(%)
+3 SET DA=DIEDA
+4 QUIT
End DoDot:1
+5 if $DATA(DTOUT)
KILL DG,DQ
+6 IF $DATA(DIETMP)#2
DO FIREREC
KILL @DIETMP,DIETMP
+7 KILL DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS,DIE1,DIESP
+8 ;p20 added DLAYGO
KILL DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD,DLAYGO
+9 QUIT
+10 ;
M ;
+1 SET DD=X
SET DIC(0)="LM"_$SELECT($DATA(DB(DQ)):"X",1:"QE")
SET DO(2)=$PIECE(DC,"^",2)
SET DO=$PIECE($PIECE(DQ(DQ),U)," ",2,99)_"^"_DO(2)_"^"_$PIECE(DC,"^",4,5)
DO DOWN
IF @("'$D("_DIC_"0))")
SET ^(0)="^"_DO(2)
+2 IF '$TEST
IF DO(2)["I"
SET %=0
SET DIC("W")=""
DO W^DIC1
+3 KILL DIC("PTRIX")
MERGE DIC("PTRIX")=DIE("PTRIX")
DIC ;p20 change DLAYGO=DP\1
SET D="B"
SET DLAYGO=DP
SET X=DD
Begin DoDot:1
+1 NEW DIETMP,DICR
DO X^DIC
End DoDot:1
KILL DIC("PTRIX")
+2 IF Y>0
SET DA=+Y
SET DI=0
SET X=$PIECE(Y,U,2)
if $DATA(DIETMP)#2
SET $PIECE(DIIENS,",")=DA
if +DR=.01!(DR="")&$PIECE(Y,U,3)
SET DI=.01
SET DK=1
SET DM=$PIECE($PIECE(DR,";",1),":",2)
SET DM=$SELECT(DR="":9999999,DM="":+DR,1:DM)
GOTO D1
+3 SET DI(DL-1)=DI(DL-1)_U
KILL DUOUT,DTOUT
GOTO U1
+4 ;
DOWN DO S
DO DIE1
DO DDA
SET DIE=DIC
QUIT
+1 ;
S ;CALLED BY O+1^DIE0
+1 SET DIOV(DL)=$GET(DOV,0)
KILL DOV
+2 SET DIE1N(DL)=$GET(DIE1N)
SET DP(DL)=DP
SET DP=+$PIECE(DC,"^",2)
SET DI(DL)=$SELECT(DV'["M":DI,$DATA(DSC(DP))!$DATA(DB(DQ)):DI,1:DI_U_$GET(DQ(DQ,"CAPTION")))
SET DIE(DL)=DIE
SET DK(DL)=DK
SET DR(DL)=DR
+3 SET DM(DL)=DM
SET DK=0
SET DIE1(DL)=DIE1
SET DL=DL+1
SET DIE1=$SELECT($GET(DIE1N):DIE1N,1:DL)
SET DIEL=DIEL+1
SET DM=9999999
SET DR=""
+4 IF $DATA(DR(DIE1,DP))
SET DM=0
SET DR=DR(DIE1,DP)
+5 QUIT
+6 ;
DDA NEW T,X
+1 SET T=$TEST
+2 FOR X=+$ORDER(DA(" "),-1):-1:1
KILL DA(X+1)
if $DATA(DA(X))#2
SET DA(X+1)=DA(X)
+3 KILL DA(1)
if $DATA(DA)#2
SET DA(1)=DA
+4 SET DIC=DIE_DA_","""_$PIECE(DC,U,3)_""","
+5 if $DATA(DIETMP)#2
SET DIIENS=","_DIIENS
+6 IF T
+7 QUIT
+8 ;
UDA NEW T,X
+1 SET T=$TEST
+2 ;K DA(1)
SET DA=$GET(DA(1))
+3 FOR X=2:1:+$ORDER(DA(" "),-1)
IF $DATA(DA(X))#2
SET DA(X-1)=DA(X)
KILL DA(X)
+4 if $DATA(DIETMP)#2
SET DIIENS=$PIECE(DIIENS,",",2,999)
+5 IF T
+6 QUIT
N ;
+1 DO DOWN
SET DA=$PIECE(DC,U,4)
SET DI=.01
if $DATA(DIETMP)#2
SET $PIECE(DIIENS,",")=DA
SET ^DISV(DUZ,$EXTRACT(DIC,1,28))=$EXTRACT(DIC,29,999)_DA
D1 SET @("D"_DIEL)=DA
G GOTO MORE^DIE
+1 ;
UP ;
+1 if $DATA(DTOUT)
QUIT
+2 SET DP(0)=DP_U_DK(DL-1)
IF $DATA(DIEC(DL))
DO DIEC
GOTO U
U1 DO UDA
SET DIEL=DIEL-1
U SET DQ=0
SET DL=DL-1
SET DIE1N=DIE1N(DL)
SET DIE=DIE(DL)
SET DM=DM(DL)
SET DI=DI(DL)
SET DP=DP(DL)
SET DR=DR(DL)
SET DK=DK(DL)
SET DIE1=DIE1(DL)
IF $DATA(DIOV(DL))
SET DOV=DIOV(DL)
KILL DIOV(DL)
+1 GOTO G
+2 ;
DIEC KILL DA
SET DA=DIEC(DL)
FOR %=1:1
if '$DATA(DIEC(DL,%))
QUIT
SET DA(%)=DIEC(DL,%)
+1 FOR DIEL=0:1
if '$DATA(DIEC(DL,0,DIEL))
QUIT
SET @("D"_DIEL)=DIEC(DL,0,DIEL)
+2 if $DATA(DIETMP)#2
SET DIIENS=DIEC(DL,"IENS")
+3 SET DIEL=DIEL-1
KILL DIEC(DL)
+4 QUIT
+5 ;
FIREFLD ;Fire field-level xrefs stored in DIEFXREF
+1 if $DATA(DIEFXREF)>2
DO FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$EXTRACT("C",$GET(DIOPER)="A"))
+2 KILL DIEFXREF
+3 QUIT
+4 ;
FIREREC ;Fire record-level xrefs accumulated in ^TMP
+1 if $DATA(DIETMP)[0
QUIT
if $DATA(@DIETMP@("R"))<2
QUIT
+2 NEW DP,DIIENS,DIE,DA,DIKEY,Y
+3 ;
+4 SET DP=0
FOR
SET DP=$ORDER(@DIETMP@("R",DP))
if 'DP
QUIT
Begin DoDot:1
+5 SET DIIENS=" "
FOR
SET DIIENS=$ORDER(@DIETMP@("R",DP,DIIENS))
if DIIENS=""
QUIT
Begin DoDot:2
+6 DO DA^DILF(DIIENS,.DA)
+7 DO FIRE^DIKC(DP,.DA,"KS",$NAME(@DIETMP@("R")),"F^^K",.DIKEY,$EXTRACT("C",$GET(DIOPER)="A"))
End DoDot:2
End DoDot:1
+8 ;
+9 ;If any keys are invalid, restore values
+10 if $DATA(DIKEY)>9
DO RESTORE(.DIKEY,DIETMP)
+11 ;
+12 KILL DIEFIRE,@DIETMP@("R"),@DIETMP@("V")
+13 QUIT
+14 ;
RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values
+1 NEW DA
+2 KILL DIEBADK
+3 if $DATA(DIEFIRE)#2
SET X="BADKEY"
+4 ;
+5 ;Set "write" and "restore" flags
+6 NEW DIEWR,DIEREST
+7 IF '$DATA(ZTQUEUED)
IF '$DATA(DDS)
IF $DATA(DIEFIRE)[0!($GET(DIEFIRE)["M")
SET DIEWR=1
+8 IF '$TEST
SET DIEWR=0
+9 IF $DATA(DIEFIRE)#2
IF DIEFIRE'["R"
SET DIEREST=0
+10 IF '$TEST
SET DIEREST=1
+11 IF '$GET(DIEWR)
IF '$GET(DIEREST)
IF $GET(DIEFIRE)'["L"
QUIT
+12 ;
+13 NEW DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA
+14 NEW DINEW,DIOLD,DIRFIL,X
+15 ;
+16 ;Loop through all keys that are not unique and build FDA
+17 KILL DIEFDA
+18 SET DIRFIL=0
FOR
SET DIRFIL=$ORDER(DIKEY(DIRFIL))
if 'DIRFIL
QUIT
Begin DoDot:1
+19 SET DIEKK=0
FOR
SET DIEKK=$ORDER(DIKEY(DIRFIL,DIEKK))
if 'DIEKK
QUIT
Begin DoDot:2
+20 if $DATA(^DD("KEY",DIEKK,0))[0
QUIT
+21 KILL DIFLD
+22 SET DIFLDI=0
FOR
SET DIFLDI=$ORDER(^DD("KEY",DIEKK,2,DIFLDI))
if 'DIFLDI
QUIT
Begin DoDot:3
+23 SET DIFLD=$PIECE($GET(^DD("KEY",DIEKK,2,DIFLDI,0)),U)
SET DIFIL=$PIECE($GET(^(0)),U,2)
+24 if 'DIFLD!'DIFIL
QUIT
+25 SET DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL)
End DoDot:3
+26 SET DIIENS=" "
SET DIIENS=$ORDER(DIKEY(DIRFIL,DIEKK,DIIENS))
if DIIENS=""
QUIT
Begin DoDot:3
+27 SET DIFIL=0
FOR
SET DIFIL=$ORDER(DIFLD(DIFIL))
if 'DIFIL
QUIT
Begin DoDot:4
+28 SET DIFLD=0
FOR
SET DIFLD=$ORDER(DIFLD(DIFIL,DIFLD))
if 'DIFLD
QUIT
Begin DoDot:5
+29 if $DATA(^DD(DIFIL,DIFLD,0))[0
QUIT
+30 SET DIIENSA=$PIECE(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999)
+31 if $DATA(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$DATA(^("4/"))
QUIT
SET DIOLD=^("F")
+32 KILL DA
DO DA^DILF(DIIENSA,.DA)
+33 SET X=$$DEC^DIKC2(DIFIL,DIFLD)
if X=""
QUIT
XECUTE X
SET DINEW=X
+34 IF DIEREST
SET DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD
+35 IF DIEWR!($GET(DIEFIRE)["L")
Begin DoDot:6
+36 SET DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD
+37 SET DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+38 ;
+39 IF DIEREST
IF $DATA(DIEFDA)
DO FILE^DIE("U","DIEFDA","DIEMSG")
KILL DIERR
+40 IF DIEWR
IF $DATA(DIEBADK)
DO MSG^DIEKMSG(.DIEBADK,DIEREST)
+41 ;
+42 IF $GET(DIEFIRE)'["L"
KILL DIEBADK
+43 QUIT
