IBDFU2A ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks - continued from IBDFU2) ; 08-JAN-1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
COPYLINE(LINE,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copys LINE from OLDBLOCK,FROMFILE to newly created NEWBLOCK,TOFILE
Q:('$G(LINE))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
Q:(FROMFILE'=357.7)&(FROMFILE'=358.7)
Q:(TOFILE'=357.7)&(TOFILE'=358.7)
N NODE,NAME,NEWLINE
S NEWLINE=""
S NODE=$G(^IBE(FROMFILE,LINE,0)) Q:NODE=""
;make sure the line really belongs to the block being copied - if not re-index it
I $P(NODE,"^",6)'=OLDBLOCK K DA S DA=LINE,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
S NAME=$P(NODE,"^",1),$P(NODE,"^",6)=NEWBLOCK
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWLINE=$S(+Y<0:"",1:+Y)
Q:'NEWLINE
S ^IBE(TOFILE,NEWLINE,0)=NODE
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWLINE
D IX1^DIK K DIK,DA
Q
;
COPYTEXT(TEXT,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies TEXT in OLDBLOCK,FROMFILE to NEWBLOCK,TOFILE
Q:('$G(TEXT))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
Q:(FROMFILE'=357.8)&(FROMFILE'=358.8)
Q:(TOFILE'=357.8)&(TOFILE'=358.8)
N NODE,NAME,NEWTEXT,TLINE
S NEWTEXT=""
S NODE=$G(^IBE(FROMFILE,TEXT,0)) Q:NODE=""
;make sure the text area really belongs to the block being copied - re-index if not
I ($P(NODE,"^",2)'=OLDBLOCK) K DA S DA=TEXT,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
S NAME=$P(NODE,"^",1),$P(NODE,"^",2)=NEWBLOCK
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWTEXT=$S(+Y<0:"",1:+Y)
Q:'NEWTEXT
S ^IBE(TOFILE,NEWTEXT,0)=NODE
;now copy the word-processing field
S NODE=$G(^IBE(FROMFILE,TEXT,1,0)) I NODE'="" S ^IBE(TOFILE,NEWTEXT,1,0)=NODE S TLINE=0 F S TLINE=$O(^IBE(FROMFILE,TEXT,1,TLINE)) Q:'TLINE S NODE=$G(^IBE(FROMFILE,TEXT,1,TLINE,0)) S:NODE'="" ^IBE(TOFILE,NEWTEXT,1,TLINE,0)=NODE
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWTEXT
D IX1^DIK K DIK,DA
Q
;
COPYFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies a display field=FLD in FROMFILE to NEWBLOCK in TOFILE
Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
Q:(FROMFILE'=357.5)&(FROMFILE'=358.5)
Q:(TOFILE'=357.5)&(TOFILE'=358.5)
N NODE,NAME,NEWFLD,SUBFLD
S NEWFLD=""
S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
;make sure the field really belongs to the block being copied - if not re-index it
I ($P(NODE,"^",2)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
S NAME=$P(NODE,"^",1),$P(NODE,"^",2)=NEWBLOCK
Q:NAME="" ;corrupted data
S:$P(NODE,"^",3) $P(NODE,"^",3)=$$GETPI^IBDFU2B($P(NODE,"^",3),$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWFLD=$S(+Y<0:"",1:+Y)
Q:'NEWFLD
S ^IBE(TOFILE,NEWFLD,0)=NODE
;now copy the subfields
S NODE=$G(^IBE(FROMFILE,FLD,2,0))
I NODE'="" S $P(NODE,"^",2)=TOFILE_2,^IBE(TOFILE,NEWFLD,2,0)=NODE S SUBFLD=0 F S SUBFLD=$O(^IBE(FROMFILE,FLD,2,SUBFLD)) Q:'SUBFLD S NODE=$G(^IBE(FROMFILE,FLD,2,SUBFLD,0)) S:NODE'="" ^IBE(TOFILE,NEWFLD,2,SUBFLD,0)=NODE
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
D IX1^DIK K DIK,DA
Q
;
COPYMFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies MUTLIPLE CHOICE FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
Q:(FROMFILE'=357.93)&(FROMFILE'=358.93)
Q:(TOFILE'=357.93)&(TOFILE'=358.93)
N NODE,NAME,NEWFLD,SUBFLD,FROMPI
S NEWFLD=""
S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
;make sure the field really belongs to the block being copied - if not re-index it
I ($P(NODE,"^",8)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
S NAME=$P(NODE,"^",1),$P(NODE,"^",8)=NEWBLOCK
Q:NAME="" ;corrupted data
S FROMPI=$P(NODE,"^",6)
S:FROMPI $P(NODE,"^",6)=$$GETPI^IBDFU2B(FROMPI,$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWFLD=$S(+Y<0:"",1:+Y)
Q:'NEWFLD
S ^IBE(TOFILE,NEWFLD,0)=NODE
;
;now copy the subfields=the choices
;don't copy choices for export if there is no package interface or choices are not exportable
I FROMPI,(FROMFILE=TOFILE)!($P($G(^IBE($S(FROMFILE[358:358.6,1:357.6),FROMPI,2)),"^",18)) D
.S NODE=$G(^IBE(FROMFILE,FLD,1,0)) I NODE'="" S $P(NODE,"^",2)=TOFILE_1,^IBE(TOFILE,NEWFLD,1,0)=NODE S SUBFLD=0 F S SUBFLD=$O(^IBE(FROMFILE,FLD,1,SUBFLD)) Q:'SUBFLD S NODE=$G(^IBE(FROMFILE,FLD,1,SUBFLD,0)) D
..S:$P(NODE,"^",9) $P(NODE,"^",9)=$$GETQLFR^IBDFU2B($P(NODE,"^",9),$S(FROMFILE[358:358.98,1:357.98),$S(TOFILE[358:358.98,1:357.98))
..S:NODE'="" ^IBE(TOFILE,NEWFLD,1,SUBFLD,0)=NODE
;
;index the new field
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
D IX1^DIK
K DIK,DA
Q
;
COPYHFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies HAND PRINT FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
Q:(FROMFILE'=359.94)&(FROMFILE'=358.94)
Q:(TOFILE'=359.94)&(TOFILE'=358.94)
N NODE,NAME,NEWFLD,SUBFLD
S NEWFLD=""
S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
;make sure the field really belongs to the block being copied - if not re-index it
I ($P(NODE,"^",8)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
S NAME=$P(NODE,"^",1),$P(NODE,"^",8)=NEWBLOCK
Q:NAME="" ;corrupted data
S:$P(NODE,"^",6) $P(NODE,"^",6)=$$GETPI^IBDFU2B($P(NODE,"^",6),$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
S:$P(NODE,"^",10) $P(NODE,"^",10)=$$GETADE^IBDFU2B($P(NODE,"^",10),$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1))
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWFLD=$S(+Y<0:"",1:+Y)
Q:'NEWFLD
S ^IBE(TOFILE,NEWFLD,0)=NODE
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
D IX1^DIK K DIK,DA
Q
;
COPYGRP(GRP,LIST,NEWLIST,BLOCK,FROMFILE,TOFILE) ;
Q:(FROMFILE'=357.4)&(FROMFILE'=358.4)
Q:(TOFILE'=357.4)&(TOFILE'=358.4)
N NODE,HDR,NEWGRP,SLCTN,FROM,TO
S NEWGRP=""
S NODE=$G(^IBE(FROMFILE,GRP,0)) Q:NODE=""
;make sure group belongs to list - otherwise re-index
I $P(NODE,"^",3)'=LIST K DA S DA=GRP,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
S HDR=$P(NODE,"^",1),$P(NODE,"^",3)=NEWLIST
Q:HDR=""
K DIC,DD,DO,DINUM S DIC="^IBE("_TOFILE_",",X=HDR,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWGRP=$S(+Y<0:"",1:+Y)
Q:'NEWGRP
S ^IBE(TOFILE,NEWGRP,0)=NODE
S NODE=0 F S NODE=$O(^IBE(FROMFILE,GRP,NODE)) Q:'NODE S ^IBE(TOFILE,NEWGRP,NODE)=$G(^IBE(FROMFILE,GRP,NODE))
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWGRP
D IX1^DIK K DIK,DA
S FROM=$S(FROMFILE[358:358.3,1:357.3),TO=$S(TOFILE[358:358.3,1:357.3)
S SLCTN="" F S SLCTN=$O(^IBE(FROM,"D",GRP,SLCTN)) Q:'SLCTN D CPYSLCTN^IBDFU2B(SLCTN,GRP,NEWGRP,LIST,NEWLIST,FROM,TO)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU2A 6981 printed Apr 09, 2024@20:56:38 Page 2
IBDFU2A ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks - continued from IBDFU2) ; 08-JAN-1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
COPYLINE(LINE,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copys LINE from OLDBLOCK,FROMFILE to newly created NEWBLOCK,TOFILE
+1 if ('$GET(LINE))!('$GET(OLDBLOCK))!('$GET(NEWBLOCK))!('$GET(FROMFILE))!('$GET(TOFILE))
QUIT
+2 if (FROMFILE'=357.7)&(FROMFILE'=358.7)
QUIT
+3 if (TOFILE'=357.7)&(TOFILE'=358.7)
QUIT
+4 NEW NODE,NAME,NEWLINE
+5 SET NEWLINE=""
+6 SET NODE=$GET(^IBE(FROMFILE,LINE,0))
if NODE=""
QUIT
+7 ;make sure the line really belongs to the block being copied - if not re-index it
+8 IF $PIECE(NODE,"^",6)'=OLDBLOCK
KILL DA
SET DA=LINE
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT
+9 SET NAME=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",6)=NEWBLOCK
+10 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+11 DO FILE^DICN
KILL DIC,DIE,DA
+12 SET NEWLINE=$SELECT(+Y<0:"",1:+Y)
+13 if 'NEWLINE
QUIT
+14 SET ^IBE(TOFILE,NEWLINE,0)=NODE
+15 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWLINE
+16 DO IX1^DIK
KILL DIK,DA
+17 QUIT
+18 ;
COPYTEXT(TEXT,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies TEXT in OLDBLOCK,FROMFILE to NEWBLOCK,TOFILE
+1 if ('$GET(TEXT))!('$GET(OLDBLOCK))!('$GET(NEWBLOCK))!('$GET(FROMFILE))!('$GET(TOFILE))
QUIT
+2 if (FROMFILE'=357.8)&(FROMFILE'=358.8)
QUIT
+3 if (TOFILE'=357.8)&(TOFILE'=358.8)
QUIT
+4 NEW NODE,NAME,NEWTEXT,TLINE
+5 SET NEWTEXT=""
+6 SET NODE=$GET(^IBE(FROMFILE,TEXT,0))
if NODE=""
QUIT
+7 ;make sure the text area really belongs to the block being copied - re-index if not
+8 IF ($PIECE(NODE,"^",2)'=OLDBLOCK)
KILL DA
SET DA=TEXT
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT
+9 SET NAME=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",2)=NEWBLOCK
+10 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+11 DO FILE^DICN
KILL DIC,DIE,DA
+12 SET NEWTEXT=$SELECT(+Y<0:"",1:+Y)
+13 if 'NEWTEXT
QUIT
+14 SET ^IBE(TOFILE,NEWTEXT,0)=NODE
+15 ;now copy the word-processing field
+16 SET NODE=$GET(^IBE(FROMFILE,TEXT,1,0))
IF NODE'=""
SET ^IBE(TOFILE,NEWTEXT,1,0)=NODE
SET TLINE=0
FOR
SET TLINE=$ORDER(^IBE(FROMFILE,TEXT,1,TLINE))
if 'TLINE
QUIT
SET NODE=$GET(^IBE(FROMFILE,TEXT,1,TLINE,0))
if NODE'=""
SET ^IBE(TOFILE,NEWTEXT,1,TLINE,0)=NODE
+17 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWTEXT
+18 DO IX1^DIK
KILL DIK,DA
+19 QUIT
+20 ;
COPYFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies a display field=FLD in FROMFILE to NEWBLOCK in TOFILE
+1 if ('$GET(FLD))!('$GET(OLDBLOCK))!('$GET(NEWBLOCK))!('$GET(FROMFILE))!('$GET(TOFILE))
QUIT
+2 if (FROMFILE'=357.5)&(FROMFILE'=358.5)
QUIT
+3 if (TOFILE'=357.5)&(TOFILE'=358.5)
QUIT
+4 NEW NODE,NAME,NEWFLD,SUBFLD
+5 SET NEWFLD=""
+6 SET NODE=$GET(^IBE(FROMFILE,FLD,0))
if NODE=""
QUIT
+7 ;make sure the field really belongs to the block being copied - if not re-index it
+8 IF ($PIECE(NODE,"^",2)'=OLDBLOCK)
KILL DA
SET DA=FLD
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT
+9 SET NAME=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",2)=NEWBLOCK
+10 ;corrupted data
if NAME=""
QUIT
+11 if $PIECE(NODE,"^",3)
SET $PIECE(NODE,"^",3)=$$GETPI^IBDFU2B($PIECE(NODE,"^",3),$SELECT(FROMFILE[358:358.6,1:357.6),$SELECT(TOFILE[358:358.6,1:357.6))
+12 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+13 DO FILE^DICN
KILL DIC,DIE,DA
+14 SET NEWFLD=$SELECT(+Y<0:"",1:+Y)
+15 if 'NEWFLD
QUIT
+16 SET ^IBE(TOFILE,NEWFLD,0)=NODE
+17 ;now copy the subfields
+18 SET NODE=$GET(^IBE(FROMFILE,FLD,2,0))
+19 IF NODE'=""
SET $PIECE(NODE,"^",2)=TOFILE_2
SET ^IBE(TOFILE,NEWFLD,2,0)=NODE
SET SUBFLD=0
FOR
SET SUBFLD=$ORDER(^IBE(FROMFILE,FLD,2,SUBFLD))
if 'SUBFLD
QUIT
SET NODE=$GET(^IBE(FROMFILE,FLD,2,SUBFLD,0))
if NODE'=""
SET ^IBE(TOFILE,NEWFLD,2,SUBFLD,0)=NODE
+20 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWFLD
+21 DO IX1^DIK
KILL DIK,DA
+22 QUIT
+23 ;
COPYMFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies MUTLIPLE CHOICE FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
+1 if ('$GET(FLD))!('$GET(OLDBLOCK))!('$GET(NEWBLOCK))!('$GET(FROMFILE))!('$GET(TOFILE))
QUIT
+2 if (FROMFILE'=357.93)&(FROMFILE'=358.93)
QUIT
+3 if (TOFILE'=357.93)&(TOFILE'=358.93)
QUIT
+4 NEW NODE,NAME,NEWFLD,SUBFLD,FROMPI
+5 SET NEWFLD=""
+6 SET NODE=$GET(^IBE(FROMFILE,FLD,0))
if NODE=""
QUIT
+7 ;make sure the field really belongs to the block being copied - if not re-index it
+8 IF ($PIECE(NODE,"^",8)'=OLDBLOCK)
KILL DA
SET DA=FLD
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT
+9 SET NAME=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",8)=NEWBLOCK
+10 ;corrupted data
if NAME=""
QUIT
+11 SET FROMPI=$PIECE(NODE,"^",6)
+12 if FROMPI
SET $PIECE(NODE,"^",6)=$$GETPI^IBDFU2B(FROMPI,$SELECT(FROMFILE[358:358.6,1:357.6),$SELECT(TOFILE[358:358.6,1:357.6))
+13 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+14 DO FILE^DICN
KILL DIC,DIE,DA
+15 SET NEWFLD=$SELECT(+Y<0:"",1:+Y)
+16 if 'NEWFLD
QUIT
+17 SET ^IBE(TOFILE,NEWFLD,0)=NODE
+18 ;
+19 ;now copy the subfields=the choices
+20 ;don't copy choices for export if there is no package interface or choices are not exportable
+21 IF FROMPI
IF (FROMFILE=TOFILE)!($PIECE($GET(^IBE($SELECT(FROMFILE[358:358.6,1:357.6),FROMPI,2)),"^",18))
Begin DoDot:1
+22 SET NODE=$GET(^IBE(FROMFILE,FLD,1,0))
IF NODE'=""
SET $PIECE(NODE,"^",2)=TOFILE_1
SET ^IBE(TOFILE,NEWFLD,1,0)=NODE
SET SUBFLD=0
FOR
SET SUBFLD=$ORDER(^IBE(FROMFILE,FLD,1,SUBFLD))
if 'SUBFLD
QUIT
SET NODE=$GET(^IBE(FROMFILE,FLD,1,SUBFLD,0))
Begin DoDot:2
+23 if $PIECE(NODE,"^",9)
SET $PIECE(NODE,"^",9)=$$GETQLFR^IBDFU2B($PIECE(NODE,"^",9),$SELECT(FROMFILE[358:358.98,1:357.98),$SELECT(TOFILE[358:358.98,1:357.98))
+24 if NODE'=""
SET ^IBE(TOFILE,NEWFLD,1,SUBFLD,0)=NODE
End DoDot:2
End DoDot:1
+25 ;
+26 ;index the new field
+27 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWFLD
+28 DO IX1^DIK
+29 KILL DIK,DA
+30 QUIT
+31 ;
COPYHFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies HAND PRINT FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
+1 if ('$GET(FLD))!('$GET(OLDBLOCK))!('$GET(NEWBLOCK))!('$GET(FROMFILE))!('$GET(TOFILE))
QUIT
+2 if (FROMFILE'=359.94)&(FROMFILE'=358.94)
QUIT
+3 if (TOFILE'=359.94)&(TOFILE'=358.94)
QUIT
+4 NEW NODE,NAME,NEWFLD,SUBFLD
+5 SET NEWFLD=""
+6 SET NODE=$GET(^IBE(FROMFILE,FLD,0))
if NODE=""
QUIT
+7 ;make sure the field really belongs to the block being copied - if not re-index it
+8 IF ($PIECE(NODE,"^",8)'=OLDBLOCK)
KILL DA
SET DA=FLD
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT
+9 SET NAME=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",8)=NEWBLOCK
+10 ;corrupted data
if NAME=""
QUIT
+11 if $PIECE(NODE,"^",6)
SET $PIECE(NODE,"^",6)=$$GETPI^IBDFU2B($PIECE(NODE,"^",6),$SELECT(FROMFILE[358:358.6,1:357.6),$SELECT(TOFILE[358:358.6,1:357.6))
+12 if $PIECE(NODE,"^",10)
SET $PIECE(NODE,"^",10)=$$GETADE^IBDFU2B($PIECE(NODE,"^",10),$SELECT(FROMFILE[358:358.99,1:359.1),$SELECT(TOFILE[358:358.99,1:359.1))
+13 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+14 DO FILE^DICN
KILL DIC,DIE,DA
+15 SET NEWFLD=$SELECT(+Y<0:"",1:+Y)
+16 if 'NEWFLD
QUIT
+17 SET ^IBE(TOFILE,NEWFLD,0)=NODE
+18 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWFLD
+19 DO IX1^DIK
KILL DIK,DA
+20 QUIT
+21 ;
COPYGRP(GRP,LIST,NEWLIST,BLOCK,FROMFILE,TOFILE) ;
+1 if (FROMFILE'=357.4)&(FROMFILE'=358.4)
QUIT
+2 if (TOFILE'=357.4)&(TOFILE'=358.4)
QUIT
+3 NEW NODE,HDR,NEWGRP,SLCTN,FROM,TO
+4 SET NEWGRP=""
+5 SET NODE=$GET(^IBE(FROMFILE,GRP,0))
if NODE=""
QUIT
+6 ;make sure group belongs to list - otherwise re-index
+7 IF $PIECE(NODE,"^",3)'=LIST
KILL DA
SET DA=GRP
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT
+8 SET HDR=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",3)=NEWLIST
+9 if HDR=""
QUIT
+10 KILL DIC,DD,DO,DINUM
SET DIC="^IBE("_TOFILE_","
SET X=HDR
SET DIC(0)=""
+11 DO FILE^DICN
KILL DIC,DIE,DA
+12 SET NEWGRP=$SELECT(+Y<0:"",1:+Y)
+13 if 'NEWGRP
QUIT
+14 SET ^IBE(TOFILE,NEWGRP,0)=NODE
+15 SET NODE=0
FOR
SET NODE=$ORDER(^IBE(FROMFILE,GRP,NODE))
if 'NODE
QUIT
SET ^IBE(TOFILE,NEWGRP,NODE)=$GET(^IBE(FROMFILE,GRP,NODE))
+16 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWGRP
+17 DO IX1^DIK
KILL DIK,DA
+18 SET FROM=$SELECT(FROMFILE[358:358.3,1:357.3)
SET TO=$SELECT(TOFILE[358:358.3,1:357.3)
+19 SET SLCTN=""
FOR
SET SLCTN=$ORDER(^IBE(FROM,"D",GRP,SLCTN))
if 'SLCTN
QUIT
DO CPYSLCTN^IBDFU2B(SLCTN,GRP,NEWGRP,LIST,NEWLIST,FROM,TO)
+20 QUIT
