source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD1.m@ 794

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

initial load of FOIAVistA 6/30/08 version
File size: 7.5 KB
Line 
1TIUDD1 ; SLC/JER - XREFs for file 8925.1 ;19-OCT-2001 10:05:37 [7/28/04 9:08am]
2 ;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163,224**;Jun 20, 1997;Build 7
3SACL(X,FLD) ; Set logic for ACL cross-reference
4 ; Called from fields .01 (NAME), .07 (STATUS), .03 (PRINT NAME),
5 ; .02 (ABBREVIATION), and Subfield .01 of ITEM sub-file
6 N TIUCLASS,TIUSTTS,TIUTTL
7 I FLD=10.01 D
8 . ; Include only TITLES in the index
9 . I $P($G(^TIU(8925.1,+X,0)),U,4)'="DOC" Q
10 . S TIUSTTS=$P($G(^TIU(8925.1,+X,0)),U,7)
11 . ; Include only TEST or ACTIVE titles
12 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
13 . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U)
14 . Q:TIUTTL']""
15 . ; First build x-ref for Clinical Documents & Immediate descendents
16 . S TIUCLASS=+$$CLINDOC^TIULC1(+X)
17 . I TIUCLASS'>0 Q
18 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)=""
19 . S ^TIU(8925.1,"ACL",38,TIUTTL,+X)=""
20 . D SACLKWIC(TIUTTL,TIUCLASS,+X)
21 . ; Now build x-ref for document classes
22 . S TIUCLASS=+$$DOCCLASS^TIULC1(+X)
23 . I TIUCLASS'>0 Q
24 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)=""
25 . D SACLKWIC(TIUTTL,TIUCLASS,+X)
26 ; For Abbreviation and Print Name fields, just set the Synonym subscript
27 I $S(FLD=.02:1,FLD=.03:1,1:0) D Q
28 . N TIUDA
29 . Q:X']""
30 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
31 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
32 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
33 . ;VMPELR P 224 allow the update of inactive titles
34 . ; Include only TEST or ACTIVE or INACTIVE TITLES
35 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
36 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
37 . Q:TIUTTL']""
38 . S X=$$UP^XLFSTR(X)
39 . Q:X=TIUTTL
40 . S TIUTTL=X_" <"_TIUTTL_">"
41 . ; First build x-ref for Clinical Documents & Immediate descendents
42 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
43 . I TIUCLASS'>0 Q
44 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
45 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
46 . ; Now build x-ref for document classes
47 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
48 . I TIUCLASS'>0 Q
49 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
50 I FLD=.07 D Q
51 . N TIUDA
52 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
53 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
54 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
55 . ; Include only TEST or ACTIVE titles
56 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
57 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
58 . Q:TIUTTL']""
59 . ; First build x-ref for Clinical Documents & Immediate descendents
60 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
61 . I TIUCLASS'>0 Q
62 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
63 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
64 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
65 . ; Now build x-ref for document classes
66 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
67 . I TIUCLASS'>0 Q
68 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
69 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
70 I FLD=.01 D
71 . N TIUDA
72 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
73 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
74 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
75 . ; Include only TEST or ACTIVE OR inactive titles
76 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
77 . ; First build x-ref for Clinical Documents & Immediate descendents
78 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
79 . I TIUCLASS'>0 Q
80 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
81 . S ^TIU(8925.1,"ACL",38,X,+TIUDA)=""
82 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
83 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)=""
84 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
85 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)=""
86 . D SACLKWIC(X,TIUCLASS,+TIUDA)
87 . ; Now build x-ref for document classes
88 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
89 . I TIUCLASS'>0 Q
90 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
91 . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
92 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
93 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)=""
94 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
95 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""
96 . D SACLKWIC(X,TIUCLASS,+TIUDA)
97 Q
98SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog
99 N TIUI,TIUJ,TIUC S TIUI=1
100 F TIUJ=1:1:$L(X)+1 D
101 . S TIUC=$E(X,TIUJ)
102 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1
103 . I I $L(TIUC)>2,(^DD("KWIC")'[TIUC),(TIUC'=X) S (^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA))=""
104 Q
105KACL(X,FLD) ; KILL Logic for ACL cross-reference
106 N TIUCLASS,TIUTTL,TIUDA
107 I FLD=10.01 D
108 . ; First remove x-ref for Clinical Documents & Immediate descendents
109 . S TIUCLASS=+$$CLINDOC^TIULC1(+X)
110 . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U)
111 . Q:TIUTTL']""
112 . Q:X=TIUTTL
113 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
114 . K ^TIU(8925.1,"ACL",38,TIUTTL,+X)
115 . D KACLKWIC(TIUTTL,TIUCLASS,+X)
116 . ; Now remove x-ref for document classes
117 . S TIUCLASS=+$$DOCCLASS^TIULC1(+X)
118 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
119 . D KACLKWIC(TIUTTL,TIUCLASS,+X)
120 I $S(FLD=.02:1,FLD=.03:1,1:0) D Q
121 . N TIUDA
122 . Q:X']""
123 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
124 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
125 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
126 . ; Include only TEST or ACTIVE or INACTIVE titles
127 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
128 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
129 . Q:TIUTTL']""
130 . S TIUTTL=X_" <"_TIUTTL_">"
131 . ; First build x-ref for Clinical Documents & Immediate descendents
132 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
133 . I TIUCLASS'>0 Q
134 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
135 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
136 . ; Now build x-ref for document classes
137 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
138 . I TIUCLASS'>0 Q
139 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
140 I FLD=.07 D
141 . N TIUDA
142 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
143 . ; First remove x-ref for Clinical Documents & Immediate descendents
144 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
145 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
146 . Q:TIUTTL']""
147 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
148 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
149 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
150 . ; Now remove x-ref for document classes
151 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
152 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
153 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
154 I FLD=.01 D
155 . N TIUDA,TIUABV,TIUPN
156 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
157 . ; First remove x-ref for Clinical Documents & Immediate descendents
158 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
159 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
160 . K ^TIU(8925.1,"ACL",38,X,+TIUDA)
161 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
162 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA),^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)
163 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
164 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA),^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)
165 . D KACLKWIC(X,TIUCLASS,+TIUDA)
166 . ; Now remove x-ref for document classes
167 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
168 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
169 . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
170 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
171 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)
172 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
173 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)
174 . D KACLKWIC(X,TIUCLASS,+TIUDA)
175 Q
176KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog
177 N TIUI,TIUJ,TIUC S TIUI=1
178 F TIUJ=1:1:$L(X)+1 D
179 . S TIUC=$E(X,TIUJ)
180 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1
181 . I I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA)
182 Q
Note: See TracBrowser for help on using the repository browser.