- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD1.m
r613 r623 1 TIUDD1 ; 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 3 SACL(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 98 SACLKWIC(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 105 KACL(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 176 KACLKWIC(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 1 TIUDD1 ; 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 3 SACL(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 88 SACLKWIC(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 95 KACL(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 157 KACLKWIC(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 TracChangeset
for help on using the changeset viewer.
