source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFU2A.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1IBDFU2A ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks - continued from IBDFU2) ; 08-JAN-1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4COPYLINE(LINE,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copys LINE from OLDBLOCK,FROMFILE to newly created NEWBLOCK,TOFILE
5 Q:('$G(LINE))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
6 Q:(FROMFILE'=357.7)&(FROMFILE'=358.7)
7 Q:(TOFILE'=357.7)&(TOFILE'=358.7)
8 N NODE,NAME,NEWLINE
9 S NEWLINE=""
10 S NODE=$G(^IBE(FROMFILE,LINE,0)) Q:NODE=""
11 ;make sure the line really belongs to the block being copied - if not re-index it
12 I $P(NODE,"^",6)'=OLDBLOCK K DA S DA=LINE,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
13 S NAME=$P(NODE,"^",1),$P(NODE,"^",6)=NEWBLOCK
14 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
15 D FILE^DICN K DIC,DIE,DA
16 S NEWLINE=$S(+Y<0:"",1:+Y)
17 Q:'NEWLINE
18 S ^IBE(TOFILE,NEWLINE,0)=NODE
19 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWLINE
20 D IX1^DIK K DIK,DA
21 Q
22 ;
23COPYTEXT(TEXT,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies TEXT in OLDBLOCK,FROMFILE to NEWBLOCK,TOFILE
24 Q:('$G(TEXT))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
25 Q:(FROMFILE'=357.8)&(FROMFILE'=358.8)
26 Q:(TOFILE'=357.8)&(TOFILE'=358.8)
27 N NODE,NAME,NEWTEXT,TLINE
28 S NEWTEXT=""
29 S NODE=$G(^IBE(FROMFILE,TEXT,0)) Q:NODE=""
30 ;make sure the text area really belongs to the block being copied - re-index if not
31 I ($P(NODE,"^",2)'=OLDBLOCK) K DA S DA=TEXT,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
32 S NAME=$P(NODE,"^",1),$P(NODE,"^",2)=NEWBLOCK
33 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
34 D FILE^DICN K DIC,DIE,DA
35 S NEWTEXT=$S(+Y<0:"",1:+Y)
36 Q:'NEWTEXT
37 S ^IBE(TOFILE,NEWTEXT,0)=NODE
38 ;now copy the word-processing field
39 S NODE=$G(^IBE(FROMFILE,TEXT,1,0)) I NODE'="" S ^IBE(TOFILE,NEWTEXT,1,0)=NODE S TLINE=0 F S TLINE=$O(^IBE(FROMFILE,TEXT,1,TLINE)) Q:'TLINE S NODE=$G(^IBE(FROMFILE,TEXT,1,TLINE,0)) S:NODE'="" ^IBE(TOFILE,NEWTEXT,1,TLINE,0)=NODE
40 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWTEXT
41 D IX1^DIK K DIK,DA
42 Q
43 ;
44COPYFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies a display field=FLD in FROMFILE to NEWBLOCK in TOFILE
45 Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
46 Q:(FROMFILE'=357.5)&(FROMFILE'=358.5)
47 Q:(TOFILE'=357.5)&(TOFILE'=358.5)
48 N NODE,NAME,NEWFLD,SUBFLD
49 S NEWFLD=""
50 S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
51 ;make sure the field really belongs to the block being copied - if not re-index it
52 I ($P(NODE,"^",2)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
53 S NAME=$P(NODE,"^",1),$P(NODE,"^",2)=NEWBLOCK
54 Q:NAME="" ;corrupted data
55 S:$P(NODE,"^",3) $P(NODE,"^",3)=$$GETPI^IBDFU2B($P(NODE,"^",3),$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
56 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
57 D FILE^DICN K DIC,DIE,DA
58 S NEWFLD=$S(+Y<0:"",1:+Y)
59 Q:'NEWFLD
60 S ^IBE(TOFILE,NEWFLD,0)=NODE
61 ;now copy the subfields
62 S NODE=$G(^IBE(FROMFILE,FLD,2,0))
63 I NODE'="" S $P(NODE,"^",2)=TOFILE_2,^IBE(TOFILE,NEWFLD,2,0)=NODE S SUBFLD=0 F S SUBFLD=$O(^IBE(FROMFILE,FLD,2,SUBFLD)) Q:'SUBFLD S NODE=$G(^IBE(FROMFILE,FLD,2,SUBFLD,0)) S:NODE'="" ^IBE(TOFILE,NEWFLD,2,SUBFLD,0)=NODE
64 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
65 D IX1^DIK K DIK,DA
66 Q
67 ;
68COPYMFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies MUTLIPLE CHOICE FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
69 Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
70 Q:(FROMFILE'=357.93)&(FROMFILE'=358.93)
71 Q:(TOFILE'=357.93)&(TOFILE'=358.93)
72 N NODE,NAME,NEWFLD,SUBFLD,FROMPI
73 S NEWFLD=""
74 S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
75 ;make sure the field really belongs to the block being copied - if not re-index it
76 I ($P(NODE,"^",8)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
77 S NAME=$P(NODE,"^",1),$P(NODE,"^",8)=NEWBLOCK
78 Q:NAME="" ;corrupted data
79 S FROMPI=$P(NODE,"^",6)
80 S:FROMPI $P(NODE,"^",6)=$$GETPI^IBDFU2B(FROMPI,$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
81 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
82 D FILE^DICN K DIC,DIE,DA
83 S NEWFLD=$S(+Y<0:"",1:+Y)
84 Q:'NEWFLD
85 S ^IBE(TOFILE,NEWFLD,0)=NODE
86 ;
87 ;now copy the subfields=the choices
88 ;don't copy choices for export if there is no package interface or choices are not exportable
89 I FROMPI,(FROMFILE=TOFILE)!($P($G(^IBE($S(FROMFILE[358:358.6,1:357.6),FROMPI,2)),"^",18)) D
90 .S NODE=$G(^IBE(FROMFILE,FLD,1,0)) I NODE'="" S $P(NODE,"^",2)=TOFILE_1,^IBE(TOFILE,NEWFLD,1,0)=NODE S SUBFLD=0 F S SUBFLD=$O(^IBE(FROMFILE,FLD,1,SUBFLD)) Q:'SUBFLD S NODE=$G(^IBE(FROMFILE,FLD,1,SUBFLD,0)) D
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))
92 ..S:NODE'="" ^IBE(TOFILE,NEWFLD,1,SUBFLD,0)=NODE
93 ;
94 ;index the new field
95 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
96 D IX1^DIK
97 K DIK,DA
98 Q
99 ;
100COPYHFLD(FLD,OLDBLOCK,NEWBLOCK,FROMFILE,TOFILE) ;copies HAND PRINT FIELD=FLD in FROMFILE to NEWBLOCK in TOFILE
101 Q:('$G(FLD))!('$G(OLDBLOCK))!('$G(NEWBLOCK))!('$G(FROMFILE))!('$G(TOFILE))
102 Q:(FROMFILE'=359.94)&(FROMFILE'=358.94)
103 Q:(TOFILE'=359.94)&(TOFILE'=358.94)
104 N NODE,NAME,NEWFLD,SUBFLD
105 S NEWFLD=""
106 S NODE=$G(^IBE(FROMFILE,FLD,0)) Q:NODE=""
107 ;make sure the field really belongs to the block being copied - if not re-index it
108 I ($P(NODE,"^",8)'=OLDBLOCK) K DA S DA=FLD,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
109 S NAME=$P(NODE,"^",1),$P(NODE,"^",8)=NEWBLOCK
110 Q:NAME="" ;corrupted data
111 S:$P(NODE,"^",6) $P(NODE,"^",6)=$$GETPI^IBDFU2B($P(NODE,"^",6),$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
112 S:$P(NODE,"^",10) $P(NODE,"^",10)=$$GETADE^IBDFU2B($P(NODE,"^",10),$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1))
113 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
114 D FILE^DICN K DIC,DIE,DA
115 S NEWFLD=$S(+Y<0:"",1:+Y)
116 Q:'NEWFLD
117 S ^IBE(TOFILE,NEWFLD,0)=NODE
118 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWFLD
119 D IX1^DIK K DIK,DA
120 Q
121 ;
122COPYGRP(GRP,LIST,NEWLIST,BLOCK,FROMFILE,TOFILE) ;
123 Q:(FROMFILE'=357.4)&(FROMFILE'=358.4)
124 Q:(TOFILE'=357.4)&(TOFILE'=358.4)
125 N NODE,HDR,NEWGRP,SLCTN,FROM,TO
126 S NEWGRP=""
127 S NODE=$G(^IBE(FROMFILE,GRP,0)) Q:NODE=""
128 ;make sure group belongs to list - otherwise re-index
129 I $P(NODE,"^",3)'=LIST K DA S DA=GRP,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
130 S HDR=$P(NODE,"^",1),$P(NODE,"^",3)=NEWLIST
131 Q:HDR=""
132 K DIC,DD,DO,DINUM S DIC="^IBE("_TOFILE_",",X=HDR,DIC(0)=""
133 D FILE^DICN K DIC,DIE,DA
134 S NEWGRP=$S(+Y<0:"",1:+Y)
135 Q:'NEWGRP
136 S ^IBE(TOFILE,NEWGRP,0)=NODE
137 S NODE=0 F S NODE=$O(^IBE(FROMFILE,GRP,NODE)) Q:'NODE S ^IBE(TOFILE,NEWGRP,NODE)=$G(^IBE(FROMFILE,GRP,NODE))
138 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWGRP
139 D IX1^DIK K DIK,DA
140 S FROM=$S(FROMFILE[358:358.3,1:357.3),TO=$S(TOFILE[358:358.3,1:357.3)
141 S SLCTN="" F S SLCTN=$O(^IBE(FROM,"D",GRP,SLCTN)) Q:'SLCTN D CPYSLCTN^IBDFU2B(SLCTN,GRP,NEWGRP,LIST,NEWLIST,FROM,TO)
142 Q
Note: See TracBrowser for help on using the repository browser.