Routine: TIUDD1

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**;Jun 20, 1997;Build 7

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)

 . I TIUABV]"" 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]"" 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]"" 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]"" S TIUPN=TIUPN_"  <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""

 . D SACLKWIC(X,TIUCLASS,+TIUDA)

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))=""

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)

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)

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**;Jun 20, 1997;Build 7

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               IF TIUABV]""

                       SET TIUABV=TIUABV_"  <"_X_">"

                       SET ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)=""

                       SET ^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)=""

 +81               SET TIUPN=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,3)

 +82               IF TIUPN]""

                       SET TIUPN=TIUPN_"  <"_X_">"

                       SET ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""

                       SET ^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)=""

 +83               DO SACLKWIC(X,TIUCLASS,+TIUDA)

 +84      ; Now build x-ref for document classes

 +85               SET TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)

 +86               IF TIUCLASS'>0

                       QUIT

 +87               SET ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""

 +88      ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES

 +89               SET TIUABV=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,2)

 +90               IF TIUABV]""

                       SET TIUABV=TIUABV_"  <"_X_">"

                       SET ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)=""

 +91               SET TIUPN=$PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,3)

 +92               IF TIUPN]""

                       SET TIUPN=TIUPN_"  <"_X_">"

                       SET ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""

 +93               DO SACLKWIC(X,TIUCLASS,+TIUDA)

               End DoDot:1

 +94       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

TIUDD1.m