source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFU3.m@ 1696

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

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1IBDFU3 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(deleting blocks) ; 08-JAN-1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4DLTBLK(BLOCK,FORM,FILE) ;deletes BLOCK (in FILE) if not part of the toolkit (unless IBTKBLK=1) and, if FORM is passed in, the block actually is on FORM
5 Q:('$G(BLOCK))
6 Q:(FILE'=357.1)&(FILE'=358.1)
7 N NODE,DIK,DA
8 S NODE=$G(^IBE(FILE,BLOCK,0))
9 K DA S DA=BLOCK,DIK="^IBE("_FILE_","
10 ;don't delete it if part of the toolkit or doesn't belong to the form (messed up cross-references), unless IBTKBLK=1 (means deletion is durring special option for editing the tk)
11 G:$G(IBTKBLK) JUSTDOIT
12 I ($P(NODE,"^",14)) D Q
13 .S $P(^IBE(FILE,BLOCK,0),"^",2)=$O(^IBE(FILE\1,"B","TOOL KIT",""))
14 .I $G(FORM)'="" K ^IBE(FILE,"C",FORM,BLOCK) D IX1^DIK
15 I $G(FORM)'="",($P(NODE,"^",2)'=FORM) D Q
16 .;don't delete it - instead re-index it and quit
17 .K ^IBE(FILE,"C",FORM,BLOCK) D IX1^DIK
18JUSTDOIT ;
19 ;delete its components
20 D DLTCNTNT(BLOCK,FILE)
21 ;delete the block (DIC,DA are newed)
22 D ^DIK
23 Q
24 ;
25DLTCNTNT(BLOCK,FILE) ;delete everything in BLOCK, but not the block itself
26 Q:('$G(BLOCK))!('$G(FILE))
27 Q:(FILE'=357.1)&(FILE'=358.1)
28 N LIST,FLD,LINE,TEXT,TARGET,DIK,DA
29 ;delete selection lists from BLOCK
30 S TARGET=$S(FILE[358:358.2,1:357.2)
31 S LIST="" F S LIST=$O(^IBE(TARGET,"C",BLOCK,LIST)) Q:'LIST D DLTLIST(TARGET,BLOCK,LIST)
32 ;delete data fields
33 S TARGET=$S(FILE[358:358.5,1:357.5)
34 S FLD="" F S FLD=$O(^IBE(TARGET,"C",BLOCK,FLD)) Q:'FLD D DLTFLD(TARGET,BLOCK,FLD)
35 ;delete multiple choice fields
36 S TARGET=$S(FILE[358:358.93,1:357.93)
37 S FLD="" F S FLD=$O(^IBE(TARGET,"C",BLOCK,FLD)) Q:'FLD D DLTIFLD(TARGET,BLOCK,FLD)
38 ;delete hand print fields
39 S TARGET=$S(FILE[358:358.94,1:359.94)
40 S FLD="" F S FLD=$O(^IBE(TARGET,"C",BLOCK,FLD)) Q:'FLD D DLTHFLD(TARGET,BLOCK,FLD)
41 ;delete lines
42 S TARGET=$S(FILE[358:358.7,1:357.7)
43 S LINE="" F S LINE=$O(^IBE(TARGET,"C",BLOCK,LINE)) Q:'LINE D DLTLINE(TARGET,BLOCK,LINE)
44 ;delete text areas
45 S TARGET=$S(FILE[358:358.8,1:357.8)
46 S TEXT="" F S TEXT=$O(^IBE(TARGET,"C",BLOCK,TEXT)) Q:'TEXT D DLTTEXT(TARGET,BLOCK,TEXT)
47 Q
48 ;
49DLTLIST(FILE,BLOCK,LIST) ;delete the LIST, its selections and groups
50 Q:'$G(LIST)!'$G(BLOCK)!(($G(FILE)'=357.2)&($G(FILE)'=358.2))
51 N GRP,SLCTN,DIK,DA
52 S DIK="^IBE("_FILE_",",DA=LIST
53 ;don't delete it if it does not belong to BLOCK - instead, reindex it and quit
54 I $P($G(^IBE(FILE,LIST,0)),"^",2)'=BLOCK K ^IBE(FILE,"C",BLOCK,LIST) D IX1^DIK Q
55 ;delete its contents(DIK,DA are newed)
56 D DLISTCNT(LIST,FILE)
57 ;delete the list
58 D ^DIK
59 Q
60DLISTCNT(LIST,FILE) ;delete the list's selections and groups
61 N GRP,SLCTN,DIK,DA,GFILE,SFILE
62 Q:('$G(LIST))!('$G(FILE))
63 Q:(FILE'=357.2)&(FILE'=358.2)
64 S GFILE=$S(FILE[358:358.4,1:357.4)
65 S SFILE=$S(FILE[358:358.3,1:357.3)
66 ;now delete list's contents
67 S GRP="" F S GRP=$O(^IBE(GFILE,"D",LIST,GRP)) Q:'GRP S DA=GRP D
68 .I $P($G(^IBE(GFILE,GRP,0)),"^",3)=LIST D
69 ..S DIK="^IBE("_GFILE_"," D ^DIK
70 ..S SLCTN="",DIK="^IBE("_SFILE_"," F S SLCTN=$O(^IBE(SFILE,"D",GRP,SLCTN)) Q:'SLCTN S DA=SLCTN D
71 ...I $P($G(^IBE(SFILE,SLCTN,0)),"^",4)=GRP D
72 ....D ^DIK
73 ...E K ^IBE(SFILE,"C",LIST,SLCTN) D IX1^DIK
74 .;
75 .E K ^IBE(GFILE,"D",LIST,GRP) D IX1^DIK
76 S SLCTN="",DIK="^IBE("_SFILE_"," F S SLCTN=$O(^IBE(SFILE,"C",LIST,SLCTN)) Q:'SLCTN S DA=SLCTN D
77 .I $P($G(^IBE(SFILE,SLCTN,0)),"^",3)=LIST D
78 ..D ^DIK
79 .E K ^IBE(SFILE,"C",LIST,SLCTN) D IX1^DIK
80 Q
81 ;
82DLTFLD(FILE,BLOCK,FLD) ;delete a display field
83 Q:('$G(BLOCK))!('$G(FLD))!('$G(FILE))
84 Q:(FILE'=357.5)&(FILE'=358.5)
85 N DA,DIK
86 S DIK="^IBE("_FILE_",",DA=FLD
87 I $P($G(^IBE(FILE,FLD,0)),"^",2)=BLOCK D
88 .D ^DIK
89 E K ^IBE(FILE,"C",BLOCK,FLD) D IX1^DIK
90 Q
91 ;
92DLTIFLD(FILE,BLOCK,FLD) ;delete a multiple choice field
93 Q:('$G(BLOCK))!('$G(FLD))!('$G(FILE))
94 Q:(FILE'=357.93)&(FILE'=358.93)
95 N DA,DIK
96 S DIK="^IBE("_FILE_",",DA=FLD
97 I $P($G(^IBE(FILE,FLD,0)),"^",8)=BLOCK D
98 .D ^DIK
99 E K ^IBE(FILE,"C",BLOCK,FLD) D IX1^DIK
100 Q
101DLTHFLD(FILE,BLOCK,FLD) ;delete a hand print field
102 Q:('$G(BLOCK))!('$G(FLD))!('$G(FILE))
103 Q:(FILE'=359.94)&(FILE'=358.94)
104 N DA,DIK
105 S DIK="^IBE("_FILE_",",DA=FLD
106 I $P($G(^IBE(FILE,FLD,0)),"^",8)=BLOCK D
107 .D ^DIK
108 E K ^IBE(FILE,"C",BLOCK,FLD) D IX1^DIK
109 Q
110 ;
111DLTTEXT(FILE,BLOCK,TEXT) ;delete the TEXT AREA
112 Q:('$G(BLOCK))!('$G(TEXT))!('$G(FILE))
113 Q:(FILE'=357.8)&(FILE'=358.8)
114 N DA,DIK
115 S DIK="^IBE("_FILE_",",DA=TEXT
116 I $P($G(^IBE(FILE,TEXT,0)),"^",2)=BLOCK D
117 .D ^DIK
118 E K ^IBE(FILE,"C",BLOCK,TEXT) D IX1^DIK
119 Q
120DLTLINE(FILE,BLOCK,LINE) ;delete the line
121 Q:('$G(BLOCK))!('$G(LINE))!('$G(FILE))
122 Q:(FILE'=357.7)&(FILE'=358.7)
123 N DA,DIK
124 S DIK="^IBE("_FILE_",",DA=LINE
125 I $P($G(^IBE(FILE,LINE,0)),"^",6)=BLOCK D
126 .D ^DIK
127 E K ^IBE(FILE,"C",BLOCK,LINE) D IX1^DIK
128 Q
129FASTEXIT ;just sets a flag signaling system should be exited
130 S VALMBCK="Q"
131 K DIR S DIR(0)="Y",DIR("A")="Exit Encounter Form Option",DIR("B")="NO" D ^DIR
132 I $D(DIRUT)!(Y) S IBFASTXT=1
133 K DIR
134 Q
Note: See TracBrowser for help on using the repository browser.