IBDFU2C ;ALB/CJM - ENCOUNTER FORM - (COPYING FORMS) ;AUG12,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
COPYFORM(OLDFORM,FROMFILE,TOFILE,NEWNAME,TK) ;
;copies OLDFORM from FROMFILE to TOFILE, changing the name to NEWNAME if defined (NEWNAME is optional), and the field TOOL KIT to TK if defined
;
Q:'$D(OLDFORM)!'$D(FROMFILE)!'$D(TOFILE) ""
Q:(FROMFILE'=357)&(FROMFILE'=358) ""
Q:(TOFILE'=357)&(TOFILE'=358) ""
Q:'OLDFORM ""
N NEWFORM,NODE,OLDBLOCK,NEWBLOCK,BLOCK,IBDELETE,FROM,TO,PAGE
S NODE=$G(^IBE(FROMFILE,OLDFORM,0)) Q:NODE="" ""
S:($G(NEWNAME)'="") $P(NODE,"^")=NEWNAME
S:$G(NEWNAME)="" NEWNAME=$P(NODE,"^")
I $G(TK)=+$G(TK) S $P(NODE,"^",7)=TK
S $P(NODE,"^",5)=0,$P(NODE,"^",13)=""
K DIC,DD,DO,DINUM S DIC="^IBE("_TOFILE_",",X=NEWNAME,DIC(0)=""
D FILE^DICN K DIC,DIE
S NEWFORM=$S(+Y<0:"",1:+Y)
I (NEWFORM<0) W !,"Unable to create a new form!" D PAUSE^IBDFU5 Q ""
;
;the new form should be empty - make sure
S FROM=$S(FROMFILE[358:358.1,1:357.1)
S TO=$S(TOFILE[358:358.1,1:357.1)
S BLOCK="" F S BLOCK=$O(^IBE(TOFILE,"C",NEWFORM,BLOCK)) Q:'BLOCK D
.I $P($G(^IBE(TO,BLOCK,0)),"^",2)'=NEWFORM D
..K ^IBE(TO,"C",NEWFORM,BLOCK),DA S DIK="^IBE("_TO_",",DA=BLOCK D IX1^DIK K DIK,DA
.E D DLTBLK^IBDFU3(BLOCK,NEWFORM,TO)
;
;copy old 0 node into the new form
S ^IBE(TOFILE,NEWFORM,0)=NODE
;
;now the page multiple
S NODE=$G(^IBE(FROMFILE,OLDFORM,2,0))
I NODE'="" S $P(NODE,"^",2)=TOFILE_".02I",^IBE(TOFILE,NEWFORM,2,0)=NODE S PAGE=0 F S PAGE=$O(^IBE(FROMFILE,OLDFORM,2,PAGE)) Q:'PAGE S NODE=$G(^IBE(FROMFILE,OLDFORM,2,PAGE,0)) S:NODE'="" ^IBE(TOFILE,NEWFORM,2,PAGE,0)=NODE
;
;copy the rest of the form
S NODE=0 F S NODE=$O(^IBE(FROMFILE,OLDFORM,NODE)) Q:'NODE Q:$G(^IBE(FROMFILE,OLDFORM,NODE))="" S ^IBE(TOFILE,NEWFORM,NODE)=$G(^IBE(FROMFILE,OLDFORM,NODE))
K DIK S DIK="^IBE("_TOFILE_",",DA=NEWFORM D IX^DIK K DIK
;
;now copy the blocks into the form
S OLDBLOCK="" F S OLDBLOCK=$O(^IBE(FROM,"C",OLDFORM,OLDBLOCK)) Q:'OLDBLOCK I $P($G(^IBE(FROM,OLDBLOCK,0)),"^",2)=OLDFORM S NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,NEWFORM,FROM,TO) W "."
Q NEWFORM
;
;
DELETE(FORM,FILE,ASK) ;deletes the FORM in FILE- if ASK then asks permission first
Q:'$G(FORM)
Q:(FILE'=357)&(FILE'=358)
I $G(ASK) Q:'$$RUSURE^IBDFU5($P($G(^IBE(FILE,FORM,0)),"^"))
N BLOCK,BLKFILE,CR
;might have to delete the bubble translation table
I FILE=357 D
.Q:'$$FORMDSCR^IBDFU1C(.FORM)
.I FORM("TYPE") D KILLTBL^IBDF19(.FORM)
S BLKFILE=FILE+.1
S BLOCK="" F S BLOCK=$O(^IBE(BLKFILE,"C",FORM,BLOCK)) Q:'BLOCK D DLTBLK^IBDFU3(BLOCK,FORM,BLKFILE) W "."
I FILE=357 F CR="AT","AC","AU","AG" K ^IBE(357,CR,FORM)
K DA S DIK="^IBE("_FILE_",",DA=FORM D ^DIK K DIK,DA
K FORM
Q
NEWNAME(OLDNAME) ;asks the user to select a unique form name
;returns "" if unsuccessfull, else the form name
;shows OLDNAME as the default if defined
;
N NAME,QUIT S NAME="",QUIT=0
K DIR S DIR(0)="357,.01A",DIR("A")="New Form Name: ",DIR("?")="Enter a unique name up to 30 characters"
S DIR("B")="" I $G(OLDNAME)'="",'$O(IBE(357,"B",OLDNAME,0)) S DIR("B")=OLDNAME
F D Q:QUIT
.D ^DIR I $D(DIRUT) S QUIT=1 Q
.I $O(^IBE(357,"B",Y,"")) D
..W !,"The form name must be unique, try using the clinic in the name!"
.E S NAME=Y,QUIT=1
K DIR
Q NAME
TKFORM() ;returns the form TOOL KIT that contains all of the tool kit blocs
N TKFORM,BLOCK,TKORDER,TK
S TKFORM=+$O(^IBE(357,"B","TOOL KIT",""))
I 'TKFORM D
.K DIC,DD,DO,DINUM S DIC="^IBE(357,",DIC(0)="",X="TOOL KIT"
.D FILE^DICN K DIC,DIE,DA
.S TKFORM=$S(+(Y>0):+Y,1:"")
.Q:'TKFORM
.S ^IBE(357,TKFORM,0)="TOOL KIT^^CONTAINS ALL OF THE TOOL KIT BLOCKS^^^^1"
.K DIK S DIK="^IBE(357,",DA=TKFORM D IX1^DIK K DIK
.S TKORDER=0 F S TKORDER=$O(^IBE(357.1,"D",TKORDER)) Q:'TKORDER S BLOCK=0 F S BLOCK=$O(^IBE(357.1,"D",TKORDER,BLOCK)) Q:'BLOCK D
..S TK=$P($G(^IBE(357.1,BLOCK,0)),"^",14) I 'TK K ^IBE(357.1,"D",TKORDER,BLOCK) Q
..S FORM=$P($G(^IBE(357.1,BLOCK,0)),"^",2) I FORM'=TKFORM K ^IBE(357.1,"C",FORM,BLOCK) S $P(^IBE(357.1,BLOCK,0),"^",2)=TKFORM K DIK S DIK="^IBE(357.1,",DA=BLOCK,DIK(1)=.02 D EN1^DIK K DIK
Q TKFORM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU2C 4173 printed Nov 22, 2024@18:03:47 Page 2
IBDFU2C ;ALB/CJM - ENCOUNTER FORM - (COPYING FORMS) ;AUG12,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
COPYFORM(OLDFORM,FROMFILE,TOFILE,NEWNAME,TK) ;
+1 ;copies OLDFORM from FROMFILE to TOFILE, changing the name to NEWNAME if defined (NEWNAME is optional), and the field TOOL KIT to TK if defined
+2 ;
+3 if '$DATA(OLDFORM)!'$DATA(FROMFILE)!'$DATA(TOFILE)
QUIT ""
+4 if (FROMFILE'=357)&(FROMFILE'=358)
QUIT ""
+5 if (TOFILE'=357)&(TOFILE'=358)
QUIT ""
+6 if 'OLDFORM
QUIT ""
+7 NEW NEWFORM,NODE,OLDBLOCK,NEWBLOCK,BLOCK,IBDELETE,FROM,TO,PAGE
+8 SET NODE=$GET(^IBE(FROMFILE,OLDFORM,0))
if NODE=""
QUIT ""
+9 if ($GET(NEWNAME)'="")
SET $PIECE(NODE,"^")=NEWNAME
+10 if $GET(NEWNAME)=""
SET NEWNAME=$PIECE(NODE,"^")
+11 IF $GET(TK)=+$GET(TK)
SET $PIECE(NODE,"^",7)=TK
+12 SET $PIECE(NODE,"^",5)=0
SET $PIECE(NODE,"^",13)=""
+13 KILL DIC,DD,DO,DINUM
SET DIC="^IBE("_TOFILE_","
SET X=NEWNAME
SET DIC(0)=""
+14 DO FILE^DICN
KILL DIC,DIE
+15 SET NEWFORM=$SELECT(+Y<0:"",1:+Y)
+16 IF (NEWFORM<0)
WRITE !,"Unable to create a new form!"
DO PAUSE^IBDFU5
QUIT ""
+17 ;
+18 ;the new form should be empty - make sure
+19 SET FROM=$SELECT(FROMFILE[358:358.1,1:357.1)
+20 SET TO=$SELECT(TOFILE[358:358.1,1:357.1)
+21 SET BLOCK=""
FOR
SET BLOCK=$ORDER(^IBE(TOFILE,"C",NEWFORM,BLOCK))
if 'BLOCK
QUIT
Begin DoDot:1
+22 IF $PIECE($GET(^IBE(TO,BLOCK,0)),"^",2)'=NEWFORM
Begin DoDot:2
+23 KILL ^IBE(TO,"C",NEWFORM,BLOCK),DA
SET DIK="^IBE("_TO_","
SET DA=BLOCK
DO IX1^DIK
KILL DIK,DA
End DoDot:2
+24 IF '$TEST
DO DLTBLK^IBDFU3(BLOCK,NEWFORM,TO)
End DoDot:1
+25 ;
+26 ;copy old 0 node into the new form
+27 SET ^IBE(TOFILE,NEWFORM,0)=NODE
+28 ;
+29 ;now the page multiple
+30 SET NODE=$GET(^IBE(FROMFILE,OLDFORM,2,0))
+31 IF NODE'=""
SET $PIECE(NODE,"^",2)=TOFILE_".02I"
SET ^IBE(TOFILE,NEWFORM,2,0)=NODE
SET PAGE=0
FOR
SET PAGE=$ORDER(^IBE(FROMFILE,OLDFORM,2,PAGE))
if 'PAGE
QUIT
SET NODE=$GET(^IBE(FROMFILE,OLDFORM,2,PAGE,0))
if NODE'=""
SET ^IBE(TOFILE,NEWFORM,2,PAGE,0)=NODE
+32 ;
+33 ;copy the rest of the form
+34 SET NODE=0
FOR
SET NODE=$ORDER(^IBE(FROMFILE,OLDFORM,NODE))
if 'NODE
QUIT
if $GET(^IBE(FROMFILE,OLDFORM,NODE))=""
QUIT
SET ^IBE(TOFILE,NEWFORM,NODE)=$GET(^IBE(FROMFILE,OLDFORM,NODE))
+35 KILL DIK
SET DIK="^IBE("_TOFILE_","
SET DA=NEWFORM
DO IX^DIK
KILL DIK
+36 ;
+37 ;now copy the blocks into the form
+38 SET OLDBLOCK=""
FOR
SET OLDBLOCK=$ORDER(^IBE(FROM,"C",OLDFORM,OLDBLOCK))
if 'OLDBLOCK
QUIT
IF $PIECE($GET(^IBE(FROM,OLDBLOCK,0)),"^",2)=OLDFORM
SET NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,NEWFORM,FROM,TO)
WRITE "."
+39 QUIT NEWFORM
+40 ;
+41 ;
DELETE(FORM,FILE,ASK) ;deletes the FORM in FILE- if ASK then asks permission first
+1 if '$GET(FORM)
QUIT
+2 if (FILE'=357)&(FILE'=358)
QUIT
+3 IF $GET(ASK)
if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(FILE,FORM,0)),"^"))
QUIT
+4 NEW BLOCK,BLKFILE,CR
+5 ;might have to delete the bubble translation table
+6 IF FILE=357
Begin DoDot:1
+7 if '$$FORMDSCR^IBDFU1C(.FORM)
QUIT
+8 IF FORM("TYPE")
DO KILLTBL^IBDF19(.FORM)
End DoDot:1
+9 SET BLKFILE=FILE+.1
+10 SET BLOCK=""
FOR
SET BLOCK=$ORDER(^IBE(BLKFILE,"C",FORM,BLOCK))
if 'BLOCK
QUIT
DO DLTBLK^IBDFU3(BLOCK,FORM,BLKFILE)
WRITE "."
+11 IF FILE=357
FOR CR="AT","AC","AU","AG"
KILL ^IBE(357,CR,FORM)
+12 KILL DA
SET DIK="^IBE("_FILE_","
SET DA=FORM
DO ^DIK
KILL DIK,DA
+13 KILL FORM
+14 QUIT
NEWNAME(OLDNAME) ;asks the user to select a unique form name
+1 ;returns "" if unsuccessfull, else the form name
+2 ;shows OLDNAME as the default if defined
+3 ;
+4 NEW NAME,QUIT
SET NAME=""
SET QUIT=0
+5 KILL DIR
SET DIR(0)="357,.01A"
SET DIR("A")="New Form Name: "
SET DIR("?")="Enter a unique name up to 30 characters"
+6 SET DIR("B")=""
IF $GET(OLDNAME)'=""
IF '$ORDER(IBE(357,"B",OLDNAME,0))
SET DIR("B")=OLDNAME
+7 FOR
Begin DoDot:1
+8 DO ^DIR
IF $DATA(DIRUT)
SET QUIT=1
QUIT
+9 IF $ORDER(^IBE(357,"B",Y,""))
Begin DoDot:2
+10 WRITE !,"The form name must be unique, try using the clinic in the name!"
End DoDot:2
+11 IF '$TEST
SET NAME=Y
SET QUIT=1
End DoDot:1
if QUIT
QUIT
+12 KILL DIR
+13 QUIT NAME
TKFORM() ;returns the form TOOL KIT that contains all of the tool kit blocs
+1 NEW TKFORM,BLOCK,TKORDER,TK
+2 SET TKFORM=+$ORDER(^IBE(357,"B","TOOL KIT",""))
+3 IF 'TKFORM
Begin DoDot:1
+4 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357,"
SET DIC(0)=""
SET X="TOOL KIT"
+5 DO FILE^DICN
KILL DIC,DIE,DA
+6 SET TKFORM=$SELECT(+(Y>0):+Y,1:"")
+7 if 'TKFORM
QUIT
+8 SET ^IBE(357,TKFORM,0)="TOOL KIT^^CONTAINS ALL OF THE TOOL KIT BLOCKS^^^^1"
+9 KILL DIK
SET DIK="^IBE(357,"
SET DA=TKFORM
DO IX1^DIK
KILL DIK
+10 SET TKORDER=0
FOR
SET TKORDER=$ORDER(^IBE(357.1,"D",TKORDER))
if 'TKORDER
QUIT
SET BLOCK=0
FOR
SET BLOCK=$ORDER(^IBE(357.1,"D",TKORDER,BLOCK))
if 'BLOCK
QUIT
Begin DoDot:2
+11 SET TK=$PIECE($GET(^IBE(357.1,BLOCK,0)),"^",14)
IF 'TK
KILL ^IBE(357.1,"D",TKORDER,BLOCK)
QUIT
+12 SET FORM=$PIECE($GET(^IBE(357.1,BLOCK,0)),"^",2)
IF FORM'=TKFORM
KILL ^IBE(357.1,"C",FORM,BLOCK)
SET $PIECE(^IBE(357.1,BLOCK,0),"^",2)=TKFORM
KILL DIK
SET DIK="^IBE(357.1,"
SET DA=BLOCK
SET DIK(1)=.02
DO EN1^DIK
KILL DIK
End DoDot:2
End DoDot:1
+13 QUIT TKFORM
