ICDIDX.m

ICDIDX ;DLS/DEK - MUMPS Cross Reference Routine ;04/21/2014

 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1

 ;               

 ; Global Variables

 ;    None

 ;               

 ; External References

 ;    IXALL^DIK           ICR  10013

 ;    $$UP^XLFSTR         ICR  10104

 ;               

 ; "D" on Description

SD(ICD) ; Set ROOT("D",<word>,<file ien>,<dt>,<des ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N WRDS,I,WD,CDT,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)  S EXC=$$EXC(DA(1),RT) Q:+EXC'>0

 S CDT=$G(@(RT_+($G(DA(1)))_",68,"_+($G(DA))_",0)")),CDT=$P(CDT,"^",1) Q:CDT'?7N  D PAR^ICDTOKN($G(X),.WRDS,0) S I=0

 F  S I=$O(WRDS(I)) Q:+I'>0  S WD=$G(WRDS(I)) S:$L(WD) @(RT_"""D"","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")=""

 S IE1=DA(1),IE2=DA,IE3=0 F  S IE3=$O(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")")) Q:+IE3'>0  D

 . S KEY=$$TM($G(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)"))) Q:'$L(KEY)

 . S @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

 Q

KD(ICD) ; Kill ROOT("D",<word>,<file ien>,<dt>,<des ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N WRDS,I,WD,CDT,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S CDT=$G(@(RT_+($G(DA(1)))_",68,"_+($G(DA))_",0)")),CDT=$P(CDT,"^",1) Q:CDT'?7N  D PAR^ICDTOKN($G(X),.WRDS,0) S I=0

 F  S I=$O(WRDS(I)) Q:+I'>0  S WD=$G(WRDS(I)) K:$L(WD) @(RT_"""D"","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")

 S IE1=DA(1),IE2=DA,IE3=0 F  S IE3=$O(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")")) Q:+IE3'>0  D

 . S KEY=$$TM($G(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)"))) Q:'$L(KEY)

 . K @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")

 Q

 ; "AD" on Description

SAD(ICD) ; Set ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N KEY,WRDS,I,WD,CDT,SYS,EXC,RT

 S RT=$$RT(+($G(ICD))) Q:'$L(RT)  S EXC=$$EXC(DA(1),RT) Q:+EXC'>0

 S CDT=$G(@(RT_+($G(DA(1)))_",68,"_+($G(DA))_",0)")),CDT=$P(CDT,"^",1) Q:CDT'?7N

 S SYS=+($P($G(@(RT_+DA(1)_",1)")),"^",1)) Q:+SYS'>0  D PAR^ICDTOKN($G(X),.WRDS,0) S I=0

 F  S I=$O(WRDS(I)) Q:+I'>0  D

 . S WD=$G(WRDS(I)) S:$L(WD) @(RT_"""AD"","_+SYS_","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")=""

 S IE1=DA(1),IE2=DA,IE3=0

 F  S IE3=$O(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")")) Q:+IE3'>0  D

 . S KEY=$$TM($G(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)"))) Q:'$L(KEY)

 . S @(RT_"""AD"","_+SYS_","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

 . S @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

 Q

KAD(ICD) ; Kill ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N KEY,WRDS,I,WD,CDT,SYS,EXC,RT,IE1,IE2,IE3 S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S CDT=$G(@(RT_+($G(DA(1)))_",68,"_+($G(DA))_",0)")),CDT=$P(CDT,"^",1) Q:CDT'?7N

 S SYS=+($P($G(@(RT_+DA(1)_",1)")),"^",1)) Q:+SYS'>0  D PAR^ICDTOKN($G(X),.WRDS,0) S I=0

 F  S I=$O(WRDS(I)) Q:+I'>0  S WD=$G(WRDS(I)) K:$L(WD) @(RT_"""AD"","_+SYS_","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")

 S IE1=DA(1),IE2=DA,IE3=0

 F  S IE3=$O(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")")) Q:+IE3'>0  D

 . S KEY=$$TM($G(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)"))) Q:'$L(KEY)

 . K @(RT_"""AD"","_+SYS_","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")

 . K @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")

 Q

 ; "AD" on Coding System

SAD2(ICD) ; Set ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>)

 Q:'$L($G(X))  Q:+($G(DA))'>0  N WRDS,I,WD,TXT,KEY,CDT,SYS,IE1,IE2,IE3,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)  S EXC=$$EXC(DA,RT) Q:+EXC'>0

 S SYS=+($G(X)) Q:+SYS'>0  S IE1=+($G(DA)),IE2=0 F  S IE2=$O(@(RT_+IE1_",68,"_IE2_")")) Q:+IE2'>0  D

 . N I S CDT=$P($G(@(RT_+IE1_",68,"_IE2_",0)")),"^",1) Q:CDT'?7N

 . S TXT=$G(@(RT_+IE1_",68,"_IE2_",1)")) I $L(TXT) D

 . . D PAR^ICDTOKN(TXT,.WRDS,0) S I=0 F  S I=$O(WRDS(I)) Q:+I'>0  S WD=$G(WRDS(I)) D

 . . . S:$L(WD) @(RT_"""AD"","_+SYS_","""_WD_""","_+IE1_","_CDT_","_+IE2_")")=""

 . S IE3=0 F  S IE3=$O(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")")) Q:+IE3'>0  D

 . . S KEY=$$TM($G(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)"))) Q:'$L(KEY)

 . . S @(RT_"""AD"","_+SYS_","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

 . . S @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

 Q

KAD2(ICD) ; Kill ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>)

 Q:'$L($G(X))  Q:+($G(DA))'>0  N WRDS,I,WD,TXT,CDT,SYS,IE1,IE2,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S SYS=+($G(X)) Q:+SYS'>0  S IE1=+($G(DA)),IE2=0 F  S IE2=$O(@(RT_+IE1_",68,"_IE2_")")) Q:+IE2'>0  D

 . N I S CDT=$P($G(@(RT_+IE1_",68,"_IE2_",0)")),"^",1) Q:CDT'?7N

 . S TXT=$G(@(RT_+IE1_",68,"_IE2_",1)")) I $L(TXT) D

 . . D PAR^ICDTOKN(TXT,.WRDS,0) S I=0 F  S I=$O(WRDS(I)) Q:+I'>0  S WD=$G(WRDS(I)) D

 . . . K:$L(WD) @(RT_"""AD"","_+SYS_","""_WD_""","_+IE1_","_CDT_","_+IE2_")")

 . S IE3=0 F  S IE3=$O(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")")) Q:+IE3'>0  D

 . . S KEY=$$TM($G(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)"))) Q:'$L(KEY)

 . . K @(RT_"""AD"","_+SYS_","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")

 . . K @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")

 Q

 ; "AD" on Keywords

SAD3(ICD) ; Set ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>,<wd ien>)

 N KEY S KEY=$$UP^XLFSTR($$TM($G(X))) Q:'$L(KEY)  Q:+($G(DA(2)))'>0  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0

 N CDT,SYS,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)  S EXC=$$EXC(DA(2),RT) Q:+EXC'>0

 S CDT=$G(@(RT_+($G(DA(2)))_",68,"_+($G(DA(1)))_",0)")),CDT=$P(CDT,"^",1) Q:CDT'?7N

 S SYS=+($P($G(@(RT_+DA(2)_",1)")),"^",1)) Q:+SYS'>0

 S @(RT_"""AD"","_+SYS_","""_KEY_""","_+DA(2)_","_CDT_","_+DA(1)_","_+DA_")")=""

 S @(RT_"""D"","""_KEY_""","_+DA(2)_","_CDT_","_+DA(1)_","_+DA_")")=""

 Q

KAD3(ICD) ; Kill ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>,<wd ien>)

 N KEY S KEY=$$UP^XLFSTR($$TM($G(X))) Q:'$L(KEY)  Q:+($G(DA(2)))'>0  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0

 N CDT,SYS,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)  S EXC=$$EXC(DA(2),RT) Q:+EXC'>0

 S CDT=$G(@(RT_+($G(DA(2)))_",68,"_+($G(DA(1)))_",0)")),CDT=$P(CDT,"^",1) Q:CDT'?7N

 S SYS=+($P($G(@(RT_+DA(2)_",1)")),"^",1)) Q:+SYS'>0

 K @(RT_"""AD"","_+SYS_","""_KEY_""","_+DA(2)_","_CDT_","_+DA(1)_","_+DA_")")

 K @(RT_"""D"","""_KEY_""","_+DA(2)_","_CDT_","_+DA(1)_","_+DA_")")

 Q

 ; "AST" on short text effective date

SAST(ICD) ; Set ROOT("AST",<code>,<dt>,<file ien>,<st ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S EXC=+($$EXC(DA(1),RT)) Q:+EXC'>0  S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 S SYS=$P($G(@(RT_DA(1)_",1)")),"^",1) S @(RT_"""AST"","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")=""

 Q

KAST(ICD) ; Kill ROOT("AST",<code>,<dt>,<file ien>,<st ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 S SYS=$P($G(@(RT_DA(1)_",1)")),"^",1) K @(RT_"""AST"","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")

 Q

 ; "ASTS" on short text effective date

SASTS1(ICD) ; Set ROOT("ASTS",<cs>,<code>,<dt>,<file ien>,<st ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S EXC=+($$EXC(DA(1),RT)) Q:+EXC'>0  S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 S SYS=$P($G(@(RT_DA(1)_",1)")),"^",1) Q:+SYS'>0

 S @(RT_"""ASTS"","_+SYS_","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")=""

 Q

KASTS1(ICD) ; Kill ROOT("ASTS",<cs>,<code>,<dt>,<file ien>,<st ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 S SYS=$P($G(@(RT_DA(1)_",1)")),"^",1) Q:+SYS'>0

 K @(RT_"""ASTS"","_+SYS_","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")

 Q

 ; "ASTS" on short text

SASTS2(ICD) ; Set ROOT("ASTS",<cs>,<code>,<dt>,<file ien>,<st ien>)

 Q:'$L($G(X))  Q:+($G(DA))'>0  N WRDS,I,WD,TXT,COD,CDT,SYS,IE1,IE2,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S EXC=$$EXC(DA,RT) Q:+EXC'>0  S SYS=+($G(X)) Q:+SYS'>0  S COD=$P($G(@(RT_+($G(DA))_",0)")),"^",1) Q:'$L(COD)

 S IE1=+($G(DA)),IE2=0 F  S IE2=$O(@(RT_+IE1_",67,"_IE2_")")) Q:+IE2'>0  D

 . N I S CDT=$P($G(@(RT_+IE1_",67,"_IE2_",0)")),"^",1) Q:CDT'?7N

 . S @(RT_"""ASTS"","_+SYS_","""_(COD_" ")_""","_CDT_","_IE1_","_IE2_")")=""

 Q

KASTS2(ICD) ; Set ROOT("ASTS",<cs>,<code>,<dt>,<file ien>,<dx ien>)

 Q:'$L($G(X))  Q:+($G(DA))'>0  N WRDS,I,WD,TXT,COD,CDT,SYS,IE1,IE2,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S SYS=+($G(X)) Q:+SYS'>0  S COD=$P($G(@(RT_+($G(DA))_",0)")),"^",1) Q:'$L(COD)

 S IE1=+($G(DA)),IE2=0 F  S IE2=$O(@(RT_+IE1_",67,"_IE2_")")) Q:+IE2'>0  D

 . N I S CDT=$P($G(@(RT_+IE1_",67,"_IE2_",0)")),"^",1) Q:CDT'?7N

 . K @(RT_"""ASTS"","_+SYS_","""_(COD_" ")_""","_CDT_","_IE1_","_IE2_")")

 Q

 ;

SADS(ICD) ; Set ROOT("ADS",<code>,<dt>,<file ien>,<dx ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S EXC=+($$EXC(DA(1),RT)) Q:+EXC'>0  S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 S @(RT_"""ADS"","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")=""

 Q

KADS(ICD) ; Kill ROOT("ADS",<code>,<dt>,<file ien>,<dx ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 K @(RT_"""ADS"","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")

 Q

SADSS1(ICD) ; Set ROOT("ADSS",SYS,<code>,<dt>,<file ien>,<dx ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S EXC=+($$EXC(DA(1),RT)) Q:+EXC'>0  S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 S SYS=$P($G(@(RT_DA(1)_",1)")),"^",1) Q:+SYS'>0

 S @(RT_"""ADSS"","_+SYS_","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")=""

 Q

KADSS1(ICD) ; Kill ROOT("ADSS",SYS,<code>,<dt>,<file ien>,<dx ien>)

 Q:'$L($G(X))  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  N EXC,COD,SYS,RT,CDT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S CDT=+($G(X)) Q:CDT'?7N  S COD=$P($G(@(RT_DA(1)_",0)")),"^",1) Q:'$L(COD)

 S SYS=$P($G(@(RT_DA(1)_",1)")),"^",1) Q:+SYS'>0

 K @(RT_"""ADSS"","_+SYS_","""_(COD_" ")_""","_CDT_","_DA(1)_","_DA_")")

 Q

SADSS2(ICD) ; Set ROOT("ADSS",SYS,<code>,<dt>,<file ien>,<dx ien>)

 Q:'$L($G(X))  Q:+($G(DA))'>0  N WRDS,I,WD,TXT,COD,CDT,SYS,IE1,IE2,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S EXC=$$EXC(DA,RT) Q:+EXC'>0  S SYS=+($G(X)) Q:+SYS'>0  S COD=$P($G(@(RT_+($G(DA))_",0)")),"^",1) Q:'$L(COD)

 S IE1=+($G(DA)),IE2=0 F  S IE2=$O(@(RT_+IE1_",68,"_IE2_")")) Q:+IE2'>0  D

 . N I S CDT=$P($G(@(RT_+IE1_",68,"_IE2_",0)")),"^",1) Q:CDT'?7N

 . S @(RT_"""ADSS"","_+SYS_","""_(COD_" ")_""","_CDT_","_IE1_","_IE2_")")=""

 Q

KADSS2(ICD) ; Set ROOT("ADSS",SYS,<code>,<dt>,<file ien>,<dx ien>)

 Q:'$L($G(X))  Q:+($G(DA))'>0  N WRDS,I,WD,TXT,COD,CDT,SYS,IE1,IE2,EXC,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S SYS=+($G(X)) Q:+SYS'>0  S COD=$P($G(@(RT_+($G(DA))_",0)")),"^",1) Q:'$L(COD)

 S IE1=+($G(DA)),IE2=0 F  S IE2=$O(@(RT_+IE1_",68,"_IE2_")")) Q:+IE2'>0  D

 . N I S CDT=$P($G(@(RT_+IE1_",68,"_IE2_",0)")),"^",1) Q:CDT'?7N

 . K @(RT_"""ADSS"","_+SYS_","""_(COD_" ")_""","_CDT_","_IE1_","_IE2_")")

 Q

SAEXC(ICD) ; Set ROOT("AEXC",<code>,<ien>)

 Q:+($G(DA))'>0  N COD,EXC,RT  S RT=$$RT(+($G(ICD))) Q:'$L(RT)  S COD=$P($G(@(RT_+DA_",0)")),"^",1) Q:'$L(COD)

 S EXC=$$EXC(DA,RT) S:+EXC'>0 @(RT_"""AEXC"","""_(COD_" ")_""","_DA_")")=""

 Q

KAEXC(ICD) ; Kill ROOT("AEXC",<code>,<ien>)

 Q:+($G(DA))'>0  N COD,EXC,RT  S RT=$$RT(+($G(ICD))) Q:'$L(RT)  S COD=$P($G(@(RT_+DA_",0)")),"^",1) Q:'$L(COD)

 K @(RT_"""AEXC"","""_(COD_" ")_""","_DA_")")

 Q

 ;

 ; Miscellaneous

EXC(X,Y) ;   Exclude from lookup

 N COD,EFF,LDS,IEN,RT S IEN=+($G(X)),RT=$G(Y) Q:+IEN'>0 0  Q:'$L(RT) 0  S COD=$P($G(@(RT_+IEN_",0)")),"^",1)

 S EFF=$O(@(RT_+IEN_",66,0)")),LDS=$O(@(RT_+IEN_",68,0)")) Q:$L(COD)&(+EFF>0)&(+LDS>0) 1

 Q 0

RM(ICD) ;   Remove Main

 N IX,RT S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S IX=" " F  S IX=$O(@(RT_""""_IX_""")")) Q:'$L(IX)  D

 . K @(RT_""""_IX_""")")

 Q

RE(ICD) ;   Re-Index

 N ZTQUEUED,DIK,IX,RT,DA S RT=$$RT(+($G(ICD))) Q:'$L(RT)

 S DIK=RT,ZTQUEUED="" D IXALL^DIK

 Q

RT(X) ;   Root from File #

 Q $S(+($G(X))=80:$$ROOT^ICDEX(80),+($G(X))=80.1:$$ROOT^ICDEX(80.1),1:"")

TM(X,Y) ;   Trim Y

 S X=$G(X),Y=$G(Y) S:'$L(Y) Y=" "

 F  Q:$E(X,1)'=Y  S X=$E(X,2,$L(X))

 F  Q:$E(X,$L(X))'=Y  S X=$E(X,1,($L(X)-1))

 Q X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ICDIDX   12485     printed  Feb 18, 2025@23:17:16                                                                                                                                                                                                     Page 2

ICDIDX    ;DLS/DEK - MUMPS Cross Reference Routine ;04/21/2014

 +1       ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1

 +2       ;               

 +3       ; Global Variables

 +4       ;    None

 +5       ;               

 +6       ; External References

 +7       ;    IXALL^DIK           ICR  10013

 +8       ;    $$UP^XLFSTR         ICR  10104

 +9       ;               

 +10      ; "D" on Description

SD(ICD)   ; Set ROOT("D",<word>,<file ien>,<dt>,<des ien>)

 +1        if '$LENGTH($GET(X))

               QUIT 

           if +($GET(DA(1)))'>0

               QUIT 

           if +($GET(DA))'>0

               QUIT 

           NEW WRDS,I,WD,CDT,EXC,RT

           SET RT=$$RT(+($GET(ICD)))

           if '$LENGTH(RT)

               QUIT 

           SET EXC=$$EXC(DA(1),RT)

           if +EXC'>0

               QUIT 

 +2        SET CDT=$GET(@(RT_+($GET(DA(1)))_",68,"_+($GET(DA))_",0)"))

           SET CDT=$PIECE(CDT,"^",1)

           if CDT'?7N

               QUIT 

           DO PAR^ICDTOKN($GET(X),.WRDS,0)

           SET I=0

 +3        FOR 

               SET I=$ORDER(WRDS(I))

               if +I'>0

                   QUIT 

               SET WD=$GET(WRDS(I))

               if $LENGTH(WD)

                   SET @(RT_"""D"","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")=""

 +4        SET IE1=DA(1)

           SET IE2=DA

           SET IE3=0

           FOR 

               SET IE3=$ORDER(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")"))

               if +IE3'>0

                   QUIT 

               Begin DoDot:1

 +5                SET KEY=$$TM($GET(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)")))

                   if '$LENGTH(KEY)

                       QUIT 

 +6                SET @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

               End DoDot:1

 +7        QUIT 

KD(ICD)   ; Kill ROOT("D",<word>,<file ien>,<dt>,<des ien>)

 +1        if '$LENGTH($GET(X))

               QUIT 

           if +($GET(DA(1)))'>0

               QUIT 

           if +($GET(DA))'>0

               QUIT 

           NEW WRDS,I,WD,CDT,EXC,RT

           SET RT=$$RT(+($GET(ICD)))

           if '$LENGTH(RT)

               QUIT 

 +2        SET CDT=$GET(@(RT_+($GET(DA(1)))_",68,"_+($GET(DA))_",0)"))

           SET CDT=$PIECE(CDT,"^",1)

           if CDT'?7N

               QUIT 

           DO PAR^ICDTOKN($GET(X),.WRDS,0)

           SET I=0

 +3        FOR 

               SET I=$ORDER(WRDS(I))

               if +I'>0

                   QUIT 

               SET WD=$GET(WRDS(I))

               if $LENGTH(WD)

                   KILL @(RT_"""D"","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")

 +4        SET IE1=DA(1)

           SET IE2=DA

           SET IE3=0

           FOR 

               SET IE3=$ORDER(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")"))

               if +IE3'>0

                   QUIT 

               Begin DoDot:1

 +5                SET KEY=$$TM($GET(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)")))

                   if '$LENGTH(KEY)

                       QUIT 

 +6                KILL @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")

               End DoDot:1

 +7        QUIT 

 +8       ; "AD" on Description

SAD(ICD)  ; Set ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>)

 +1        if '$LENGTH($GET(X))

               QUIT 

           if +($GET(DA(1)))'>0

               QUIT 

           if +($GET(DA))'>0

               QUIT 

           NEW KEY,WRDS,I,WD,CDT,SYS,EXC,RT

 +2        SET RT=$$RT(+($GET(ICD)))

           if '$LENGTH(RT)

               QUIT 

           SET EXC=$$EXC(DA(1),RT)

           if +EXC'>0

               QUIT 

 +3        SET CDT=$GET(@(RT_+($GET(DA(1)))_",68,"_+($GET(DA))_",0)"))

           SET CDT=$PIECE(CDT,"^",1)

           if CDT'?7N

               QUIT 

 +4        SET SYS=+($PIECE($GET(@(RT_+DA(1)_",1)")),"^",1))

           if +SYS'>0

               QUIT 

           DO PAR^ICDTOKN($GET(X),.WRDS,0)

           SET I=0

 +5        FOR 

               SET I=$ORDER(WRDS(I))

               if +I'>0

                   QUIT 

               Begin DoDot:1

 +6                SET WD=$GET(WRDS(I))

                   if $LENGTH(WD)

                       SET @(RT_"""AD"","_+SYS_","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")=""

               End DoDot:1

 +7        SET IE1=DA(1)

           SET IE2=DA

           SET IE3=0

 +8        FOR 

               SET IE3=$ORDER(@(RT_+IE1_",68,"_+IE2_",2,"_IE3_")"))

               if +IE3'>0

                   QUIT 

               Begin DoDot:1

 +9                SET KEY=$$TM($GET(@(RT_+IE1_",68,"_+IE2_",2,"_+IE3_",0)")))

                   if '$LENGTH(KEY)

                       QUIT 

 +10               SET @(RT_"""AD"","_+SYS_","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

 +11               SET @(RT_"""D"","""_KEY_""","_+IE1_","_CDT_","_+IE2_","_+IE3_")")=""

               End DoDot:1

 +12       QUIT 

KAD(ICD)  ; Kill ROOT("AD",<cs>,<word>,<file ien>,<dt>,<des ien>)

 +1        if '$LENGTH($GET(X))

               QUIT 

           if +($GET(DA(1)))'>0

               QUIT 

           if +($GET(DA))'>0

               QUIT 

           NEW KEY,WRDS,I,WD,CDT,SYS,EXC,RT,IE1,IE2,IE3

           SET RT=$$RT(+($GET(ICD)))

           if '$LENGTH(RT)

               QUIT 

 +2        SET CDT=$GET(@(RT_+($GET(DA(1)))_",68,"_+($GET(DA))_",0)"))

           SET CDT=$PIECE(CDT,"^",1)

           if CDT'?7N

               QUIT 

 +3        SET SYS=+($PIECE($GET(@(RT_+DA(1)_",1)")),"^",1))

           if +SYS'>0

               QUIT 

           DO PAR^ICDTOKN($GET(X),.WRDS,0)

           SET I=0

 +4        FOR 

               SET I=$ORDER(WRDS(I))

               if +I'>0

                   QUIT 

               SET WD=$GET(WRDS(I))

               if $LENGTH(WD)

                   KILL @(RT_"""AD"","_+SYS_","""_WD_""","_+DA(1)_","_CDT_","_+DA_")")

 +5        SET IE1=DA(1)