source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD1.m@ 1800

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

revised back to 6/30/08 version
File size: 6.1 KB
RevLine 
[623]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**;Jun 20, 1997
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 . ; Include only TEST or ACTIVE titles
34 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
35 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
36 . Q:TIUTTL']""
37 . S X=$$UP^XLFSTR(X)
38 . Q:X=TIUTTL
39 . S TIUTTL=X_" <"_TIUTTL_">"
40 . ; First build x-ref for Clinical Documents & Immediate descendents
41 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
42 . I TIUCLASS'>0 Q
43 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
44 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
45 . ; Now build x-ref for document classes
46 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
47 . I TIUCLASS'>0 Q
48 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
49 I FLD=.07 D Q
50 . N TIUDA
51 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
52 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
53 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
54 . ; Include only TEST or ACTIVE titles
55 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
56 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
57 . Q:TIUTTL']""
58 . ; First build x-ref for Clinical Documents & Immediate descendents
59 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
60 . I TIUCLASS'>0 Q
61 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
62 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
63 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
64 . ; Now build x-ref for document classes
65 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
66 . I TIUCLASS'>0 Q
67 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
68 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
69 I FLD=.01 D
70 . N TIUDA
71 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
72 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
73 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
74 . ; Include only TEST or ACTIVE titles
75 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
76 . ; First build x-ref for Clinical Documents & Immediate descendents
77 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
78 . I TIUCLASS'>0 Q
79 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
80 . S ^TIU(8925.1,"ACL",38,X,+TIUDA)=""
81 . D SACLKWIC(X,TIUCLASS,+TIUDA)
82 . ; Now build x-ref for document classes
83 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
84 . I TIUCLASS'>0 Q
85 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
86 . D SACLKWIC(X,TIUCLASS,+TIUDA)
87 Q
88SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog
89 N TIUI,TIUJ,TIUC S TIUI=1
90 F TIUJ=1:1:$L(X)+1 D
91 . S TIUC=$E(X,TIUJ)
92 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1
93 . 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))=""
94 Q
95KACL(X,FLD) ; KILL Logic for ACL cross-reference
96 N TIUCLASS,TIUTTL,TIUDA
97 I FLD=10.01 D
98 . ; First remove x-ref for Clinical Documents & Immediate descendents
99 . S TIUCLASS=+$$CLINDOC^TIULC1(+X)
100 . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U)
101 . Q:TIUTTL']""
102 . Q:X=TIUTTL
103 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
104 . K ^TIU(8925.1,"ACL",38,TIUTTL,+X)
105 . D KACLKWIC(TIUTTL,TIUCLASS,+X)
106 . ; Now remove x-ref for document classes
107 . S TIUCLASS=+$$DOCCLASS^TIULC1(+X)
108 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
109 . D KACLKWIC(TIUTTL,TIUCLASS,+X)
110 I $S(FLD=.02:1,FLD=.03:1,1:0) D Q
111 . N TIUDA
112 . Q:X']""
113 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
114 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
115 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
116 . ; Include only TEST or ACTIVE titles
117 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
118 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
119 . Q:TIUTTL']""
120 . S TIUTTL=X_" <"_TIUTTL_">"
121 . ; First build x-ref for Clinical Documents & Immediate descendents
122 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
123 . I TIUCLASS'>0 Q
124 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
125 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
126 . ; Now build x-ref for document classes
127 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
128 . I TIUCLASS'>0 Q
129 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
130 I FLD=.07 D
131 . N TIUDA
132 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
133 . ; First remove x-ref for Clinical Documents & Immediate descendents
134 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
135 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
136 . Q:TIUTTL']""
137 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
138 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
139 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
140 . ; Now remove x-ref for document classes
141 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
142 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
143 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
144 I FLD=.01 D
145 . N TIUDA
146 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
147 . ; First remove x-ref for Clinical Documents & Immediate descendents
148 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
149 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
150 . K ^TIU(8925.1,"ACL",38,X,+TIUDA)
151 . D KACLKWIC(X,TIUCLASS,+TIUDA)
152 . ; Now remove x-ref for document classes
153 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
154 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
155 . D KACLKWIC(X,TIUCLASS,+TIUDA)
156 Q
157KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog
158 N TIUI,TIUJ,TIUC S TIUI=1
159 F TIUJ=1:1:$L(X)+1 D
160 . S TIUC=$E(X,TIUJ)
161 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1
162 . I I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA)
163 Q
Note: See TracBrowser for help on using the repository browser.