LRSCTX ;DALOI/FHS/JDB - FIND TERM OR ADD TO FILE ;04/10/12 15:41
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
Q
;
;
EN(LRFILE,LRTXT,LRSCT,LRHL7,LRERROR,CHECK) ;
; Main entry point for LRSCTX.
; Returns a matching entry for LRTXT in LRFILE or creates a new entry in LRFILE for LRTXT.
; Called by OBX^LA7VIN7
;
; Inputs
; LRFILE: File # to search (61, 61.2, 62)
; LRTXT: Text to find
; LRSCT: <opt> SNOMED CT code
; LRHL7: <byref><opt> HL7 info array
; ("R4")=File #4 IEN
; ("R6247")=File #62.47 IEN
; ("FSEC")=HL7 Field separator and Encoding characters
; ("MSH",3)=Sending Application
; ("MSH",4)=Sending Facility
; ("MSH",5)=Receiving Application
; ("MSH",6)=Receiving Facility
; ("MSH",11)=Message ID
; ("OBX",3)=OBX-3 (raw)
; ("OBX",5)=OBX-5 (raw)
; LRERROR:<byref> See Outputs
; CHECK:<opt> 1=Check for match, dont add
;
; Outputs (record # plus info)
; problem: 0^error msg -OR- IEN or "IEN^1" (^1=new entry flag)
; LRERROR array contains any error message associated.
;
N DATA,DIERR,I,LR6247,LRDATA,LRFIEN,LRFSEC,LRLEXSCT,LRMSG,LRX,SCTP,NTEXT,X,Y
N NODE,DIERR
S LRFILE=$G(LRFILE)
S LRTXT=$G(LRTXT)
S LRSCT=$G(LRSCT)
S CHECK=$G(CHECK)
S LRFSEC=$G(LRHL7("FSEC"))
S LR6247=$G(LRHL7("R6247"))
I LRFILE'?1(1"61",1"61.2",1"62") Q "0^Unknown file #"_LRFILE
;
S LRFIEN=0 ;IEN of matching/new file's entry
;
; If SCT code, use LEX data if valid SCT code
I LRSCT'="" S LRFIEN=$$CHKSCT(LRFILE,LRSCT,.LRHL7,1)
;
I LRFIEN Q LRFIEN
I $TR(LRTXT," ","")="" Q "0^Text is empty"
;
; Didnt find a valid SCT code/text match so keep searching
; Search for the text passed in
K NTEXT
S LRFIEN=$$FIND(LRTXT,LRFILE,.NTEXT)
I LRFIEN Q LRFIEN
;
; Check SCT database for a text match
S LRX=$$TXT4CS^LRSCT($$TRIM^XLFSTR(LRTXT),"SCT",.DATA)
; Use SCT code from synonym only if just one SCT matches
I LRX="1" D
. N SCT
. S SCT=$O(DATA(0))
. Q:SCT=""
. S X=$$CODE^LRSCT(SCT,"SCT")
. Q:X'>0 ;valid SCT?
. ; find IEN of associated SCT code in target file
. S LRFIEN=$$SCT2IEN^LA7VHLU6(SCT,LRTXT,"",LRFILE,"","")
. Q:LRFIEN
. ; do a file search for this SCT
. S LRFIEN=$$CHKSCT(LRFILE,SCT,.LRHL7,1)
. Q:LRFIEN
. ; file error
. I 'LRFIEN S X=$P(LRFIEN,"^",2) I X'="" S LRFIEN="O^"_X Q
. K NTEXT
. ; Search for the text passed in (trimmed)
. S LRFIEN=$$FIND($$TRIM^XLFSTR(LRTXT),LRFILE,.NTEXT)
;
; No matches so need to add new entry
I 'LRFIEN,'CHECK D
. N LRIN
. K LRERROR
. S LRIN(.01)=$$TRIM^XLFSTR(LRTXT)
. ; new term so set as "refer to ETS"
. S LRIN(21)="REFERRED"
. S LRFIEN=$$FILE^LRSCTX1(LRFILE,.LRIN,.LRERROR,.LRHL7)
. I LRFIEN S LRFIEN=LRFIEN_"^1" ;new entry created
. I 'LRFIEN S X=$P($G(LRERROR),"^",2) I X'="" S LRFIEN="0^"_X
;
Q LRFIEN
;
;
CHKSCT(LRFILE,LRSCT,HLINFO,ADD,INACTIVE) ;
; Private helper method
; Checks for an SCT match. If no existing LRFILE entry is found using the LEX data, a new entry in LRFILE will be created automatically.
; Inputs
; LRFILE: File number to search/add entry to (61, 61.2, 62)
; LRSCT: SCT Code to use for search
; HLINFO:<byref> (from EN^LRSCTX)
; ADD:<opt> dflt=0 0=dont add new entry 1=add new entry
; INACTIVE: <opt>0 or 1 <dflt=0> 1=use SCT even if inactive
; Outputs
; The IEN of the entry found or created.
; If a file error occurred, output=0 and the second "^" piece contains error info. ie "0^Unknown file #"
;
N DATA,I,LRERROR,LRFIEN,LRLEXSCT,LRIN,NODE,NTEXT,SCTP,X,Y
S LRFILE=$G(LRFILE),LRSCT=$G(LRSCT),INACTIVE=$G(INACTIVE,0),ADD=$G(ADD,0)
S LRFIEN=0
;
; SCT code in target file?
I LRFILE,LRSCT'="" S LRFIEN=$$SCT2IEN^LA7VHLU6(LRSCT,"","",LRFILE,"","")
;
; Get SCT info from LEX
I 'LRFIEN D
. N DATA,LR6247,SCTHIER
. S LRLEXSCT=$$CODE^LRSCT(LRSCT,"SCT","","DATA")
. Q:LRLEXSCT=-1
. I 'INACTIVE Q:LRLEXSCT'>0 ; dont use if invalid SCT code
. I INACTIVE I LRLEXSCT'>0!(LRLEXSCT'=-2) Q
. S SCTHIER=$P($G(DATA(0)),"^",2)
. ; check for targ file matches on SCT main, preferred, & synonyms
. S X=$G(DATA("F"))
. I X'="" S LRFIEN=$$FIND(X,LRFILE,.NTEXT)
. Q:LRFIEN
. S (X,SCTP)=$G(DATA("P"))
. S:SCTP="" SCTP=DATA("F")
. I X'="" S LRFIEN=$$FIND(X,LRFILE,.NTEXT)
. Q:LRFIEN
. ; re-sort "S"YNonym array from longest $L to shortest this results in using abbreviations as last resort
. K Y
. S I=0
. F S I=$O(DATA("S",I)) Q:'I D ;
. . S X=DATA("S",I)
. . S Y(65536-$L(X),I)=X
. I $D(Y) K DATA("S") M DATA("S")=Y K Y
. ;
. S NODE="DATA(""S"")"
. F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,1)'="S" D Q:LRFIEN ;
. . S X=@NODE
. . I X'="" S LRFIEN=$$FIND(X,LRFILE,.NTEXT)
. ;
. Q:LRFIEN
. I 'ADD S LRFIEN="0^Function CHKSCT auto-add disabled" Q
. ;
. ; add new entry into target file using LEX info and stop
. K LRIN
. S LRIN(.01)=$$DELHIER^LRSCT(SCTP) ; SCT Preferred term
. I LRLEXSCT D ; only set SCT info if valid SCT code
. . S LRIN(20)=LRSCT
. . S LRIN(21)="PREFERRED TERM"
. . S X=SCTHIER
. . I X'="" S X="SCT "_X
. . I $D(^LAB(64.061,"C",$$UP^XLFSTR(X))) D ;
. . . S LRIN(22)=X
. . ;
. ;
. S LR6247=$G(HLINFO("R6247"))
. S LRFIEN=$$FILE^LRSCTX1(LRFILE,.LRIN,.LRERROR,.HLINFO)
. I LRFIEN S LRFIEN=LRFIEN_"^1" ; indicates new entry
. I 'LRFIEN S LRFIEN="0^"_$P($G(LRERROR),"^",2)
;
Q LRFIEN
;
;
FIND(LRTXT,LRFILE,NTEXT) ;
; Private helper method
; Tries to find a matching text entry in the file specified.
; Inputs
; LRTXT: Text of term
; LRFILE: File # to use
; NTEXT:<byref> See Outputs
; Outputs
; 0 if no match, else the IEN of the matching record.
; NTEXT: New text to use for .01 field
;
; Converts ^ to ~
; Looks for exact match in LRFILE on B & C xrefs.
; $$TRIMs LRTXT then looks for any match in xref B & xref C
; Passes an array of possible matches to $$FIND
; Strips off any SCT hierarchy text and tries again
; If no match returns 0
;
N LRNIEN,DIERR,LRDATA,LRMSG,TXT2,X
S LRTXT=$G(LRTXT)
S LRFILE=$G(LRFILE)
S LRNIEN=0
S LRTXT=$TR(LRTXT,"^","~") ;also in FILE method
;exact text match?
S LRNIEN=$$FIND1^DIC(LRFILE,,"OX",LRTXT,"B^C",,"LRMSG")
I LRNIEN Q LRNIEN
;
; check B index first
K LRDATA,LRMSG,DIERR
D FIND^DIC(LRFILE,,"@;.01;20","M",$$TRIM^XLFSTR(LRTXT),,"B",,,"LRDATA","LRMSG")
S LRNIEN=$$MATCH(LRTXT,.LRDATA)
;
; check C index (synonym)
I 'LRNIEN D ;
. K LRDATA,LRMSG,DIERR
. D FIND^DIC(LRFILE,,"@;.01;20","M",$$TRIM^XLFSTR(LRTXT),,"C",,,"LRDATA","LRMSG")
. Q:'$D(LRDATA("DILIST",2))
. S LRNIEN=$$MATCH(LRTXT,.LRDATA)
;
; strip SCT top level name off and try again ie: this is text (body structure)
S X=$$TRIM^XLFSTR(LRTXT)
; last char = ) and also contains a (
I 'LRNIEN I $E(X,$L(X),$L(X))=")" I X["(" D ;
. S TXT2=$$DELHIER^LRSCT(X)
. Q:X=TXT2
. K LRDATA,LRMSG,DIERR
. D FIND^DIC(LRFILE,,"@;.01;20","M",TXT2,,"B",,,"LRDATA","LRMSG")
. S LRNIEN=$$MATCH(TXT2,.LRDATA)
. I LRNIEN D Q ;
. . S NTEXT=TXT2
. ;
. Q:LRNIEN
. ; check C index (synonym)
. K LRDATA,LRMSG,DIERR
. D FIND^DIC(LRFILE,,"@;.01;20","M",TXT2,,"C",,,"LRDATA","LRMSG")
. I $D(LRDATA("DILIST",2)) D ;
. . S LRNIEN=$$MATCH(TXT2,.LRDATA)
. . I LRNIEN S NTEXT=TXT2
. ;
;
Q LRNIEN
;
;
MATCH(TEXT,DATA) ;
; Private helper method
; Scan the DATA array for an entry that matches TEXT.
; Inputs
; TEXT: The .01 text to match on
; DATA: <byref> a DILIST array from FIND^DIC
; Outputs
; 0 = no match or the IEN of the matching record.
;
; Note: $$TRIMS and $$UPs for text comparisons.
; 1) Looks for entries in DATA that have an SCT code. If TEXT matches .01 text use that entry.
; 2) If no entries with SCT code match, check rest of DATA array.
;
N I,LRIEN,REC,NM,SCT,TXT2
S TEXT=$G(TEXT)
S TXT2=$$TRIM^XLFSTR($$UP^XLFSTR(TEXT))
S LRIEN=0
; find one with an SCT code first
S I=0
F S I=$O(DATA("DILIST","ID",I)) Q:'I D Q:LRIEN ;
. S SCT=DATA("DILIST","ID",I,20)
. Q:SCT=""
. ; Should it only be a valid SCT code? does name match?
. S REC=DATA("DILIST",2,I)
. S NM=DATA("DILIST","ID",I,.01)
. Q:$$TRIM^XLFSTR($$UP^XLFSTR(NM))'=TXT2
. S LRIEN=REC
;
I LRIEN Q LRIEN
S I=0
F S I=$O(DATA("DILIST",2,I)) Q:'I D Q:LRIEN ;
. S REC=DATA("DILIST",2,I)
. S NM=DATA("DILIST","ID",I,.01)
. Q:$$TRIM^XLFSTR($$UP^XLFSTR(NM))'=TXT2
. S LRIEN=REC
Q LRIEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSCTX 8556 printed Apr 09, 2024@21:22:32 Page 2
LRSCTX ;DALOI/FHS/JDB - FIND TERM OR ADD TO FILE ;04/10/12 15:41
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 QUIT
+4 ;
+5 ;
EN(LRFILE,LRTXT,LRSCT,LRHL7,LRERROR,CHECK) ;
+1 ; Main entry point for LRSCTX.
+2 ; Returns a matching entry for LRTXT in LRFILE or creates a new entry in LRFILE for LRTXT.
+3 ; Called by OBX^LA7VIN7
+4 ;
+5 ; Inputs
+6 ; LRFILE: File # to search (61, 61.2, 62)
+7 ; LRTXT: Text to find
+8 ; LRSCT: <opt> SNOMED CT code
+9 ; LRHL7: <byref><opt> HL7 info array
+10 ; ("R4")=File #4 IEN
+11 ; ("R6247")=File #62.47 IEN
+12 ; ("FSEC")=HL7 Field separator and Encoding characters
+13 ; ("MSH",3)=Sending Application
+14 ; ("MSH",4)=Sending Facility
+15 ; ("MSH",5)=Receiving Application
+16 ; ("MSH",6)=Receiving Facility
+17 ; ("MSH",11)=Message ID
+18 ; ("OBX",3)=OBX-3 (raw)
+19 ; ("OBX",5)=OBX-5 (raw)
+20 ; LRERROR:<byref> See Outputs
+21 ; CHECK:<opt> 1=Check for match, dont add
+22 ;
+23 ; Outputs (record # plus info)
+24 ; problem: 0^error msg -OR- IEN or "IEN^1" (^1=new entry flag)
+25 ; LRERROR array contains any error message associated.
+26 ;
+27 NEW DATA,DIERR,I,LR6247,LRDATA,LRFIEN,LRFSEC,LRLEXSCT,LRMSG,LRX,SCTP,NTEXT,X,Y
+28 NEW NODE,DIERR
+29 SET LRFILE=$GET(LRFILE)
+30 SET LRTXT=$GET(LRTXT)
+31 SET LRSCT=$GET(LRSCT)
+32 SET CHECK=$GET(CHECK)
+33 SET LRFSEC=$GET(LRHL7("FSEC"))
+34 SET LR6247=$GET(LRHL7("R6247"))
+35 IF LRFILE'?1(1"61",1"61.2",1"62")
QUIT "0^Unknown file #"_LRFILE
+36 ;
+37 ;IEN of matching/new file's entry
SET LRFIEN=0
+38 ;
+39 ; If SCT code, use LEX data if valid SCT code
+40 IF LRSCT'=""
SET LRFIEN=$$CHKSCT(LRFILE,LRSCT,.LRHL7,1)
+41 ;
+42 IF LRFIEN
QUIT LRFIEN
+43 IF $TRANSLATE(LRTXT," ","")=""
QUIT "0^Text is empty"
+44 ;
+45 ; Didnt find a valid SCT code/text match so keep searching
+46 ; Search for the text passed in
+47 KILL NTEXT
+48 SET LRFIEN=$$FIND(LRTXT,LRFILE,.NTEXT)
+49 IF LRFIEN
QUIT LRFIEN
+50 ;
+51 ; Check SCT database for a text match
+52 SET LRX=$$TXT4CS^LRSCT($$TRIM^XLFSTR(LRTXT),"SCT",.DATA)
+53 ; Use SCT code from synonym only if just one SCT matches
+54 IF LRX="1"
Begin DoDot:1
+55 NEW SCT
+56 SET SCT=$ORDER(DATA(0))
+57 if SCT=""
QUIT
+58 SET X=$$CODE^LRSCT(SCT,"SCT")
+59 ;valid SCT?
if X'>0
QUIT
+60 ; find IEN of associated SCT code in target file
+61 SET LRFIEN=$$SCT2IEN^LA7VHLU6(SCT,LRTXT,"",LRFILE,"","")
+62 if LRFIEN
QUIT
+63 ; do a file search for this SCT
+64 SET LRFIEN=$$CHKSCT(LRFILE,SCT,.LRHL7,1)
+65 if LRFIEN
QUIT
+66 ; file error
+67 IF 'LRFIEN
SET X=$PIECE(LRFIEN,"^",2)
IF X'=""
SET LRFIEN="O^"_X
QUIT
+68 KILL NTEXT
+69 ; Search for the text passed in (trimmed)
+70 SET LRFIEN=$$FIND($$TRIM^XLFSTR(LRTXT),LRFILE,.NTEXT)
End DoDot:1
+71 ;
+72 ; No matches so need to add new entry
+73 IF 'LRFIEN
IF 'CHECK
Begin DoDot:1
+74 NEW LRIN
+75 KILL LRERROR
+76 SET LRIN(.01)=$$TRIM^XLFSTR(LRTXT)
+77 ; new term so set as "refer to ETS"
+78 SET LRIN(21)="REFERRED"
+79 SET LRFIEN=$$FILE^LRSCTX1(LRFILE,.LRIN,.LRERROR,.LRHL7)
+80 ;new entry created
IF LRFIEN
SET LRFIEN=LRFIEN_"^1"
+81 IF 'LRFIEN
SET X=$PIECE($GET(LRERROR),"^",2)
IF X'=""
SET LRFIEN="0^"_X
End DoDot:1
+82 ;
+83 QUIT LRFIEN
+84 ;
+85 ;
CHKSCT(LRFILE,LRSCT,HLINFO,ADD,INACTIVE) ;
+1 ; Private helper method
+2 ; Checks for an SCT match. If no existing LRFILE entry is found using the LEX data, a new entry in LRFILE will be created automatically.
+3 ; Inputs
+4 ; LRFILE: File number to search/add entry to (61, 61.2, 62)
+5 ; LRSCT: SCT Code to use for search
+6 ; HLINFO:<byref> (from EN^LRSCTX)
+7 ; ADD:<opt> dflt=0 0=dont add new entry 1=add new entry
+8 ; INACTIVE: <opt>0 or 1 <dflt=0> 1=use SCT even if inactive
+9 ; Outputs
+10 ; The IEN of the entry found or created.
+11 ; If a file error occurred, output=0 and the second "^" piece contains error info. ie "0^Unknown file #"
+12 ;
+13 NEW DATA,I,LRERROR,LRFIEN,LRLEXSCT,LRIN,NODE,NTEXT,SCTP,X,Y
+14 SET LRFILE=$GET(LRFILE)
SET LRSCT=$GET(LRSCT)
SET INACTIVE=$GET(INACTIVE,0)
SET ADD=$GET(ADD,0)
+15 SET LRFIEN=0
+16 ;
+17 ; SCT code in target file?
+18 IF LRFILE
IF LRSCT'=""
SET LRFIEN=$$SCT2IEN^LA7VHLU6(LRSCT,"","",LRFILE,"","")
+19 ;
+20 ; Get SCT info from LEX
+21 IF 'LRFIEN
Begin DoDot:1
+22 NEW DATA,LR6247,SCTHIER
+23 SET LRLEXSCT=$$CODE^LRSCT(LRSCT,"SCT","","DATA")
+24 if LRLEXSCT=-1
QUIT
+25 ; dont use if invalid SCT code
IF 'INACTIVE
if LRLEXSCT'>0
QUIT
+26 IF INACTIVE
IF LRLEXSCT'>0!(LRLEXSCT'=-2)
QUIT
+27 SET SCTHIER=$PIECE($GET(DATA(0)),"^",2)
+28 ; check for targ file matches on SCT main, preferred, & synonyms
+29 SET X=$GET(DATA("F"))
+30 IF X'=""
SET LRFIEN=$$FIND(X,LRFILE,.NTEXT)
+31 if LRFIEN
QUIT
+32 SET (X,SCTP)=$GET(DATA("P"))
+33 if SCTP=""
SET SCTP=DATA("F")
+34 IF X'=""
SET LRFIEN=$$FIND(X,LRFILE,.NTEXT)
+35 if LRFIEN
QUIT
+36 ; re-sort "S"YNonym array from longest $L to shortest this results in using abbreviations as last resort
+37 KILL Y
+38 SET I=0
+39 ;
FOR
SET I=$ORDER(DATA("S",I))
if 'I
QUIT
Begin DoDot:2
+40 SET X=DATA("S",I)
+41 SET Y(65536-$LENGTH(X),I)=X
End DoDot:2
+42 IF $DATA(Y)
KILL DATA("S")
MERGE DATA("S")=Y
KILL Y
+43 ;
+44 SET NODE="DATA(""S"")"
+45 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,1)'="S"
QUIT
Begin DoDot:2
+46 SET X=@NODE
+47 IF X'=""
SET LRFIEN=$$FIND(X,LRFILE,.NTEXT)
End DoDot:2
if LRFIEN
QUIT
+48 ;
+49 if LRFIEN
QUIT
+50 IF 'ADD
SET LRFIEN="0^Function CHKSCT auto-add disabled"
QUIT
+51 ;
+52 ; add new entry into target file using LEX info and stop
+53 KILL LRIN
+54 ; SCT Preferred term
SET LRIN(.01)=$$DELHIER^LRSCT(SCTP)
+55 ; only set SCT info if valid SCT code
IF LRLEXSCT
Begin DoDot:2
+56 SET LRIN(20)=LRSCT
+57 SET LRIN(21)="PREFERRED TERM"
+58 SET X=SCTHIER
+59 IF X'=""
SET X="SCT "_X
+60 ;
IF $DATA(^LAB(64.061,"C",$$UP^XLFSTR(X)))
Begin DoDot:3
+61 SET LRIN(22)=X
End DoDot:3
+62 ;
End DoDot:2
+63 ;
+64 SET LR6247=$GET(HLINFO("R6247"))
+65 SET LRFIEN=$$FILE^LRSCTX1(LRFILE,.LRIN,.LRERROR,.HLINFO)
+66 ; indicates new entry
IF LRFIEN
SET LRFIEN=LRFIEN_"^1"
+67 IF 'LRFIEN
SET LRFIEN="0^"_$PIECE($GET(LRERROR),"^",2)
End DoDot:1
+68 ;
+69 QUIT LRFIEN
+70 ;
+71 ;
FIND(LRTXT,LRFILE,NTEXT) ;
+1 ; Private helper method
+2 ; Tries to find a matching text entry in the file specified.
+3 ; Inputs
+4 ; LRTXT: Text of term
+5 ; LRFILE: File # to use
+6 ; NTEXT:<byref> See Outputs
+7 ; Outputs
+8 ; 0 if no match, else the IEN of the matching record.
+9 ; NTEXT: New text to use for .01 field
+10 ;
+11 ; Converts ^ to ~
+12 ; Looks for exact match in LRFILE on B & C xrefs.
+13 ; $$TRIMs LRTXT then looks for any match in xref B & xref C
+14 ; Passes an array of possible matches to $$FIND
+15 ; Strips off any SCT hierarchy text and tries again
+16 ; If no match returns 0
+17 ;
+18 NEW LRNIEN,DIERR,LRDATA,LRMSG,TXT2,X
+19 SET LRTXT=$GET(LRTXT)
+20 SET LRFILE=$GET(LRFILE)
+21 SET LRNIEN=0
+22 ;also in FILE method
SET LRTXT=$TRANSLATE(LRTXT,"^","~")
+23 ;exact text match?
+24 SET LRNIEN=$$FIND1^DIC(LRFILE,,"OX",LRTXT,"B^C",,"LRMSG")
+25 IF LRNIEN
QUIT LRNIEN
+26 ;
+27 ; check B index first
+28 KILL LRDATA,LRMSG,DIERR
+29 DO FIND^DIC(LRFILE,,"@;.01;20","M",$$TRIM^XLFSTR(LRTXT),,"B",,,"LRDATA","LRMSG")
+30 SET LRNIEN=$$MATCH(LRTXT,.LRDATA)
+31 ;
+32 ; check C index (synonym)
+33 ;
IF 'LRNIEN
Begin DoDot:1
+34 KILL LRDATA,LRMSG,DIERR
+35 DO FIND^DIC(LRFILE,,"@;.01;20","M",$$TRIM^XLFSTR(LRTXT),,"C",,,"LRDATA","LRMSG")
+36 if '$DATA(LRDATA("DILIST",2))
QUIT
+37 SET LRNIEN=$$MATCH(LRTXT,.LRDATA)
End DoDot:1
+38 ;
+39 ; strip SCT top level name off and try again ie: this is text (body structure)
+40 SET X=$$TRIM^XLFSTR(LRTXT)
+41 ; last char = ) and also contains a (
+42 ;
IF 'LRNIEN
IF $EXTRACT(X,$LENGTH(X),$LENGTH(X))=")"
IF X["("
Begin DoDot:1
+43 SET TXT2=$$DELHIER^LRSCT(X)
+44 if X=TXT2
QUIT
+45 KILL LRDATA,LRMSG,DIERR
+46 DO FIND^DIC(LRFILE,,"@;.01;20","M",TXT2,,"B",,,"LRDATA","LRMSG")
+47 SET LRNIEN=$$MATCH(TXT2,.LRDATA)
+48 ;
IF LRNIEN
Begin DoDot:2
+49 SET NTEXT=TXT2
End DoDot:2
QUIT
+50 ;
+51 if LRNIEN
QUIT
+52 ; check C index (synonym)
+53 KILL LRDATA,LRMSG,DIERR
+54 DO FIND^DIC(LRFILE,,"@;.01;20","M",TXT2,,"C",,,"LRDATA","LRMSG")
+55 ;
IF $DATA(LRDATA("DILIST",2))
Begin DoDot:2
+56 SET LRNIEN=$$MATCH(TXT2,.LRDATA)
+57 IF LRNIEN
SET NTEXT=TXT2
End DoDot:2
+58 ;
End DoDot:1
+59 ;
+60 QUIT LRNIEN
+61 ;
+62 ;
MATCH(TEXT,DATA) ;
+1 ; Private helper method
+2 ; Scan the DATA array for an entry that matches TEXT.
+3 ; Inputs
+4 ; TEXT: The .01 text to match on
+5 ; DATA: <byref> a DILIST array from FIND^DIC
+6 ; Outputs
+7 ; 0 = no match or the IEN of the matching record.
+8 ;
+9 ; Note: $$TRIMS and $$UPs for text comparisons.
+10 ; 1) Looks for entries in DATA that have an SCT code. If TEXT matches .01 text use that entry.
+11 ; 2) If no entries with SCT code match, check rest of DATA array.
+12 ;
+13 NEW I,LRIEN,REC,NM,SCT,TXT2
+14 SET TEXT=$GET(TEXT)
+15 SET TXT2=$$TRIM^XLFSTR($$UP^XLFSTR(TEXT))
+16 SET LRIEN=0
+17 ; find one with an SCT code first
+18 SET I=0
+19 ;
FOR
SET I=$ORDER(DATA("DILIST","ID",I))
if 'I
QUIT
Begin DoDot:1
+20 SET SCT=DATA("DILIST","ID",I,20)
+21 if SCT=""
QUIT
+22 ; Should it only be a valid SCT code? does name match?
+23 SET REC=DATA("DILIST",2,I)
+24 SET NM=DATA("DILIST","ID",I,.01)
+25 if $$TRIM^XLFSTR($$UP^XLFSTR(NM))'=TXT2
QUIT
+26 SET LRIEN=REC
End DoDot:1
if LRIEN
QUIT
+27 ;
+28 IF LRIEN
QUIT LRIEN
+29 SET I=0
+30 ;
FOR
SET I=$ORDER(DATA("DILIST",2,I))
if 'I
QUIT
Begin DoDot:1
+31 SET REC=DATA("DILIST",2,I)
+32 SET NM=DATA("DILIST","ID",I,.01)
+33 if $$TRIM^XLFSTR($$UP^XLFSTR(NM))'=TXT2
QUIT
+34 SET LRIEN=REC
End DoDot:1
if LRIEN
QUIT
+35 QUIT LRIEN
