TIUDD1 ; SLC/JER - XREFs for file 8925.1 ;19-OCT-2001 10:05:37 [7/28/04 9:08am]
;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163,224,278**;Jun 20, 1997;Build 5
SACL(X,FLD) ; Set logic for ACL cross-reference
; Called from fields .01 (NAME), .07 (STATUS), .03 (PRINT NAME),
; .02 (ABBREVIATION), and Subfield .01 of ITEM sub-file
N TIUCLASS,TIUSTTS,TIUTTL
I FLD=10.01 D
. ; Include only TITLES in the index
. I $P($G(^TIU(8925.1,+X,0)),U,4)'="DOC" Q
. S TIUSTTS=$P($G(^TIU(8925.1,+X,0)),U,7)
. ; Include only TEST or ACTIVE titles
. I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
. S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U)
. Q:TIUTTL']""
. ; First build x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+X)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)=""
. S ^TIU(8925.1,"ACL",38,TIUTTL,+X)=""
. D SACLKWIC(TIUTTL,TIUCLASS,+X)
. ; Now build x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+X)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)=""
. D SACLKWIC(TIUTTL,TIUCLASS,+X)
; For Abbreviation and Print Name fields, just set the Synonym subscript
I $S(FLD=.02:1,FLD=.03:1,1:0) D Q
. N TIUDA
. Q:X']""
. S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
. I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
. S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
. ;VMPELR P 224 allow the update of inactive titles
. ; Include only TEST or ACTIVE or INACTIVE TITLES
. I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
. S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
. Q:TIUTTL']""
. S X=$$UP^XLFSTR(X)
. Q:X=TIUTTL
. S TIUTTL=X_" <"_TIUTTL_">"
. ; First build x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
. S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
. ; Now build x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
I FLD=.07 D Q
. N TIUDA
. S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
. I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
. S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
. ; Include only TEST or ACTIVE titles
. I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
. S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
. Q:TIUTTL']""
. ; First build x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
. S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
. D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
. ; Now build x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
. D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
I FLD=.01 D
. N TIUDA
. S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
. I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
. S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
. ; Include only TEST or ACTIVE OR inactive titles
. I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
. ; First build x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
. S ^TIU(8925.1,"ACL",38,X,+TIUDA)=""
. S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
. ;*278 - Do not set print name or abbreviation if same as name
. I TIUABV]"",TIUABV'=X S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)=""
. S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
. I TIUPN]"",TIUPN'=X S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)=""
. D SACLKWIC(X,TIUCLASS,+TIUDA)
. ; Now build x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
. ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
. S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
. I TIUABV]"",TIUABV'=X S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)=""
. S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
. I TIUPN]"",TIUPN'=X S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""
. D SACLKWIC(X,TIUCLASS,+TIUDA)
Q
SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog
N TIUI,TIUJ,TIUC S TIUI=1
F TIUJ=1:1:$L(X)+1 D
. S TIUC=$E(X,TIUJ)
. I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1
. 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))=""
Q
KACL(X,FLD) ; KILL Logic for ACL cross-reference
N TIUCLASS,TIUTTL,TIUDA
I FLD=10.01 D
. ; First remove x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+X)
. S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U)
. Q:TIUTTL']""
. Q:X=TIUTTL
. K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
. K ^TIU(8925.1,"ACL",38,TIUTTL,+X)
. D KACLKWIC(TIUTTL,TIUCLASS,+X)
. ; Now remove x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+X)
. K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
. D KACLKWIC(TIUTTL,TIUCLASS,+X)
I $S(FLD=.02:1,FLD=.03:1,1:0) D Q
. N TIUDA
. Q:X']""
. S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
. I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
. S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
. ; Include only TEST or ACTIVE or INACTIVE titles
. I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
. S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
. Q:TIUTTL']""
. S TIUTTL=X_" <"_TIUTTL_">"
. ; First build x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
. K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
. ; Now build x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
. I TIUCLASS'>0 Q
. K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
I FLD=.07 D
. N TIUDA
. S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
. ; First remove x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
. S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
. Q:TIUTTL']""
. K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
. K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
. D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
. ; Now remove x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
. K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
. D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
I FLD=.01 D
. N TIUDA,TIUABV,TIUPN
. S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
. ; First remove x-ref for Clinical Documents & Immediate descendents
. S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
. K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
. K ^TIU(8925.1,"ACL",38,X,+TIUDA)
. S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
. I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA),^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)
. S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
. I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA),^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)
. D KACLKWIC(X,TIUCLASS,+TIUDA)
. ; Now remove x-ref for document classes
. S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
. K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
. ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
. S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
. I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)
. S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
. I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)
. D KACLKWIC(X,TIUCLASS,+TIUDA)
Q
KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog
N TIUI,TIUJ,TIUC S TIUI=1
F TIUJ=1:1:$L(X)+1 D
. S TIUC=$E(X,TIUJ)
. I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1
. I I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUDD1 8003 printed Sep 23, 2025@20:15:58 Page 2
TIUDD1 ; SLC/JER - XREFs for file 8925.1 ;19-OCT-2001 10:05:37 [7/28/04 9:08am]
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163,224,278**;Jun 20, 1997;Build 5
SACL(X,FLD) ; Set logic for ACL cross-reference
+1 ; Called from fields .01 (NAME), .07 (STATUS), .03 (PRINT NAME),
+2 ; .02 (ABBREVIATION), and Subfield .01 of ITEM sub-file
+3 NEW TIUCLASS,TIUSTTS,TIUTTL
+4 IF FLD=10.01
Begin DoDot:1
+5 ; Include only TITLES in the index
+6 IF $PIECE($GET(^TIU(8925.1,+X,0)),U,4)'="DOC"
QUIT
+7 SET TIUSTTS=$PIECE($GET(^TIU(8925.1,+X,0)),U,7)
+8 ; Include only TEST or ACTIVE titles
+9 IF $SELECT(TIUSTTS=10:0,TIUSTTS=11:0,1:1)
QUIT
+10 SET TIUTTL=$PIECE($GET(^TIU(8925.1,+X,0)),U)
+11 if TIUTTL']""
QUIT
+12 ; First build x-ref for Clinical Documents & Immediate descendents
+13 SET TIUCLASS=+$$CLINDOC^TIULC1(+X)
+14 IF TIUCLASS'>0
QUIT
+15 SET ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)=""
+16 SET ^TIU(8925.1,"ACL",38,TIUTTL,+X)=""
+17 DO SACLKWIC(TIUTTL,TIUCLASS,+X)
+18 ; Now build x-ref for document classes
+19 SET TIUCLASS=+$$DOCCLASS^TIULC1(+X)
+20 IF TIUCLASS'>0
QUIT
+21 SET ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)=""
+22 DO SACLKWIC(TIUTTL,TIUCLASS,+X)
End DoDot:1
+23 ; For Abbreviation and Print Name fields, just set the Synonym subscript
+24 IF $SELECT(FLD=.02:1,FLD=.03:1,1:0)
Begin DoDot:1
+25 NEW TIUDA
+26 if X']""
QUIT
+27 SET TIUDA=$SELECT(+$GET(DA(1)):+$GET(DA(1)),1:+$GET(DA))
+28 IF $PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC"
QUIT
+29 SET TIUSTTS=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,7)
+30 ;VMPELR P 224 allow the update of inactive titles
+31 ; Include only TEST or ACTIVE or INACTIVE TITLES
+32 IF $SELECT(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1)
QUIT
+33 SET TIUTTL=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U)
+34 if TIUTTL']""
QUIT
+35 SET X=$$UP^XLFSTR(X)
+36 if X=TIUTTL
QUIT
+37 SET TIUTTL=X_" <"_TIUTTL_">"
+38 ; First build x-ref for Clinical Documents & Immediate descendents
+39 SET TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
+40 IF TIUCLASS'>0
QUIT
+41 SET ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
+42 SET ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
+43 ; Now build x-ref for document classes
+44 SET TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
+45 IF TIUCLASS'>0
QUIT
+46 SET ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
End DoDot:1
QUIT
+47 IF FLD=.07
Begin DoDot:1
+48 NEW TIUDA
+49 SET TIUDA=$SELECT(+$GET(DA(1)):+$GET(DA(1)),1:+$GET(DA))
+50 IF $PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC"
QUIT
+51 SET TIUSTTS=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,7)
+52 ; Include only TEST or ACTIVE titles
+53 IF $SELECT(TIUSTTS=10:0,TIUSTTS=11:0,1:1)
QUIT
+54 SET TIUTTL=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U)
+55 if TIUTTL']""
QUIT
+56 ; First build x-ref for Clinical Documents & Immediate descendents
+57 SET TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
+58 IF TIUCLASS'>0
QUIT
+59 SET ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
+60 SET ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)=""
+61 DO SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
+62 ; Now build x-ref for document classes
+63 SET TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
+64 IF TIUCLASS'>0
QUIT
+65 SET ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)=""
+66 DO SACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
End DoDot:1
QUIT
+67 IF FLD=.01
Begin DoDot:1
+68 NEW TIUDA
+69 SET TIUDA=$SELECT(+$GET(DA(1)):+$GET(DA(1)),1:+$GET(DA))
+70 IF $PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC"
QUIT
+71 SET TIUSTTS=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,7)
+72 ; Include only TEST or ACTIVE OR inactive titles
+73 IF $SELECT(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1)
QUIT
+74 ; First build x-ref for Clinical Documents & Immediate descendents
+75 SET TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
+76 IF TIUCLASS'>0
QUIT
+77 SET ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
+78 SET ^TIU(8925.1,"ACL",38,X,+TIUDA)=""
+79 SET TIUABV=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,2)
+80 ;*278 - Do not set print name or abbreviation if same as name
+81 IF TIUABV]""
IF TIUABV'=X
SET TIUABV=TIUABV_" <"_X_">"
SET ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)=""
SET ^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)=""
+82 SET TIUPN=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,3)
+83 IF TIUPN]""
IF TIUPN'=X
SET TIUPN=TIUPN_" <"_X_">"
SET ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""
SET ^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)=""
+84 DO SACLKWIC(X,TIUCLASS,+TIUDA)
+85 ; Now build x-ref for document classes
+86 SET TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
+87 IF TIUCLASS'>0
QUIT
+88 SET ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
+89 ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
+90 SET TIUABV=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,2)
+91 IF TIUABV]""
IF TIUABV'=X
SET TIUABV=TIUABV_" <"_X_">"
SET ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)=""
+92 SET TIUPN=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,3)
+93 IF TIUPN]""
IF TIUPN'=X
SET TIUPN=TIUPN_" <"_X_">"
SET ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""
+94 DO SACLKWIC(X,TIUCLASS,+TIUDA)
End DoDot:1
+95 QUIT
SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog
+1 NEW TIUI,TIUJ,TIUC
SET TIUI=1
+2 FOR TIUJ=1:1:$LENGTH(X)+1
Begin DoDot:1
+3 SET TIUC=$EXTRACT(X,TIUJ)
+4 IF "(,.?! '-/&:;)"[TIUC
SET TIUC=$EXTRACT($EXTRACT(X,TIUI,TIUJ-1),1,30)
SET TIUI=TIUJ+1
+5 IF $TEST
IF $LENGTH(TIUC)>2
IF (^DD("KWIC")'[TIUC)
IF (TIUC'=X)
SET (^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA))=""
End DoDot:1
+6 QUIT
KACL(X,FLD) ; KILL Logic for ACL cross-reference
+1 NEW TIUCLASS,TIUTTL,TIUDA
+2 IF FLD=10.01
Begin DoDot:1
+3 ; First remove x-ref for Clinical Documents & Immediate descendents
+4 SET TIUCLASS=+$$CLINDOC^TIULC1(+X)
+5 SET TIUTTL=$PIECE($GET(^TIU(8925.1,+X,0)),U)
+6 if TIUTTL']""
QUIT
+7 if X=TIUTTL
QUIT
+8 KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
+9 KILL ^TIU(8925.1,"ACL",38,TIUTTL,+X)
+10 DO KACLKWIC(TIUTTL,TIUCLASS,+X)
+11 ; Now remove x-ref for document classes
+12 SET TIUCLASS=+$$DOCCLASS^TIULC1(+X)
+13 KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)
+14 DO KACLKWIC(TIUTTL,TIUCLASS,+X)
End DoDot:1
+15 IF $SELECT(FLD=.02:1,FLD=.03:1,1:0)
Begin DoDot:1
+16 NEW TIUDA
+17 if X']""
QUIT
+18 SET TIUDA=$SELECT(+$GET(DA(1)):+$GET(DA(1)),1:+$GET(DA))
+19 IF $PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC"
QUIT
+20 SET TIUSTTS=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,7)
+21 ; Include only TEST or ACTIVE or INACTIVE titles
+22 IF $SELECT(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1)
QUIT
+23 SET TIUTTL=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U)
+24 if TIUTTL']""
QUIT
+25 SET TIUTTL=X_" <"_TIUTTL_">"
+26 ; First build x-ref for Clinical Documents & Immediate descendents
+27 SET TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
+28 IF TIUCLASS'>0
QUIT
+29 KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
+30 KILL ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
+31 ; Now build x-ref for document classes
+32 SET TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
+33 IF TIUCLASS'>0
QUIT
+34 KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
End DoDot:1
QUIT
+35 IF FLD=.07
Begin DoDot:1
+36 NEW TIUDA
+37 SET TIUDA=$SELECT(+$GET(DA(1)):+$GET(DA(1)),1:+$GET(DA))
+38 ; First remove x-ref for Clinical Documents & Immediate descendents
+39 SET TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
+40 SET TIUTTL=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U)
+41 if TIUTTL']""
QUIT
+42 KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
+43 KILL ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)
+44 DO KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
+45 ; Now remove x-ref for document classes
+46 SET TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
+47 KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)
+48 DO KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
End DoDot:1
+49 IF FLD=.01
Begin DoDot:1
+50 NEW TIUDA,TIUABV,TIUPN
+51 SET TIUDA=$SELECT(+$GET(DA(1)):+$GET(DA(1)),1:+$GET(DA))
+52 ; First remove x-ref for Clinical Documents & Immediate descendents
+53 SET TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
+54 KILL ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
+55 KILL ^TIU(8925.1,"ACL",38,X,+TIUDA)
+56 SET TIUABV=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,2)
+57 IF TIUABV]""
SET TIUABV=TIUABV_" <"_X_">"
KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA),^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)
+58 SET TIUPN=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,3)
+59 IF TIUPN]""
SET TIUPN=TIUPN_" <"_X_">"
KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA),^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)
+60 DO KACLKWIC(X,TIUCLASS,+TIUDA)
+61 ; Now remove x-ref for document classes
+62 SET TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
+63 KILL ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
+64 ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
+65 SET TIUABV=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,2)
+66 IF TIUABV]""
SET TIUABV=TIUABV_" <"_X_">"
KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)
+67 SET TIUPN=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,3)
+68 IF TIUPN]""
SET TIUPN=TIUPN_" <"_X_">"
KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)
+69 DO KACLKWIC(X,TIUCLASS,+TIUDA)
End DoDot:1
+70 QUIT
KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog
+1 NEW TIUI,TIUJ,TIUC
SET TIUI=1
+2 FOR TIUJ=1:1:$LENGTH(X)+1
Begin DoDot:1
+3 SET TIUC=$EXTRACT(X,TIUJ)
+4 IF "(,.?! '-/&:;)"[TIUC
SET TIUC=$EXTRACT($EXTRACT(X,TIUI,TIUJ-1),1,30)
SET TIUI=TIUJ+1
+5 IF $TEST
IF $LENGTH(TIUC)>2
KILL ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA)
End DoDot:1
+6 QUIT
