source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFU2B.m@ 641

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

initial load of FOIAVistA 6/30/08 version
File size: 7.8 KB
Line 
1IBDFU2B ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks - continued from IBDFU2) ; 08-JAN-1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
3 ;
4CPYSLCTN(SLCTN,GRP,NEWGRP,LIST,NEWLIST,FROMFILE,TOFILE) ;
5 Q:('$G(SLCTN))!('$G(GRP))!('$G(NEWGRP))!('$G(LIST))!('$G(NEWLIST))!('$G(FROMFILE))!('$G(TOFILE))
6 Q:(FROMFILE'=357.3)&(FROMFILE'=358.3)
7 Q:(TOFILE'=357.3)&(TOFILE'=358.3)
8 N NODE,NAME,NEWSLCTN,SC,CNT,I
9 S NEWSLCTN=""
10 S NODE=$G(^IBE(FROMFILE,SLCTN,0)) Q:NODE=""
11 I ($P(NODE,"^",3)'=LIST)!($P(NODE,"^",4)'=GRP) K DA S DA=SLCTN,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
12 S NAME=$P(NODE,"^",1),$P(NODE,"^",3)=NEWLIST,$P(NODE,"^",4)=NEWGRP
13 Q:NAME=""
14 K DIC,DD,DINUM,DO S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
15 D FILE^DICN K DIC,DIE,DA
16 S NEWSLCTN=$S(+Y<0:"",1:+Y)
17 Q:'NEWSLCTN
18 S ^IBE(TOFILE,NEWSLCTN,0)=NODE
19 ;
20 ; -- now copy the subcolumn value multiple
21 ; -- When copying selections but not same list definition (i.e.
22 ; when copying selections from one list to another)
23 ; find old sub columns, in 357.2 for list
24 ; find and match to new sub columns in 357.2 for new list
25 ;
26 S (SC,CNT,LAST)=0
27 ;S NODE=$G(^IBE(FROMFILE,SLCTN,1,0)) I NODE'="" S ^IBE(TOFILE,NEWSLCTN,1,0)=NODE
28 F S SC=$O(^IBE(FROMFILE,SLCTN,1,SC)) Q:'SC S NODE=$G(^IBE(FROMFILE,SLCTN,1,SC,0)) D:$D(IBDFCPYF) S:NODE'="" ^IBE(TOFILE,NEWSLCTN,1,+NODE,0)=NODE,CNT=CNT+1,LAST=+NODE
29 .N K,IBDFI
30 .S K=0,IBDFI=+NODE
31 .Q:$G(IBDFNEW(IBDFI))=$G(IBDFOLD(IBDFI))
32 .F S K=$O(IBDFNEW(K)) Q:K="" I IBDFNEW(K)=$G(IBDFOLD(+IBDFI)) S $P(NODE,"^",1)=K,NODE=NODE Q
33 .Q
34 S ^IBE(TOFILE,NEWSLCTN,1,0)=$S(TOFILE=357.3:"^357.31IA^",1:"^358.31IA^")_$G(LAST)_"^"_CNT
35 ; -- now copy 2 node if it exists
36 S NODE=$G(^IBE(FROMFILE,SLCTN,2))
37 I NODE'="" S ^IBE(TOFILE,NEWSLCTN,2)=NODE
38 ;
39 ; -- now copy 3 node if it exists (CPT MODIFIERS)
40 ;
41 I $D(^IBE(FROMFILE,SLCTN,3)) D
42 . S ^IBE(TOFILE,NEWSLCTN,3,0)=^IBE(FROMFILE,SLCTN,3,0)
43 . F I=0:0 S I=$O(^IBE(FROMFILE,SLCTN,3,I)) Q:'I D
44 .. S:$D(^IBE(FROMFILE,SLCTN,3,I,0)) ^IBE(TOFILE,NEWSLCTN,3,I,0)=^(0)
45 ;
46 ; -- now re-index file entry
47 ;
48 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWSLCTN
49 D IX1^DIK
50 K DIK,DA
51 Q
52 ;
53GETMA(MA,FROMFILE,TOFILE) ;copys marking area=ma from file=FROMFILE to file=TOFILE if it does not already exist
54 ;returns the ien of the marking area existing in TOFILE
55 Q:($G(FROMFILE)'=357.91)&($G(FROMFILE)'=358.91) ""
56 Q:($G(TOFILE)'=357.91)&($G(TOFILE)'=358.91) ""
57 Q:'$G(MA) ""
58 Q:FROMFILE=TOFILE MA ;files are the same!
59 N NODE,NAME,NEWMA
60 S NEWMA=""
61 S NODE=$G(^IBE(FROMFILE,MA,0)) Q:NODE="" ""
62 S NAME=$P(NODE,"^",1)
63 Q:NAME="" ""
64 S NEWMA=$O(^IBE(TOFILE,"B",NAME,0)) Q:NEWMA NEWMA ;quit if it already exists
65 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
66 D FILE^DICN K DIC,DIE,DA
67 S NEWMA=$S(+Y<0:"",1:+Y)
68 Q:'NEWMA ""
69 S ^IBE(TOFILE,NEWMA,0)=NODE
70 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWMA
71 D IX1^DIK K DIK,DA
72 Q NEWMA
73 ;
74GETPI(PI,FROMFILE,TOFILE) ;copies the package interface=PI from file=FROMFILE to file=TOFILE if it doesn't already exist
75 ;returns the ien of the package interface in the TOFILE
76 Q:($G(FROMFILE)'=357.6)&($G(FROMFILE)'=358.6) ""
77 Q:($G(TOFILE)'=357.6)&($G(TOFILE)'=358.6) ""
78 Q:'$G(PI) ""
79 Q:FROMFILE=TOFILE PI
80 N NODE,NEWPI,SUB1,SUB2,RTN,ENTRYPT,TYPE
81 S NEWPI=""
82 S NODE=$G(^IBE(FROMFILE,PI,0)) Q:NODE="" ""
83 S NAME=$P(NODE,"^"),ENTRYPT=$P(NODE,"^",2),RTN=$P(NODE,"^",3),TYPE=$P(NODE,"^",6)
84 S NEWPI=$$LOOKUP(NAME,RTN,ENTRYPT,TOFILE,TYPE)
85 Q:NEWPI NEWPI ;quit if copy is not needed
86 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=$P(NODE,"^"),DIC(0)=""
87 Q:X="" "" ;corrupted data!
88 D FILE^DICN K DIC,DIE,DA
89 S NEWPI=$S(+Y<0:"",1:+Y)
90 Q:'NEWPI ""
91 ;
92 ;for display or selection interfaces, if the entry point does not exist the new package interface should be marked as unavailable
93 I (TYPE=2)!(TYPE=3) D
94 .I RTN="" S $P(NODE,"^",9)=0 Q
95 .I RTN'="" D
96 ..I ENTRYPT]"" I '$L($T(@ENTRYPT^@RTN)) S $P(NODE,"^",9)=0
97 ..I ENTRYPT="" I '$L($T(^@RTN)) S $P(NODE,"^",9)=0
98 ;
99 S ^IBE(TOFILE,NEWPI,0)=NODE
100 S:$P(NODE,"^",13) $P(NODE,"^",13)=$$GETPI($P(NODE,"^",13),$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
101 S ^IBE(TOFILE,NEWPI,0)=NODE
102 F SUB1=2,3,4,5,8,9,10,11,12,14,17,18,19,20,21 S NODE=$G(^IBE(FROMFILE,PI,SUB1)) I NODE'="" S ^IBE(TOFILE,NEWPI,SUB1)=NODE
103 S NODE=$G(^IBE(FROMFILE,PI,16)) I NODE'="" D
104 .N TYPEDATA
105 .S TYPEDATA=$P(NODE,"^",2)
106 .I TYPEDATA S $P(NODE,"^",2)=$$GETADE(TYPEDATA,$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1))
107 .S TYPEDATA=$P(NODE,"^",6)
108 .I TYPEDATA S $P(NODE,"^",6)=$$GETADE(TYPEDATA,$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1))
109 .S ^IBE(TOFILE,NEWPI,16)=NODE
110 F SUB1=1,6,7,15 S NODE=$G(^IBE(FROMFILE,PI,SUB1,0)) D
111 .I NODE'="" S ^IBE(TOFILE,NEWPI,SUB1,0)=NODE S SUB2=0 F S SUB2=$O(^IBE(FROMFILE,PI,SUB1,SUB2)) Q:'SUB2 S NODE=$G(^IBE(FROMFILE,PI,SUB1,SUB2,0)) I NODE'="" S ^IBE(TOFILE,NEWPI,SUB1,SUB2,0)=NODE
112 ;
113 D CPYQLFRS(FROMFILE,PI,TOFILE,NEWPI)
114 ;
115 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWPI
116 D IX1^DIK K DIK,DA
117 Q NEWPI
118 ;
119CPYQLFRS(FROMFILE,PI,TOFILE,NEWPI) ;copy allowable qualifiers from the package interface=PI in NEWPI to the package interface=NEWPI in TOFILE
120 ;
121 N NODE,SUB,VARPTR
122 K ^IBE(TOFILE,NEWPI,13)
123 S NODE=$G(^IBE(FROMFILE,PI,13,0)) I NODE'="" S ^IBE(TOFILE,NEWPI,13,0)=NODE S SUB=0 F S SUB=$O(^IBE(FROMFILE,PI,13,SUB)) Q:'SUB D
124 .S NODE=$G(^IBE(FROMFILE,PI,13,SUB,0)),VARPTR=$P(NODE,"^") I +VARPTR D I +VARPTR S $P(NODE,"^")=VARPTR,^IBE(TOFILE,NEWPI,13,SUB,0)=NODE
125 ..I VARPTR["IBE" S $P(VARPTR,";")=$$GETADE(+VARPTR,$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1)),$P(VARPTR,"(",2)=$S(TOFILE[358:358.99,1:359.1)_"," Q
126 ..I VARPTR["IBD" S $P(VARPTR,";")=$$GETQLFR(+VARPTR,$S(FROMFILE[358:358.98,1:357.98),$S(TOFILE[358:358.98,1:357.98)),$P(VARPTR,"(",2)=$S(TOFILE[358:358.98,1:357.98)_","
127 Q
128 ;
129LOOKUP(NAME,RTN,ENTRYPT,TOFILE,TYPE) ;return 1 if the package interface already exists in TOFILE, 0 otherwise
130 N PI,LOOKNODE,QUIT
131 Q:NAME="" ""
132 S (QUIT,PI)=0 F S PI=$O(^IBE(TOFILE,"B",$E(NAME,1,30),PI)) Q:'PI S LOOKNODE=$G(^IBE(TOFILE,PI,0)) I LOOKNODE'="" D Q:QUIT
133 .I NAME=$P(LOOKNODE,"^"),RTN=$P(LOOKNODE,"^",3),ENTRYPT=$P(LOOKNODE,"^",2),TYPE=$P(LOOKNODE,"^",6) S QUIT=1 Q ;matches!
134 Q PI
135 ;
136GETQLFR(QLFR,FROMFILE,TOFILE) ;copys qualifier=QLFR from file=FROMFILE to file=TOFILE if it does not already exist
137 ;returns the ien of the qualifier existing in TOFILE
138 Q:($G(FROMFILE)'=357.98)&($G(FROMFILE)'=358.98) ""
139 Q:($G(TOFILE)'=357.98)&($G(TOFILE)'=358.98) ""
140 Q:'$G(QLFR) ""
141 Q:FROMFILE=TOFILE QLFR ;files are the same!
142 N NODE,NAME,NEWQLFR
143 S NEWQLFR=""
144 S NODE=$G(^IBD(FROMFILE,QLFR,0)) Q:NODE="" ""
145 S NAME=$P(NODE,"^",1)
146 Q:NAME="" ""
147 ;does it already exist?
148 S NEWQLFR=0 F S NEWQLFR=$O(^IBD(TOFILE,"B",$E(NAME,1,30),NEWQLFR)) Q:'NEWQLFR Q:$P($G(^IBD(TOFILE,NEWQLFR,0)),"^")=NAME
149 Q:NEWQLFR NEWQLFR ;quit if it already exists
150 K DIC,DO,DINUM,DD S DIC="^IBD("_TOFILE_",",X=NAME,DIC(0)=""
151 D FILE^DICN K DIC,DIE,DA
152 S NEWQLFR=$S(+Y<0:"",1:+Y)
153 Q:'NEWQLFR ""
154 S ^IBD(TOFILE,NEWQLFR,0)=NODE
155 K DIK,DA S DIK="^IBD("_TOFILE_",",DA=NEWQLFR
156 D IX1^DIK K DIK,DA
157 Q NEWQLFR
158 ;
159GETADE(ADE,FROMFILE,TOFILE) ;copys AICS Data Element=ADE from file=FROMFILE to file=TOFILE if it does not already exist
160 ;returns the ien of the qualifier existing in TOFILE
161 Q:($G(FROMFILE)'=359.1)&($G(FROMFILE)'=358.99) ""
162 Q:($G(TOFILE)'=359.1)&($G(TOFILE)'=358.99) ""
163 Q:'$G(ADE) ""
164 Q:FROMFILE=TOFILE ADE ;files are the same!
165 N NODE,NAME,NEWADE,SUB
166 S NEWADE=""
167 S NODE=$G(^IBE(FROMFILE,ADE,0)) Q:NODE="" ""
168 S NAME=$P(NODE,"^",1)
169 Q:NAME="" ""
170 S NEWADE=$O(^IBE(TOFILE,"B",NAME,0)) Q:NEWADE NEWADE ;quit if it already exists
171 K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
172 D FILE^DICN K DIC,DIE,DA
173 S NEWADE=$S(+Y<0:"",1:+Y)
174 Q:'NEWADE ""
175 S ^IBE(TOFILE,NEWADE,0)=NODE
176 ;
177 ; -- 9/28/95 add 10 node to be moved for moved fields
178 F SUB=1,2,3,10 S NODE=$G(^IBE(FROMFILE,ADE,SUB)) I NODE'="" S ^IBE(TOFILE,NEWADE,SUB)=NODE
179 K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWADE
180 D IX1^DIK K DIK,DA
181 Q NEWADE
Note: See TracBrowser for help on using the repository browser.