- 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 Feb 19, 2025@00:19:59 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