| 1 | IBDFU2C ;ALB/CJM - ENCOUNTER FORM - (COPYING FORMS) ;AUG12,1993
|
|---|
| 2 | ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
|
|---|
| 3 | ;
|
|---|
| 4 | COPYFORM(OLDFORM,FROMFILE,TOFILE,NEWNAME,TK) ;
|
|---|
| 5 | ;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
|
|---|
| 6 | ;
|
|---|
| 7 | Q:'$D(OLDFORM)!'$D(FROMFILE)!'$D(TOFILE) ""
|
|---|
| 8 | Q:(FROMFILE'=357)&(FROMFILE'=358) ""
|
|---|
| 9 | Q:(TOFILE'=357)&(TOFILE'=358) ""
|
|---|
| 10 | Q:'OLDFORM ""
|
|---|
| 11 | N NEWFORM,NODE,OLDBLOCK,NEWBLOCK,BLOCK,IBDELETE,FROM,TO,PAGE
|
|---|
| 12 | S NODE=$G(^IBE(FROMFILE,OLDFORM,0)) Q:NODE="" ""
|
|---|
| 13 | S:($G(NEWNAME)'="") $P(NODE,"^")=NEWNAME
|
|---|
| 14 | S:$G(NEWNAME)="" NEWNAME=$P(NODE,"^")
|
|---|
| 15 | I $G(TK)=+$G(TK) S $P(NODE,"^",7)=TK
|
|---|
| 16 | S $P(NODE,"^",5)=0,$P(NODE,"^",13)=""
|
|---|
| 17 | K DIC,DD,DO,DINUM S DIC="^IBE("_TOFILE_",",X=NEWNAME,DIC(0)=""
|
|---|
| 18 | D FILE^DICN K DIC,DIE
|
|---|
| 19 | S NEWFORM=$S(+Y<0:"",1:+Y)
|
|---|
| 20 | I (NEWFORM<0) W !,"Unable to create a new form!" D PAUSE^IBDFU5 Q ""
|
|---|
| 21 | ;
|
|---|
| 22 | ;the new form should be empty - make sure
|
|---|
| 23 | S FROM=$S(FROMFILE[358:358.1,1:357.1)
|
|---|
| 24 | S TO=$S(TOFILE[358:358.1,1:357.1)
|
|---|
| 25 | S BLOCK="" F S BLOCK=$O(^IBE(TOFILE,"C",NEWFORM,BLOCK)) Q:'BLOCK D
|
|---|
| 26 | .I $P($G(^IBE(TO,BLOCK,0)),"^",2)'=NEWFORM D
|
|---|
| 27 | ..K ^IBE(TO,"C",NEWFORM,BLOCK),DA S DIK="^IBE("_TO_",",DA=BLOCK D IX1^DIK K DIK,DA
|
|---|
| 28 | .E D DLTBLK^IBDFU3(BLOCK,NEWFORM,TO)
|
|---|
| 29 | ;
|
|---|
| 30 | ;copy old 0 node into the new form
|
|---|
| 31 | S ^IBE(TOFILE,NEWFORM,0)=NODE
|
|---|
| 32 | ;
|
|---|
| 33 | ;now the page multiple
|
|---|
| 34 | S NODE=$G(^IBE(FROMFILE,OLDFORM,2,0))
|
|---|
| 35 | 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
|
|---|
| 36 | ;
|
|---|
| 37 | ;copy the rest of the form
|
|---|
| 38 | 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))
|
|---|
| 39 | K DIK S DIK="^IBE("_TOFILE_",",DA=NEWFORM D IX^DIK K DIK
|
|---|
| 40 | ;
|
|---|
| 41 | ;now copy the blocks into the form
|
|---|
| 42 | 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 "."
|
|---|
| 43 | Q NEWFORM
|
|---|
| 44 | ;
|
|---|
| 45 | ;
|
|---|
| 46 | DELETE(FORM,FILE,ASK) ;deletes the FORM in FILE- if ASK then asks permission first
|
|---|
| 47 | Q:'$G(FORM)
|
|---|
| 48 | Q:(FILE'=357)&(FILE'=358)
|
|---|
| 49 | I $G(ASK) Q:'$$RUSURE^IBDFU5($P($G(^IBE(FILE,FORM,0)),"^"))
|
|---|
| 50 | N BLOCK,BLKFILE,CR
|
|---|
| 51 | ;might have to delete the bubble translation table
|
|---|
| 52 | I FILE=357 D
|
|---|
| 53 | .Q:'$$FORMDSCR^IBDFU1C(.FORM)
|
|---|
| 54 | .I FORM("TYPE") D KILLTBL^IBDF19(.FORM)
|
|---|
| 55 | S BLKFILE=FILE+.1
|
|---|
| 56 | S BLOCK="" F S BLOCK=$O(^IBE(BLKFILE,"C",FORM,BLOCK)) Q:'BLOCK D DLTBLK^IBDFU3(BLOCK,FORM,BLKFILE) W "."
|
|---|
| 57 | I FILE=357 F CR="AT","AC","AU","AG" K ^IBE(357,CR,FORM)
|
|---|
| 58 | K DA S DIK="^IBE("_FILE_",",DA=FORM D ^DIK K DIK,DA
|
|---|
| 59 | K FORM
|
|---|
| 60 | Q
|
|---|
| 61 | NEWNAME(OLDNAME) ;asks the user to select a unique form name
|
|---|
| 62 | ;returns "" if unsuccessfull, else the form name
|
|---|
| 63 | ;shows OLDNAME as the default if defined
|
|---|
| 64 | ;
|
|---|
| 65 | N NAME,QUIT S NAME="",QUIT=0
|
|---|
| 66 | K DIR S DIR(0)="357,.01A",DIR("A")="New Form Name: ",DIR("?")="Enter a unique name up to 30 characters"
|
|---|
| 67 | S DIR("B")="" I $G(OLDNAME)'="",'$O(IBE(357,"B",OLDNAME,0)) S DIR("B")=OLDNAME
|
|---|
| 68 | F D Q:QUIT
|
|---|
| 69 | .D ^DIR I $D(DIRUT) S QUIT=1 Q
|
|---|
| 70 | .I $O(^IBE(357,"B",Y,"")) D
|
|---|
| 71 | ..W !,"The form name must be unique, try using the clinic in the name!"
|
|---|
| 72 | .E S NAME=Y,QUIT=1
|
|---|
| 73 | K DIR
|
|---|
| 74 | Q NAME
|
|---|
| 75 | TKFORM() ;returns the form TOOL KIT that contains all of the tool kit blocs
|
|---|
| 76 | N TKFORM,BLOCK,TKORDER,TK
|
|---|
| 77 | S TKFORM=+$O(^IBE(357,"B","TOOL KIT",""))
|
|---|
| 78 | I 'TKFORM D
|
|---|
| 79 | .K DIC,DD,DO,DINUM S DIC="^IBE(357,",DIC(0)="",X="TOOL KIT"
|
|---|
| 80 | .D FILE^DICN K DIC,DIE,DA
|
|---|
| 81 | .S TKFORM=$S(+(Y>0):+Y,1:"")
|
|---|
| 82 | .Q:'TKFORM
|
|---|
| 83 | .S ^IBE(357,TKFORM,0)="TOOL KIT^^CONTAINS ALL OF THE TOOL KIT BLOCKS^^^^1"
|
|---|
| 84 | .K DIK S DIK="^IBE(357,",DA=TKFORM D IX1^DIK K DIK
|
|---|
| 85 | .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
|
|---|
| 86 | ..S TK=$P($G(^IBE(357.1,BLOCK,0)),"^",14) I 'TK K ^IBE(357.1,"D",TKORDER,BLOCK) Q
|
|---|
| 87 | ..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
|
|---|
| 88 | Q TKFORM
|
|---|
