IBDFU2 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks) ;01/08/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**15,63**;APR 24, 1997;Build 80
;
;
COPYBLK(OLDBLOCK,IBFORM,FROMFILE,TOFILE,ROW,COL,TKORDER,NAME,RECMPILE) ;copies OLDBLOCK in FROMFILE to IBFORM in TOFILE
;makes the new block part of IBFORM if defined
;places block at (ROW,COL) if defined
;sets TOOL KIT ORDER TKORDER if defined and >0
;sets the block name to NAME if defined
;returns the ien of the new copy
;RECMPILE means don't copy compiled block
;
Q:(FROMFILE'=357.1)&(FROMFILE'=358.1) ""
Q:(TOFILE'=357.1)&(TOFILE'=358.1) ""
N NODE,LIST,FLD,LINE,TEXT,NEWBLOCK,FROM,TO,SUB,I
S NEWBLOCK=""
S NODE=$G(^IBE(FROMFILE,OLDBLOCK,0)) Q:NODE="" ""
S $P(NODE,"^",2)=$G(IBFORM)
S:$G(NAME)="" NAME=$P(NODE,"^")
S RECMPILE=+$G(RECMPILE)
;there must be a name
Q:NAME="" ""
S $P(NODE,"^")=NAME
I $D(ROW),(ROW=+ROW) S $P(NODE,"^",4)=ROW
I $D(COL),(COL=+COL) S $P(NODE,"^",5)=COL
S:$D(TKORDER) $P(NODE,"^",14)=$S(TKORDER:TKORDER,1:"")
K DIC,DO,DD,DINUM S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWBLOCK=$S(+Y<0:"",1:+Y)
Q:'NEWBLOCK ""
S ^IBE(TOFILE,NEWBLOCK,0)=NODE
S NODE=0 F S NODE=$O(^IBE(FROMFILE,OLDBLOCK,NODE)) Q:'NODE S ^IBE(TOFILE,NEWBLOCK,NODE)=$G(^IBE(FROMFILE,OLDBLOCK,NODE))
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWBLOCK
D IX1^DIK K DIK,DA
;I ('RECMPILE),TOFILE=357.1,FROMFILE=357.1,$D(^IBE(357.1,OLDBLOCK,"V")),$D(^IBE(357.1,OLDBLOCK,"S")),$D(^IBE(357.1,OLDBLOCK,"B")),$D(^IBE(357.1,OLDBLOCK,"H")) D
;.F SUB="S","V","B","H" S I=0 S ^IBE(357.1,NEWBLOCK,SUB,0)=$G(^IBE(357.1,OLDBLOCK,SUB,0)) F S I=$O(^IBE(357.1,OLDBLOCK,SUB,I)) Q:'I S ^IBE(357.1,NEWBLOCK,SUB,I,0)=$G(^IBE(357.1,OLDBLOCK,SUB,I,0))
;before any new block component is created, make sure there is no garbage around with dangling pointer pointing to new block
D DLTCNTNT^IBDFU3(NEWBLOCK,TOFILE)
;
;now copy the old block's contents into the newblock
S (LIST,LINE,TEXT)=""
;
;copy selection lists
S FROM=$S(FROMFILE[358:358.2,1:357.2),TO=$S(TOFILE[358:358.2,1:357.2)
F S LIST=$O(^IBE(FROM,"C",OLDBLOCK,LIST)) Q:'LIST I $$COPYLIST(LIST,OLDBLOCK,NEWBLOCK,FROM,TO)
;
;copy data fields
S FROM=$S(FROMFILE[358:358.5,1:357.5),TO=$S(TOFILE[358:358.5,1:357.5)
S FLD=0 F S FLD=$O(^IBE(FROM,"C",OLDBLOCK,FLD)) Q:'FLD D COPYFLD^IBDFU2A(FLD,OLDBLOCK,NEWBLOCK,FROM,TO)
;
;copy multiple choice fields
S FROM=$S(FROMFILE[358:358.93,1:357.93),TO=$S(TOFILE[358:358.93,1:357.93)
S FLD=0 F S FLD=$O(^IBE(FROM,"C",OLDBLOCK,FLD)) Q:'FLD D COPYMFLD^IBDFU2A(FLD,OLDBLOCK,NEWBLOCK,FROM,TO)
;
;copy hand print fields
S FROM=$S(FROMFILE[358:358.94,1:359.94),TO=$S(TOFILE[358:358.94,1:359.94)
S FLD=0 F S FLD=$O(^IBE(FROM,"C",OLDBLOCK,FLD)) Q:'FLD D COPYHFLD^IBDFU2A(FLD,OLDBLOCK,NEWBLOCK,FROM,TO)
;
;copy lines
S FROM=$S(FROMFILE[358:358.7,1:357.7),TO=$S(TOFILE[358:358.7,1:357.7)
F S LINE=$O(^IBE(FROM,"C",OLDBLOCK,LINE)) Q:'LINE D COPYLINE^IBDFU2A(LINE,OLDBLOCK,NEWBLOCK,FROM,TO)
;
;copy text areas
S FROM=$S(FROMFILE[358:358.8,1:357.8),TO=$S(TOFILE[358:358.8,1:357.8)
F S TEXT=$O(^IBE(FROM,"C",OLDBLOCK,TEXT)) Q:'TEXT D COPYTEXT^IBDFU2A(TEXT,OLDBLOCK,NEWBLOCK,FROM,TO)
Q NEWBLOCK
;
COPYLIST(LIST,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;
N IBDIMPDA,IBDCSYS,IBDPIEN,IBDX
;returns the new list copied from LIST
Q:'$G(LIST)!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE)) 0
Q:(FROMFILE'=357.2)&(FROMFILE'=358.2) 0
Q:(TOFILE'=357.2)&(TOFILE'=358.2) 0
N NODE,NAME,NEWLIST,GRP,SLCTN,COL,TO,FROM,TOPI,FROMPI,DYNAMIC
S NEWLIST=""
S NODE=$G(^IBE(FROMFILE,LIST,0)) Q:NODE="" 0
S DYNAMIC=$P(NODE,"^",14)
;make sure the list really belongs to the block being copied - if not re-index it
I $P(NODE,"^",2)='OLDBLOCK K DA S DA=LIST,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q 0
S NAME=$P(NODE,"^",1),$P(NODE,"^",2)=NEWBLOCK
S FROMPI=$P(NODE,"^",11)
S TOPI=$$GETPI^IBDFU2B(FROMPI,$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6)),$P(NODE,"^",11)=TOPI
Q:NAME="" 0
K DIC,DD,DINUM,DO S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWLIST=$S(+Y<0:"",1:+Y)
Q:'NEWLIST 0
D DLISTCNT^IBDFU3(NEWLIST,TOFILE) ;clean up any dangling pointers that may be now pointing to this new, supposedly empty list
;
;now copy
S ^IBE(TOFILE,NEWLIST,0)=NODE
;
;copy the column multiple
S NODE=$G(^IBE(FROMFILE,LIST,1,0))
I NODE'="" S $P(NODE,"^",2)=TOFILE_"1I",^IBE(TOFILE,NEWLIST,1,0)=NODE S COL=0 F S COL=$O(^IBE(FROMFILE,LIST,1,COL)) Q:'COL S NODE=$G(^IBE(FROMFILE,LIST,1,COL,0)) S:NODE'="" ^IBE(TOFILE,NEWLIST,1,COL,0)=NODE
;
;now copy the subcolumn multiple
S NODE=$G(^IBE(FROMFILE,LIST,2,0)) I NODE'="" S $P(NODE,"^",2)=TOFILE_"2I",^IBE(TOFILE,NEWLIST,2,0)=NODE S COL=0 F S COL=$O(^IBE(FROMFILE,LIST,2,COL)) Q:'COL S NODE=$G(^IBE(FROMFILE,LIST,2,COL,0)) I NODE'="" D
.S:$P(NODE,"^",6) $P(NODE,"^",6)=$$GETMA^IBDFU2B($P(NODE,"^",6),$S(FROMFILE[358:358.91,1:357.91),$S(TOFILE[358:358.91,1:357.91))
.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 ^IBE(TOFILE,NEWLIST,2,COL,0)=NODE
;
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWLIST
D IX1^DIK K DIK,DA
S FROM=$S(FROMFILE[358:358.4,1:357.4),TO=$S(TOFILE[358:358.4,1:357.4)
;
; -- don't want to copy groups and selections if the selections are
; not exportable
I FROM'=TO,FROMPI,'$P($G(^IBE($S(FROM[358:358.6,1:357.6),FROMPI,2)),"^",18) Q NEWLIST
;I 'DYNAMIC S GRP="" F S GRP=$O(^IBE(FROM,"D",LIST,GRP)) Q:'GRP D COPYGRP^IBDFU2A(GRP,LIST,NEWLIST,NEWBLOCK,FROM,TO)
S GRP="" F S GRP=$O(^IBE(FROM,"D",LIST,GRP)) Q:'GRP D COPYGRP^IBDFU2A(GRP,LIST,NEWLIST,NEWBLOCK,FROM,TO)
Q NEWLIST
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU2 5788 printed Dec 13, 2024@02:53:34 Page 2
IBDFU2 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks) ;01/08/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15,63**;APR 24, 1997;Build 80
+2 ;
+3 ;
COPYBLK(OLDBLOCK,IBFORM,FROMFILE,TOFILE,ROW,COL,TKORDER,NAME,RECMPILE) ;copies OLDBLOCK in FROMFILE to IBFORM in TOFILE
+1 ;makes the new block part of IBFORM if defined
+2 ;places block at (ROW,COL) if defined
+3 ;sets TOOL KIT ORDER TKORDER if defined and >0
+4 ;sets the block name to NAME if defined
+5 ;returns the ien of the new copy
+6 ;RECMPILE means don't copy compiled block
+7 ;
+8 if (FROMFILE'=357.1)&(FROMFILE'=358.1)
QUIT ""
+9 if (TOFILE'=357.1)&(TOFILE'=358.1)
QUIT ""
+10 NEW NODE,LIST,FLD,LINE,TEXT,NEWBLOCK,FROM,TO,SUB,I
+11 SET NEWBLOCK=""
+12 SET NODE=$GET(^IBE(FROMFILE,OLDBLOCK,0))
if NODE=""
QUIT ""
+13 SET $PIECE(NODE,"^",2)=$GET(IBFORM)
+14 if $GET(NAME)=""
SET NAME=$PIECE(NODE,"^")
+15 SET RECMPILE=+$GET(RECMPILE)
+16 ;there must be a name
+17 if NAME=""
QUIT ""
+18 SET $PIECE(NODE,"^")=NAME
+19 IF $DATA(ROW)
IF (ROW=+ROW)
SET $PIECE(NODE,"^",4)=ROW
+20 IF $DATA(COL)
IF (COL=+COL)
SET $PIECE(NODE,"^",5)=COL
+21 if $DATA(TKORDER)
SET $PIECE(NODE,"^",14)=$SELECT(TKORDER:TKORDER,1:"")
+22 KILL DIC,DO,DD,DINUM
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+23 DO FILE^DICN
KILL DIC,DIE,DA
+24 SET NEWBLOCK=$SELECT(+Y<0:"",1:+Y)
+25 if 'NEWBLOCK
QUIT ""
+26 SET ^IBE(TOFILE,NEWBLOCK,0)=NODE
+27 SET NODE=0
FOR
SET NODE=$ORDER(^IBE(FROMFILE,OLDBLOCK,NODE))
if 'NODE
QUIT
SET ^IBE(TOFILE,NEWBLOCK,NODE)=$GET(^IBE(FROMFILE,OLDBLOCK,NODE))
+28 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWBLOCK
+29 DO IX1^DIK
KILL DIK,DA
+30 ;I ('RECMPILE),TOFILE=357.1,FROMFILE=357.1,$D(^IBE(357.1,OLDBLOCK,"V")),$D(^IBE(357.1,OLDBLOCK,"S")),$D(^IBE(357.1,OLDBLOCK,"B")),$D(^IBE(357.1,OLDBLOCK,"H")) D
+31 ;.F SUB="S","V","B","H" S I=0 S ^IBE(357.1,NEWBLOCK,SUB,0)=$G(^IBE(357.1,OLDBLOCK,SUB,0)) F S I=$O(^IBE(357.1,OLDBLOCK,SUB,I)) Q:'I S ^IBE(357.1,NEWBLOCK,SUB,I,0)=$G(^IBE(357.1,OLDBLOCK,SUB,I,0))
+32 ;before any new block component is created, make sure there is no garbage around with dangling pointer pointing to new block
+33 DO DLTCNTNT^IBDFU3(NEWBLOCK,TOFILE)
+34 ;
+35 ;now copy the old block's contents into the newblock
+36 SET (LIST,LINE,TEXT)=""
+37 ;
+38 ;copy selection lists
+39 SET FROM=$SELECT(FROMFILE[358:358.2,1:357.2)
SET TO=$SELECT(TOFILE[358:358.2,1:357.2)
+40 FOR
SET LIST=$ORDER(^IBE(FROM,"C",OLDBLOCK,LIST))
if 'LIST
QUIT
IF $$COPYLIST(LIST,OLDBLOCK,NEWBLOCK,FROM,TO)
+41 ;
+42 ;copy data fields
+43 SET FROM=$SELECT(FROMFILE[358:358.5,1:357.5)
SET TO=$SELECT(TOFILE[358:358.5,1:357.5)
+44 SET FLD=0
FOR
SET FLD=$ORDER(^IBE(FROM,"C",OLDBLOCK,FLD))
if 'FLD
QUIT
DO COPYFLD^IBDFU2A(FLD,OLDBLOCK,NEWBLOCK,FROM,TO)
+45 ;
+46 ;copy multiple choice fields
+47 SET FROM=$SELECT(FROMFILE[358:358.93,1:357.93)
SET TO=$SELECT(TOFILE[358:358.93,1:357.93)
+48 SET FLD=0
FOR
SET FLD=$ORDER(^IBE(FROM,"C",OLDBLOCK,FLD))
if 'FLD
QUIT
DO COPYMFLD^IBDFU2A(FLD,OLDBLOCK,NEWBLOCK,FROM,TO)
+49 ;
+50 ;copy hand print fields
+51 SET FROM=$SELECT(FROMFILE[358:358.94,1:359.94)
SET TO=$SELECT(TOFILE[358:358.94,1:359.94)
+52 SET FLD=0
FOR
SET FLD=$ORDER(^IBE(FROM,"C",OLDBLOCK,FLD))
if 'FLD
QUIT
DO COPYHFLD^IBDFU2A(FLD,OLDBLOCK,NEWBLOCK,FROM,TO)
+53 ;
+54 ;copy lines
+55 SET FROM=$SELECT(FROMFILE[358:358.7,1:357.7)
SET TO=$SELECT(TOFILE[358:358.7,1:357.7)
+56 FOR
SET LINE=$ORDER(^IBE(FROM,"C",OLDBLOCK,LINE))
if 'LINE
QUIT
DO COPYLINE^IBDFU2A(LINE,OLDBLOCK,NEWBLOCK,FROM,TO)
+57 ;
+58 ;copy text areas
+59 SET FROM=$SELECT(FROMFILE[358:358.8,1:357.8)
SET TO=$SELECT(TOFILE[358:358.8,1:357.8)
+60 FOR
SET TEXT=$ORDER(^IBE(FROM,"C",OLDBLOCK,TEXT))
if 'TEXT
QUIT
DO COPYTEXT^IBDFU2A(TEXT,OLDBLOCK,NEWBLOCK,FROM,TO)
+61 QUIT NEWBLOCK
+62 ;
COPYLIST(LIST,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;
+1 NEW IBDIMPDA,IBDCSYS,IBDPIEN,IBDX
+2 ;returns the new list copied from LIST
+3 if '$GET(LIST)!('$GET(OLDBLOCK))!('$GET(NEWBLOCK))!('$GET(FROMFILE))!('$GET(TOFILE))
QUIT 0
+4 if (FROMFILE'=357.2)&(FROMFILE'=358.2)
QUIT 0
+5 if (TOFILE'=357.2)&(TOFILE'=358.2)
QUIT 0
+6 NEW NODE,NAME,NEWLIST,GRP,SLCTN,COL,TO,FROM,TOPI,FROMPI,DYNAMIC
+7 SET NEWLIST=""
+8 SET NODE=$GET(^IBE(FROMFILE,LIST,0))
if NODE=""
QUIT 0
+9 SET DYNAMIC=$PIECE(NODE,"^",14)
+10 ;make sure the list really belongs to the block being copied - if not re-index it
+11 IF $PIECE(NODE,"^",2)='OLDBLOCK
KILL DA
SET DA=LIST
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT 0
+12 SET NAME=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",2)=NEWBLOCK
+13 SET FROMPI=$PIECE(NODE,"^",11)
+14 SET TOPI=$$GETPI^IBDFU2B(FROMPI,$SELECT(FROMFILE[358:358.6,1:357.6),$SELECT(TOFILE[358:358.6,1:357.6))
SET $PIECE(NODE,"^",11)=TOPI
+15 if NAME=""
QUIT 0
+16 KILL DIC,DD,DINUM,DO
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+17 DO FILE^DICN
KILL DIC,DIE,DA
+18 SET NEWLIST=$SELECT(+Y<0:"",1:+Y)
+19 if 'NEWLIST
QUIT 0
+20 ;clean up any dangling pointers that may be now pointing to this new, supposedly empty list
DO DLISTCNT^IBDFU3(NEWLIST,TOFILE)
+21 ;
+22 ;now copy
+23 SET ^IBE(TOFILE,NEWLIST,0)=NODE
+24 ;
+25 ;copy the column multiple
+26 SET NODE=$GET(^IBE(FROMFILE,LIST,1,0))
+27 IF NODE'=""
SET $PIECE(NODE,"^",2)=TOFILE_"1I"
SET ^IBE(TOFILE,NEWLIST,1,0)=NODE
SET COL=0
FOR
SET COL=$ORDER(^IBE(FROMFILE,LIST,1,COL))
if 'COL
QUIT
SET NODE=$GET(^IBE(FROMFILE,LIST,1,COL,0))
if NODE'=""
SET ^IBE(TOFILE,NEWLIST,1,COL,0)=NODE
+28 ;
+29 ;now copy the subcolumn multiple
+30 SET NODE=$GET(^IBE(FROMFILE,LIST,2,0))
IF NODE'=""
SET $PIECE(NODE,"^",2)=TOFILE_"2I"
SET ^IBE(TOFILE,NEWLIST,2,0)=NODE
SET COL=0
FOR
SET COL=$ORDER(^IBE(FROMFILE,LIST,2,COL))
if 'COL
QUIT
SET NODE=$GET(^IBE(FROMFILE,LIST,2,COL,0))
IF NODE'=""
Begin DoDot:1
+31 if $PIECE(NODE,"^",6)
SET $PIECE(NODE,"^",6)=$$GETMA^IBDFU2B($PIECE(NODE,"^",6),$SELECT(FROMFILE[358:358.91,1:357.91),$SELECT(TOFILE[358:358.91,1:357.91))
+32 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))
+33 SET ^IBE(TOFILE,NEWLIST,2,COL,0)=NODE
End DoDot:1
+34 ;
+35 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWLIST
+36 DO IX1^DIK
KILL DIK,DA
+37 SET FROM=$SELECT(FROMFILE[358:358.4,1:357.4)
SET TO=$SELECT(TOFILE[358:358.4,1:357.4)
+38 ;
+39 ; -- don't want to copy groups and selections if the selections are
+40 ; not exportable
+41 IF FROM'=TO
IF FROMPI
IF '$PIECE($GET(^IBE($SELECT(FROM[358:358.6,1:357.6),FROMPI,2)),"^",18)
QUIT NEWLIST
+42 ;I 'DYNAMIC S GRP="" F S GRP=$O(^IBE(FROM,"D",LIST,GRP)) Q:'GRP D COPYGRP^IBDFU2A(GRP,LIST,NEWLIST,NEWBLOCK,FROM,TO)
+43 SET GRP=""
FOR
SET GRP=$ORDER(^IBE(FROM,"D",LIST,GRP))
if 'GRP
QUIT
DO COPYGRP^IBDFU2A(GRP,LIST,NEWLIST,NEWBLOCK,FROM,TO)
+44 QUIT NEWLIST
