143 lines
6.7 KiB
Mathematica
143 lines
6.7 KiB
Mathematica
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
|