DIT1 ;SFISC/GFT,TKW-TRANSFER DD'S ;30JAN2010
;;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.
;
K A W !! S A=+Y,E=A
CHK F V=0:0 S V=$O(^DD(A,"SB",V)) Q:'V S A(V)=0,L(V)=V#1+DHIT
S A=$O(A(0)),B=A#1+DHIT I A'="" K A(A) G P:$P(DHIT,".")+1'>B,CHK:'$D(^DD(B)),P:DHIT["." S X=$P(^(B,0),U) S:$D(^DIC(B,0)) X=$P(^(0),U)_" FILE" W $P(^DD(A,0),U)_" WOULD COLLIDE WITH "_X,$C(7),! K L,A Q
S A=$O(L(0)) I A S %X="^DIC("_A_",""%D"",",%Y="^DIC("_L(A)_",""%D""," D %XY^%RCR
D WAIT^DICD F A="^DIE(","^DIPT(","^DIBT(" F V=0:0 S V=$O(@(A_"V)")) Q:'V I $D(^(V,0)),$P(^(0),U,4)-Y=0 S ^UTILITY("DITR",$J,A,V)=$P(^(0),U)
S A="F B=0:0 Q:F=DTO!'$F(W,DTO) S W=$P(W,DTO)_F_$P(W,DTO,2,9)"
I $O(^UTILITY("DITR",$J,""))]"" W !,"DO YOU WANT TO COPY '",$P(Y,U,2),"'S TEMPLATES INTO YOUR NEW FILE" D YN^DICN W ! D:%=1
.S E="I DIK=""^DIBT("",%Z=1,$D(L(+W)) S $P(W,U)=L(+W)"
.F DIK="^DIE(","^DIPT(","^DIBT(" S V=$P(@(DIK_"0)"),U,3),%X=DIK_"Z,",%Y=DIK_"V," D ^DIT2,IXALL^DIK
GO S Y=DLAYGO K ^UTILITY("DITR",$J),^DD(Y,"B"),^(.01),^("IX"),^("RQ"),^(0,"IX"),E
S @("V=$P("_DTO_"0),U,2)"),@("^(0)=$P("_DTO(0)_"0),U,1,2)_$P(V,DDF(1),2)_U_U")
DD W ! S L=$O(L(L)) Q:L="" S Y=L(L),B=0,V=$O(^DD(L,0,"NM",0)),^DD(Y,0)=^DD(L,0) I V]"",$O(^(0,"NM",0))="" S ^(V)=""
S V=-1 I $D(^DD(L,0,"UP")) S ^DD(Y,0,"UP")=^("UP")#1+DHIT
ID S V=$O(^DD(L,0,"ID",V)) I V]"",$D(^(V))#2 S W=^(V) X A S ^DD(Y,0,"ID",V)=W G ID
F V=0:0 S V=$O(^DD(L,V)) Q:'V W "." D MOVEFLD
D IXKEY(.L,DTO,Y,F)
S DA(1)=Y,DIK="^DD("_Y_"," D IXALL^DIK K %A,%B,%C,%Z
G DD
;
MOVEFLD S W=$G(^DD(L,V,0)),D=$P(W,U,2),%Z=0,%A="" Q:W=""
I D["C" D Q ;copy COMPUTED FIELD, replacing Y variable with DIT
.N DITN
.S D=$P(W,U,5,99),^DD(Y,V,0)=$P(W,U,1,4)_"^N DIT "_$$DITRPL(D)
.S ^DD(Y,V,9)="^",^DD(Y,V,9.1)=$G(^DD(L,V,9.1))
.F DITN=9.01,9.02 S W=$G(^DD(L,V,DITN)) I W]"" D Y S ^DD(Y,V,DITN)=W
.S DITN=9.15 F S DITN=$O(^DD(L,V,DITN)) Q:DITN="" I $D(^(DITN))#2 S ^DD(Y,V,DITN)=$$DITRPL(^(DITN))
MULFLD I D S L(+D)=D#1+DHIT,W=$P(W,U)_U_L(+D)_$P(D,+D,2,9)_U_$P(W,U,3,99)
E X A ;D Y ;DO NOT REPLACE NUMBERS IN THE '0' NODE --GFT 1/30/2010
S ^DD(Y,V,0)=W,%B=0
N S %B=$O(@("^DD(L,V,"_%A_"%B)")) G:((%B=5)&(%A="")) N I %B="" Q:'%Z S @("%B="_$P(%A,",",%Z)),%Z=%Z-1,%A=$P(%A,",",1,%Z)_$E(",",%Z>0) G N
I @("$D(^DD(L,V,"_%A_"%B))#2") S W=^(%B) D D S @("^DD(Y,V,"_%A_"%B)=W")
I @("$D(^DD(L,V,"_%A_"%B))<9") G N
S:+%B'=%B %B=""""_%B_"""" S %A=%A_%B_",",%Z=%Z+1,%B="" G N
;
DITRPL(W) S W=$$REPLACE(W,"Y("_L_","_V_",","DIT(") D D Q W
;
D X A
Y ;REPLACE THE NUMBERS; CALLED FROM DIT2
N O
F O=0:0 S O=$O(L(O)) Q:'O S W=$$REPLACE(W,O,L(O))
Q
;
REPLACE(X,OLD,NEW) ;
N %,C
S C=$L(NEW)-$L(OLD)
F %=0:0 S %=$F(X,OLD,%) Q:%<1 I C+$L(X)<256,$E(X,%)'=".",$E(X,%-$L(OLD)-1)'?1N S X=$E(X,1,%-$L(OLD)-1)_NEW_$E(X,%,9999),%=%+C
Q X
;
IXKEY(DIFRN,DIFRGBL,DITON,DITOGBL) ; transfer KEY and INDEX file entries
; DIFRN=from file#, DIFRN(DIFRN)=from file list, DIFRGBL=from file global, DITON=to file#, DITOGBL=to file global
N A,B,E,F,V,Y
N DIFRNAME,DIFRD0,DIG,DITOD0,DIL1,DIL2,DIL3,DIFRPRT,I,X S DIFRNAME=""
S DIL1=$L(DIFRGBL)
S DIL3=$O(DIFRN("")) S:DIL3 DIL3=$F(DIFRGBL,DIL3) S:DIL3 DIL3=DIL3-1,DIFRPRT=$E(DIFRGBL,1,DIL3)
; INDEX file entries
F S DIFRNAME=$O(^DD("IX","BB",DIFRN,DIFRNAME)) Q:DIFRNAME="" D
. S DIFRD0=$O(^DD("IX","BB",DIFRN,DIFRNAME,0)) Q:'DIFRD0
. S DITOD0=$O(^DD("IX","BB",DITON,DIFRNAME,0)) I DITOD0 D ERR("IX",DITON,DIFRNAME) Q
. S DITOD0=$$NXTNO^DICLIB("^DD(""IX"",","","U")
. M ^DD("IX",DITOD0)=^DD("IX",DIFRD0)
. K ^DD("IX",DITOD0,11.1,"AC"),^("B"),^("BB")
. I DIFRGBL'=DITOGBL!(DIFRN'=DITON) S DIG="^DD(""IX"","_DITOD0_")" D ADJ
. S DIK="^DD(""IX"",",DA=DITOD0 D IX1^DIK
. Q
; KEY file entries
S DIFRNAME=""
F S DIFRNAME=$O(^DD("KEY","BB",DIFRN,DIFRNAME)) Q:DIFRNAME="" D
. S DIFRD0=$O(^DD("KEY","BB",DIFRN,DIFRNAME,0)) Q:'DIFRD0
. S DITOD0=$O(^DD("KEY","BB",DITON,DIFRNAME,0)) I DITOD0 D ERR("KEY",DITON,DIFRNAME) Q
. S DITOD0=$$NXTNO^DICLIB("^DD(""KEY"",","","U")
. M ^DD("KEY",DITOD0)=^DD("KEY",DIFRD0)
. K ^DD("KEY",DITOD0,2,"B"),^("BB"),^("S")
. I DIFRGBL'=DITOGBL!(DIFRN'=DITON) S DIG="^DD(""KEY"","_DITOD0_")" D ADJ
. S DIK="^DD(""KEY"",",DA=DITOD0 D IX1^DIK
. Q
Q
ADJ ; Change data to contain new file number and global reference.
F S DIG=$Q(@DIG),X=$QS(DIG,2) Q:X'=DITOD0 D
. S X=@DIG,I=0
. I DIFRGBL'=DITOGBL F S I=$F(X,DIFRGBL,I) Q:'I D
. . S $E(X,I-DIL1,I-1)=DITOGBL,I=I+$L(DITOGBL)-DIL1
. Q:DIFRN=DITON N DIF,DIT
. F DIF=0:0 S DIF=$O(DIFRN(DIF)) Q:'DIF S DIT=DIFRN(DIF),DIL2=$L(DIF),I=0 F D Q:'I
. . S I=$F(X,DIF,I) Q:'I Q:$E(X,I,999)
. . I DIL3,$E(X,(I-DIL3+1),(I-DIL1+DIL3-1))=DIFRPRT Q
. . S $E(X,I-DIL2,I-1)=DIT,I=I+$L(DIT)-DIL2
. S @DIG=X Q
Q
;
ERR(DITYPE,DITON,DIFRNAME) ;
;DITYPE=IX or KEY, DITON=file/subfile#, DIFRNAME=Index/Key name
N DIPAR,DIER S DIPAR(1)=$S(DITYPE="IX":"INDEX",1:"KEY")
S DIPAR(2)=DIFRNAME,DIPAR(3)=DITON
D BLD^DIALOG(9548,.DIPAR),MSG^DIALOG("WE")
Q
;
; Error list
;9548 - |1| '|2|' for file |3| already exists.
;
Q
;
P W $C(7),"FILE #"_+Y_" SHOULD ONLY BE TRANSFERRED TO A FILE WHOSE NUMBER",!?8,"ALSO "_$S(Y#1:"ENDS WITH '"_(Y#1)_"'",1:"IS INTEGER") K L,A Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIT1 5474 printed Apr 09, 2024@21:49:31 Page 2
DIT1 ;SFISC/GFT,TKW-TRANSFER DD'S ;30JAN2010
+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 KILL A
WRITE !!
SET A=+Y
SET E=A
CHK FOR V=0:0
SET V=$ORDER(^DD(A,"SB",V))
if 'V
QUIT
SET A(V)=0
SET L(V)=V#1+DHIT
+1 SET A=$ORDER(A(0))
SET B=A#1+DHIT
IF A'=""
KILL A(A)
if $PIECE(DHIT,".")+1'>B
GOTO P
if '$DATA(^DD(B))
GOTO CHK
if DHIT["."
GOTO P
SET X=$PIECE(^(B,0),U)
if $DATA(^DIC(B,0))
SET X=$PIECE(^(0),U)_" FILE"
WRITE $PIECE(^DD(A,0),U)_" WOULD COLLIDE WITH "_X,$CHAR(7),!
KILL L,A
QUIT
+2 SET A=$ORDER(L(0))
IF A
SET %X="^DIC("_A_",""%D"","
SET %Y="^DIC("_L(A)_",""%D"","
DO %XY^%RCR
+3 DO WAIT^DICD
FOR A="^DIE(","^DIPT(","^DIBT("
FOR V=0:0
SET V=$ORDER(@(A_"V)"))
if 'V
QUIT
IF $DATA(^(V,0))
IF $PIECE(^(0),U,4)-Y=0
SET ^UTILITY("DITR",$JOB,A,V)=$PIECE(^(0),U)
+4 SET A="F B=0:0 Q:F=DTO!'$F(W,DTO) S W=$P(W,DTO)_F_$P(W,DTO,2,9)"
+5 IF $ORDER(^UTILITY("DITR",$JOB,""))]""
WRITE !,"DO YOU WANT TO COPY '",$PIECE(Y,U,2),"'S TEMPLATES INTO YOUR NEW FILE"
DO YN^DICN
WRITE !
if %=1
Begin DoDot:1
+6 SET E="I DIK=""^DIBT("",%Z=1,$D(L(+W)) S $P(W,U)=L(+W)"
+7 FOR DIK="^DIE(","^DIPT(","^DIBT("
SET V=$PIECE(@(DIK_"0)"),U,3)
SET %X=DIK_"Z,"
SET %Y=DIK_"V,"
DO ^DIT2
DO IXALL^DIK
End DoDot:1
GO SET Y=DLAYGO
KILL ^UTILITY("DITR",$JOB),^DD(Y,"B"),^(.01),^("IX"),^("RQ"),^(0,"IX"),E
+1 SET @("V=$P("_DTO_"0),U,2)")
SET @("^(0)=$P("_DTO(0)_"0),U,1,2)_$P(V,DDF(1),2)_U_U")
DD WRITE !
SET L=$ORDER(L(L))
if L=""
QUIT
SET Y=L(L)
SET B=0
SET V=$ORDER(^DD(L,0,"NM",0))
SET ^DD(Y,0)=^DD(L,0)
IF V]""
IF $ORDER(^(0,"NM",0))=""
SET ^(V)=""
+1 SET V=-1
IF $DATA(^DD(L,0,"UP"))
SET ^DD(Y,0,"UP")=^("UP")#1+DHIT
ID SET V=$ORDER(^DD(L,0,"ID",V))
IF V]""
IF $DATA(^(V))#2
SET W=^(V)
XECUTE A
SET ^DD(Y,0,"ID",V)=W
GOTO ID
+1 FOR V=0:0
SET V=$ORDER(^DD(L,V))
if 'V
QUIT
WRITE "."
DO MOVEFLD
+2 DO IXKEY(.L,DTO,Y,F)
+3 SET DA(1)=Y
SET DIK="^DD("_Y_","
DO IXALL^DIK
KILL %A,%B,%C,%Z
+4 GOTO DD
+5 ;
MOVEFLD SET W=$GET(^DD(L,V,0))
SET D=$PIECE(W,U,2)
SET %Z=0
SET %A=""
if W=""
QUIT
+1 ;copy COMPUTED FIELD, replacing Y variable with DIT
IF D["C"
Begin DoDot:1
+2 NEW DITN
+3 SET D=$PIECE(W,U,5,99)
SET ^DD(Y,V,0)=$PIECE(W,U,1,4)_"^N DIT "_$$DITRPL(D)
+4 SET ^DD(Y,V,9)="^"
SET ^DD(Y,V,9.1)=$GET(^DD(L,V,9.1))
+5 FOR DITN=9.01,9.02
SET W=$GET(^DD(L,V,DITN))
IF W]""
DO Y
SET ^DD(Y,V,DITN)=W
+6 SET DITN=9.15
FOR
SET DITN=$ORDER(^DD(L,V,DITN))
if DITN=""
QUIT
IF $DATA(^(DITN))#2
SET ^DD(Y,V,DITN)=$$DITRPL(^(DITN))
End DoDot:1
QUIT
MULFLD IF D
SET L(+D)=D#1+DHIT
SET W=$PIECE(W,U)_U_L(+D)_$PIECE(D,+D,2,9)_U_$PIECE(W,U,3,99)
+1 ;D Y ;DO NOT REPLACE NUMBERS IN THE '0' NODE --GFT 1/30/2010
IF '$TEST
XECUTE A
+2 SET ^DD(Y,V,0)=W
SET %B=0
N SET %B=$ORDER(@("^DD(L,V,"_%A_"%B)"))
if ((%B=5)&(%A=""))
GOTO N
IF %B=""
if '%Z
QUIT
SET @("%B="_$PIECE(%A,",",%Z))
SET %Z=%Z-1
SET %A=$PIECE(%A,",",1,%Z)_$EXTRACT(",",%Z>0)
GOTO N
+1 IF @("$D(^DD(L,V,"_%A_"%B))#2")
SET W=^(%B)
DO D
SET @("^DD(Y,V,"_%A_"%B)=W")
+2 IF @("$D(^DD(L,V,"_%A_"%B))<9")
GOTO N
+3 if +%B'=%B
SET %B=""""_%B_""""
SET %A=%A_%B_","
SET %Z=%Z+1
SET %B=""
GOTO N
+4 ;
DITRPL(W) SET W=$$REPLACE(W,"Y("_L_","_V_",","DIT(")
DO D
QUIT W
+1 ;
D XECUTE A
Y ;REPLACE THE NUMBERS; CALLED FROM DIT2
+1 NEW O
+2 FOR O=0:0
SET O=$ORDER(L(O))
if 'O
QUIT
SET W=$$REPLACE(W,O,L(O))
+3 QUIT
+4 ;
REPLACE(X,OLD,NEW) ;
+1 NEW %,C
+2 SET C=$LENGTH(NEW)-$LENGTH(OLD)
+3 FOR %=0:0
SET %=$FIND(X,OLD,%)
if %<1
QUIT
IF C+$LENGTH(X)<256
IF $EXTRACT(X,%)'="."
IF $EXTRACT(X,%-$LENGTH(OLD)-1)'?1N
SET X=$EXTRACT(X,1,%-$LENGTH(OLD)-1)_NEW_$EXTRACT(X,%,9999)
SET %=%+C
+4 QUIT X
+5 ;
IXKEY(DIFRN,DIFRGBL,DITON,DITOGBL) ; transfer KEY and INDEX file entries
+1 ; DIFRN=from file#, DIFRN(DIFRN)=from file list, DIFRGBL=from file global, DITON=to file#, DITOGBL=to file global
+2 NEW A,B,E,F,V,Y
+3 NEW DIFRNAME,DIFRD0,DIG,DITOD0,DIL1,DIL2,DIL3,DIFRPRT,I,X
SET DIFRNAME=""
+4 SET DIL1=$LENGTH(DIFRGBL)
+5 SET DIL3=$ORDER(DIFRN(""))
if DIL3
SET DIL3=$FIND(DIFRGBL,DIL3)
if DIL3
SET DIL3=DIL3-1
SET DIFRPRT=$EXTRACT(DIFRGBL,1,DIL3)
+6 ; INDEX file entries
+7 FOR
SET DIFRNAME=$ORDER(^DD("IX","BB",DIFRN,DIFRNAME))
if DIFRNAME=""
QUIT
Begin DoDot:1
+8 SET DIFRD0=$ORDER(^DD("IX","BB",DIFRN,DIFRNAME,0))
if 'DIFRD0
QUIT
+9 SET DITOD0=$ORDER(^DD("IX","BB",DITON,DIFRNAME,0))
IF DITOD0
DO ERR("IX",DITON,DIFRNAME)
QUIT
+10 SET DITOD0=$$NXTNO^DICLIB("^DD(""IX"",","","U")
+11 MERGE ^DD("IX",DITOD0)=^DD("IX",DIFRD0)
+12 KILL ^DD("IX",DITOD0,11.1,"AC"),^("B"),^("BB")
+13 IF DIFRGBL'=DITOGBL!(DIFRN'=DITON)
SET DIG="^DD(""IX"","_DITOD0_")"
DO ADJ
+14 SET DIK="^DD(""IX"","
SET DA=DITOD0
DO IX1^DIK
+15 QUIT
End DoDot:1
+16 ; KEY file entries
+17 SET DIFRNAME=""
+18 FOR
SET DIFRNAME=$ORDER(^DD("KEY","BB",DIFRN,DIFRNAME))
if DIFRNAME=""
QUIT
Begin DoDot:1
+19 SET DIFRD0=$ORDER(^DD("KEY","BB",DIFRN,DIFRNAME,0))
if 'DIFRD0
QUIT
+20 SET DITOD0=$ORDER(^DD("KEY","BB",DITON,DIFRNAME,0))
IF DITOD0
DO ERR("KEY",DITON,DIFRNAME)
QUIT
+21 SET DITOD0=$$NXTNO^DICLIB("^DD(""KEY"",","","U")
+22 MERGE ^DD("KEY",DITOD0)=^DD("KEY",DIFRD0)
+23 KILL ^DD("KEY",DITOD0,2,"B"),^("BB"),^("S")
+24 IF DIFRGBL'=DITOGBL!(DIFRN'=DITON)
SET DIG="^DD(""KEY"","_DITOD0_")"
DO ADJ
+25 SET DIK="^DD(""KEY"","
SET DA=DITOD0
DO IX1^DIK
+26 QUIT
End DoDot:1
+27 QUIT
ADJ ; Change data to contain new file number and global reference.
+1 FOR
SET DIG=$QUERY(@DIG)
SET X=$QSUBSCRIPT(DIG,2)
if X'=DITOD0
QUIT
Begin DoDot:1
+2 SET X=@DIG
SET I=0
+3 IF DIFRGBL'=DITOGBL
FOR
SET I=$FIND(X,DIFRGBL,I)
if 'I
QUIT
Begin DoDot:2
+4 SET $EXTRACT(X,I-DIL1,I-1)=DITOGBL
SET I=I+$LENGTH(DITOGBL)-DIL1
End DoDot:2
+5 if DIFRN=DITON
QUIT
NEW DIF,DIT
+6 FOR DIF=0:0
SET DIF=$ORDER(DIFRN(DIF))
if 'DIF
QUIT
SET DIT=DIFRN(DIF)
SET DIL2=$LENGTH(DIF)
SET I=0
FOR
Begin DoDot:2
+7 SET I=$FIND(X,DIF,I)
if 'I
QUIT
if $EXTRACT(X,I,999)
QUIT
+8 IF DIL3
IF $EXTRACT(X,(I-DIL3+1),(I-DIL1+DIL3-1))=DIFRPRT
QUIT
+9 SET $EXTRACT(X,I-DIL2,I-1)=DIT
SET I=I+$LENGTH(DIT)-DIL2
End DoDot:2
if 'I
QUIT
+10 SET @DIG=X
QUIT
End DoDot:1
+11 QUIT
+12 ;
ERR(DITYPE,DITON,DIFRNAME) ;
+1 ;DITYPE=IX or KEY, DITON=file/subfile#, DIFRNAME=Index/Key name
+2 NEW DIPAR,DIER
SET DIPAR(1)=$SELECT(DITYPE="IX":"INDEX",1:"KEY")
+3 SET DIPAR(2)=DIFRNAME
SET DIPAR(3)=DITON
+4 DO BLD^DIALOG(9548,.DIPAR)
DO MSG^DIALOG("WE")
+5 QUIT
+6 ;
+7 ; Error list
+8 ;9548 - |1| '|2|' for file |3| already exists.
+9 ;
+10 QUIT
+11 ;
P WRITE $CHAR(7),"FILE #"_+Y_" SHOULD ONLY BE TRANSFERRED TO A FILE WHOSE NUMBER",!?8,"ALSO "_$SELECT(Y#1:"ENDS WITH '"_(Y#1)_"'",1:"IS INTEGER")
KILL L,A
QUIT
+1 ;
