Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFU2A

IBDFU2A.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. COPYLINE(LINE,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copys LINE from OLDBLOCK,FROMFILE to newly created NEWBLOCK,TOFILE
  1.  Q:('$G(LINE))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
  1.  Q:(FROMFILE'=357.7)&(FROMFILE'=358.7)
  1.  Q:(TOFILE'=357.7)&(TOFILE'=358.7)
  1.  N NODE,NAME,NEWLINE
  1.  S NEWLINE=""
  1.  S NODE=$G(^IBE(FROMFILE,LINE,0)) Q:NODE=""
  1.  ;make sure the line really belongs to the block being copied - if not re-index it
  1.  I $P(NODE,"^",6)'=OLDBLOCK K DA S DA=LINE,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
  1.  S NAME=$P(NODE,"^",1),$P(NODE,"^",6)=NEWBLOCK
  1.  K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S NEWLINE=$S(+Y<0:"",1:+Y)
  1.  Q:'NEWLINE
  1.  S ^IBE(TOFILE,NEWLINE,0)=NODE
  1.  K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWLINE
  1.  D IX1^DIK K DIK,DA
  1.  Q
  1.  ;
  1. COPYTEXT(TEXT,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies TEXT in OLDBLOCK,FROMFILE to NEWBLOCK,TOFILE
  1.  Q:('$G(TEXT))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
  1.  Q:(FROMFILE'=357.8)&(FROMFILE'=358.8)
  1.  Q:(TOFILE'=357.8)&(TOFILE'=358.8)
  1.  N NODE,NAME,NEWTEXT,TLINE
  1.  S NEWTEXT=""
  1.  S NODE=$G(^IBE(FROMFILE,TEXT,0)) Q:NODE=""
  1.  ;make sure the text area really belongs to the block being copied - re-index if not
  1.  I ($P(NODE,"^",2)'=OLDBLOCK) K DA S DA=TEXT,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
  1.  S NAME=$P(NODE,"^",1),$P(NODE,"^",2)=NEWBLOCK
  1.  K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S NEWTEXT=$S(+Y<0:"",1:+Y)
  1.  Q:'NEWTEXT
  1.  S ^IBE(TOFILE,NEWTEXT,0)=NODE
  1.  ;now copy the word-processing field
  1.  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
  1.  K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWTEXT
  1.  D IX1^DIK K DIK,DA
  1.  Q
  1.  ;
  1. COPYFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies a display field=FLD in FROMFILE to NEWBLOCK in TOFILE
  1.  Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
  1.  Q:(FROMFILE'=357.5)&(FROMFILE'=358.5)
  1.  Q:(TOFILE'=357.5)&(TOFILE'=358.5)
  1.  N NODE,NAME,NEWFLD,SUBFLD
  1.  S NEWFLD=""
  1.  S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
  1.  ;make sure the field really belongs to the block being copied - if not re-index it
  1.  I ($P(NODE,"^",2)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
  1.  S NAME=$P(NODE,"^",1),$P(NODE,"^",2)=NEWBLOCK
  1.  Q:NAME=""  ;corrupted data
  1.  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))
  1.  K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S NEWFLD=$S(+Y<0:"",1:+Y)
  1.  Q:'NEWFLD
  1.  S ^IBE(TOFILE,NEWFLD,0)=NODE
  1.  ;now copy the subfields
  1.  S NODE=$G(^IBE(FROMFILE,FLD,2,0))
  1.  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
  1.  K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
  1.  D IX1^DIK K DIK,DA
  1.  Q
  1.  ;
  1. COPYMFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies MUTLIPLE CHOICE FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
  1.  Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
  1.  Q:(FROMFILE'=357.93)&(FROMFILE'=358.93)
  1.  Q:(TOFILE'=357.93)&(TOFILE'=358.93)
  1.  N NODE,NAME,NEWFLD,SUBFLD,FROMPI
  1.  S NEWFLD=""
  1.  S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
  1.  ;make sure the field really belongs to the block being copied - if not re-index it
  1.  I ($P(NODE,"^",8)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
  1.  S NAME=$P(NODE,"^",1),$P(NODE,"^",8)=NEWBLOCK
  1.  Q:NAME=""  ;corrupted data
  1.  S FROMPI=$P(NODE,"^",6)
  1.  S:FROMPI $P(NODE,"^",6)=$$GETPI^IBDFU2B(FROMPI,$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
  1.  K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S NEWFLD=$S(+Y<0:"",1:+Y)
  1.  Q:'NEWFLD
  1.  S ^IBE(TOFILE,NEWFLD,0)=NODE
  1.  ;
  1.  ;now copy the subfields=the choices
  1.  ;don't copy choices for export if there is no package interface or choices are not exportable
  1.  I FROMPI,(FROMFILE=TOFILE)!($P($G(^IBE($S(FROMFILE[358:358.6,1:357.6),FROMPI,2)),"^",18)) D
  1.  .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
  1.  ..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))
  1.  ..S:NODE'="" ^IBE(TOFILE,NEWFLD,1,SUBFLD,0)=NODE
  1.  ;
  1.  ;index the new field
  1.  K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
  1.  D IX1^DIK
  1.  K DIK,DA
  1.  Q
  1.  ;
  1. COPYHFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies HAND PRINT FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
  1.  Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
  1.  Q:(FROMFILE'=359.94)&(FROMFILE'=358.94)
  1.  Q:(TOFILE'=359.94)&(TOFILE'=358.94)
  1.  N NODE,NAME,NEWFLD,SUBFLD
  1.  S NEWFLD=""
  1.  S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
  1.  ;make sure the field really belongs to the block being copied - if not re-index it
  1.  I ($P(NODE,"^",8)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
  1.  S NAME=$P(NODE,"^",1),$P(NODE,"^",8)=NEWBLOCK
  1.  Q:NAME=""  ;corrupted data
  1.  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))
  1.  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))
  1.  K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S NEWFLD=$S(+Y<0:"",1:+Y)
  1.  Q:'NEWFLD
  1.  S ^IBE(TOFILE,NEWFLD,0)=NODE
  1.  K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
  1.  D IX1^DIK K DIK,DA
  1.  Q
  1.  ;
  1. COPYGRP(GRP,LIST,NEWLIST,BLOCK,FROMFILE,TOFILE) ;
  1.  Q:(FROMFILE'=357.4)&(FROMFILE'=358.4)
  1.  Q:(TOFILE'=357.4)&(TOFILE'=358.4)
  1.  N NODE,HDR,NEWGRP,SLCTN,FROM,TO
  1.  S NEWGRP=""
  1.  S NODE=$G(^IBE(FROMFILE,GRP,0)) Q:NODE=""
  1.  ;make sure group belongs to list - otherwise re-index
  1.  I $P(NODE,"^",3)'=LIST K DA S DA=GRP,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
  1.  S HDR=$P(NODE,"^",1),$P(NODE,"^",3)=NEWLIST
  1.  Q:HDR=""
  1.  K DIC,DD,DO,DINUM S DIC="^IBE("_TOFILE_",",X=HDR,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S NEWGRP=$S(+Y<0:"",1:+Y)
  1.  Q:'NEWGRP
  1.  S ^IBE(TOFILE,NEWGRP,0)=NODE
  1.  S NODE=0 F  S NODE=$O(^IBE(FROMFILE,GRP,NODE)) Q:'NODE  S ^IBE(TOFILE,NEWGRP,NODE)=$G(^IBE(FROMFILE,GRP,NODE))
  1.  K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWGRP
  1.  D IX1^DIK K DIK,DA
  1.  S FROM=$S(FROMFILE[358:358.3,1:357.3),TO=$S(TOFILE[358:358.3,1:357.3)
  1.  S SLCTN="" F  S SLCTN=$O(^IBE(FROM,"D",GRP,SLCTN)) Q:'SLCTN  D CPYSLCTN^IBDFU2B(SLCTN,GRP,NEWGRP,LIST,NEWLIST,FROM,TO)
  1.  Q