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