- 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 Jan 18, 2025@03:47:59 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