source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFU2C.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
Line 
1IBDFU2C ;ALB/CJM - ENCOUNTER FORM - (COPYING FORMS) ;AUG12,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4COPYFORM(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 ;
46DELETE(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
61NEWNAME(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
75TKFORM() ;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
Note: See TracBrowser for help on using the repository browser.