LRSCT ;DALOI/STAFF - SNOMED SCT UTILITIES ;01/10/11 10:46
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
;
Q
;
CODE(LRCODE,LRSRC,LRDT,LRARR) ;
;
; Wrapper for LEX CODE API
; If LRARR not specified, the default LEX array is killed on exit
; Inputs
; LRCODE : The SCT code
; LRSRC : The code source
; LRDT : <opt> The effective date
; LRARR : <opt><byname> The output array (not byref)
; Outputs
; The modified CODE^LEXTRAN return string:
; 1=valid -1=not found -2=inactive -99=API error
; The CODE^LEXTRAN output array (in LRARR)
;
N STATUS,LRX,STOP,X
N DIERR,LEX ; New LEX which is used/returned by Lexicon when return array not defined.
S LRARR=$G(LRARR)
I LRARR'="" K @LRARR
I $G(LRDT)="" S LRDT=$$DT^XLFDT()
S STOP=0
S STATUS=$$CODE^LEXTRAN($G(LRCODE),$G(LRSRC),$G(LRDT),LRARR)
;
I +STATUS=-2 D
. S STOP=1
. S $P(STATUS,"^",1)=-1
;
I +STATUS=-4 D
. S STOP=1,$P(STATUS,"^",1)=-2
. S X=$P(STATUS,"not active for ",2)
. I X?1(7N,7N1"."1.N) S $P(STATUS,"not active for ",2)=$$FMTE^XLFDT(X,"MZ")
;
I +STATUS=-8 D
. S STOP=1,$P(STATUS,"^",1)=-2
. S X=+$P(STATUS," ",2)
. I X?1(7N,7N1"."1.N) S $P(STATUS," ",2)=$$FMTE^XLFDT(X,"MZ")
. I LRDT=DT Q
. K:LRARR'="" @LRARR
. S LRX=$$CODE^LEXTRAN(LRCODE,LRSRC,DT,LRARR)
;
I 'STOP,+STATUS=-1 S $P(STATUS,"^",1)=-99
;
Q STATUS
;
;
SCTOK(SCT,DATE,LROUT) ;
; Is this SCT code valid?
; Inputs
; SCT : The SCT Code
; DATE :<opt> The date to use for the lookup (defaults to today)
; LROUT :<opt><byref> Holds the SCT code info. See Outputs.
;
; Outputs
; Returns 0 if invalid or 1 if valid
; Returns SCT info in the LROUT array
;
N LRZ,STATUS
N DIERR
S SCT=$G(SCT)
S DATE=$G(DATE)
S LROUT=$G(LROUT)
I 'DATE S DATE=$$DT^XLFDT()
S STATUS=0
S STATUS=+$$CODE(SCT,"SCT",DATE,"LRZ")
M LROUT=LRZ
I +STATUS'=1 S STATUS=0
Q STATUS
;
;
GETSCT(LRFILE,LRIEN) ;
; Returns the SCT code for the File/record specified
; Inputs
; LRFILE: File # (61, 62, 61.2)
; LRIEN: IEN of file entry
N LRFLD
N DIERR,LRTARG,LRMSG
S LRFLD=""
I LRFILE=61 S LRFLD=20
I LRFILE=62 S LRFLD=20
I LRFILE=61.2 S LRFLD=20
I 'LRFLD Q 0
Q $$GET1^DIQ(LRFILE,LRIEN_",",LRFLD,"I","LRTARG","LRMSG")
;
;
FINDSCT(LRFILE,LRSCT) ;
; Finds an SCT code in the specified file.
; Inputs
; LRFILE: File number
; LRSCT: The SCT code
; Outputs
; "IEN^external value" of the entry from the specified file.
;
N LRIEN,NAME,DATA
S LRFILE=$G(LRFILE)
S LRSCT=$G(LRSCT)
I 'LRFILE Q 0
I LRSCT="" Q 0
S LRIEN=0
S DATA=""
I LRFILE=61 D ;
. S LRIEN=+$O(^LAB(61,"F",LRSCT,0))
. I LRIEN S DATA=$G(^LAB(61,LRIEN,0))
;
I LRFILE=61.2 D ;
. S LRIEN=+$O(^LAB(61.2,"F",LRSCT,0))
. I LRIEN S DATA=$G(^LAB(61.2,LRIEN,0))
;
I LRFILE=62 D ;
. S LRIEN=+$O(^LAB(62,"F",LRSCT,0))
. I LRIEN S DATA=$G(^LAB(62,LRIEN,0))
;
S NAME=$P(DATA,U,1)
I LRIEN S LRIEN=LRIEN_"^"_NAME
Q LRIEN
;
;
GETPREF(SCT) ;
; Returns the Preferred Name for an SCT code
N PREF,DATA,X
S PREF=""
S X=$$CODE(SCT,"SCT",,"DATA")
S PREF=$G(DATA("P"))
Q PREF
;
;
;
GETFSN(SCT) ;
; Returns fully specified SCT term
N FSN,DATA,X
S FSN=""
S X=$$CODE(SCT,"SCT",,"DATA")
S FSN=$G(DATA("F"))
Q FSN
;
;
TXT4CS(LRTXT,LRCS,LRARR,LRHIER) ;
;
; Inputs
; LRTXT: Text to find in SCT codeset
; LRCS: Codeset to search (dflt=SCT)
; LRARR:<byref> See Outputs
; LRHIER:<opt>
; Outputs
; Returns # of matches" or "0^error message"
; LRARR array will contain info about matches
; LRARR(code)=hierarchy
;
N X,LEX,DIERR
S LRTXT=$G(LRTXT)
S LRCS=$G(LRCS,"SCT")
S LRHIER=$G(LRHIER)
K LRARR
S X=$$TXT4CS^LEXTRAN(LRTXT,LRCS,"",LRHIER)
I X>0 S X=$P(X,"^",2)
I X<0 S $P(X,"^",1)=0
M LRARR=LEX
Q X
;
;
DELHIER(TEXT) ;
; Removes any SCT Hierachy text from TEXT
; Inputs
; TEXT: The text to check
; Outputs -- The text less the SCT Hierarchy (if applicable)
N STR,X
S TEXT=$G(TEXT)
S STR=TEXT
S STR=$$TRIM^XLFSTR(STR)
; last char = ) and also contains a (
I $E(STR,$L(STR),$L(STR))=")" I STR["(" D ;
. N TXT2,TXT3,STOP
. S STOP=0
. ; Text to use -- ie: this is the text
. S TXT2=$RE(TEXT) S TXT2=$P(TXT2,"(",2,$L(TXT2)) S TXT2=$RE(TXT2)
. S TXT2=$$TRIM^XLFSTR(TXT2)
. ; get last ( piece -- ie: (body structure)
. S TXT3=$RE(TEXT) S TXT3=$P(TXT3,"(",1) S TXT3=$RE(TXT3) S TXT3=$P(TXT3,")",1)
. S TXT3=$$TRIM^XLFSTR(TXT3)
. Q:TXT3=""
. S X="SCT "_TXT3
. S STOP=1
. ; dont remove non-SCT hierarchy phrases in paranthesis
. I $D(^LAB(64.061,"B",X)) S STOP=0 ;valid SCT Hierachy?
. I $D(^LAB(64.061,"C",$$UP^XLFSTR(X))) S STOP=0
. Q:STOP
. S STR=TXT2
Q STR
;
;
LEX6247(R6247,LROUT) ;
; Gets SCT/LEX info for a File #62.47 entry
; Inputs
; R6247: File #62.47 IEN
; LROUT:<byref><opt>
; Outputs
; Returns the #64.061 IEN of the #62.47 entry queried.
; Also returns aditional info in the LROUT array:
; LROUT("SCTIEN")
; LROUT("SCTTOP")
; LROUT("LEXABRV")
;
N R64061,SCTIEN,DATA,X
S R6247=+$G(R6247)
K LROUT
S LROUT("SCTIEN")=""
S LROUT("SCTTOP")=""
S LROUT("LEXABRV")=""
I 'R6247 Q 0
S DATA=$G(^LAB(62.47,R6247,0))
S R64061=$P(DATA,U,3) ;fld .03
I 'R64061 Q 0
S DATA=$G(^LAB(64.061,R64061,63))
S SCTIEN=$P(DATA,U,4) ;fld 63.3
S LROUT("SCTIEN")=SCTIEN ;IEN
S DATA=$G(^LAB(64.061,+SCTIEN,0))
S X=$P(DATA,U,1)
S LROUT("SCTTOP")=X
;S DATA=$G(^LAB(64.061,+SCTIEN,0))
;S X=$P(DATA,U,1)
;S LROUT("SCTHIER")=X
S DATA=$G(^LAB(64.061,+SCTIEN,1))
S X=$P(DATA,U,1) ;fld 12
S LROUT("LEXABRV")=X
Q R64061
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSCT 5726 printed Sep 23, 2025@19:55:55 Page 2
LRSCT ;DALOI/STAFF - SNOMED SCT UTILITIES ;01/10/11 10:46
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 ;
+4 QUIT
+5 ;
CODE(LRCODE,LRSRC,LRDT,LRARR) ;
+1 ;
+2 ; Wrapper for LEX CODE API
+3 ; If LRARR not specified, the default LEX array is killed on exit
+4 ; Inputs
+5 ; LRCODE : The SCT code
+6 ; LRSRC : The code source
+7 ; LRDT : <opt> The effective date
+8 ; LRARR : <opt><byname> The output array (not byref)
+9 ; Outputs
+10 ; The modified CODE^LEXTRAN return string:
+11 ; 1=valid -1=not found -2=inactive -99=API error
+12 ; The CODE^LEXTRAN output array (in LRARR)
+13 ;
+14 NEW STATUS,LRX,STOP,X
+15 ; New LEX which is used/returned by Lexicon when return array not defined.
NEW DIERR,LEX
+16 SET LRARR=$GET(LRARR)
+17 IF LRARR'=""
KILL @LRARR
+18 IF $GET(LRDT)=""
SET LRDT=$$DT^XLFDT()
+19 SET STOP=0
+20 SET STATUS=$$CODE^LEXTRAN($GET(LRCODE),$GET(LRSRC),$GET(LRDT),LRARR)
+21 ;
+22 IF +STATUS=-2
Begin DoDot:1
+23 SET STOP=1
+24 SET $PIECE(STATUS,"^",1)=-1
End DoDot:1
+25 ;
+26 IF +STATUS=-4
Begin DoDot:1
+27 SET STOP=1
SET $PIECE(STATUS,"^",1)=-2
+28 SET X=$PIECE(STATUS,"not active for ",2)
+29 IF X?1(7N,7N1"."1.N)
SET $PIECE(STATUS,"not active for ",2)=$$FMTE^XLFDT(X,"MZ")
End DoDot:1
+30 ;
+31 IF +STATUS=-8
Begin DoDot:1
+32 SET STOP=1
SET $PIECE(STATUS,"^",1)=-2
+33 SET X=+$PIECE(STATUS," ",2)
+34 IF X?1(7N,7N1"."1.N)
SET $PIECE(STATUS," ",2)=$$FMTE^XLFDT(X,"MZ")
+35 IF LRDT=DT
QUIT
+36 if LRARR'=""
KILL @LRARR
+37 SET LRX=$$CODE^LEXTRAN(LRCODE,LRSRC,DT,LRARR)
End DoDot:1
+38 ;
+39 IF 'STOP
IF +STATUS=-1
SET $PIECE(STATUS,"^",1)=-99
+40 ;
+41 QUIT STATUS
+42 ;
+43 ;
SCTOK(SCT,DATE,LROUT) ;
+1 ; Is this SCT code valid?
+2 ; Inputs
+3 ; SCT : The SCT Code
+4 ; DATE :<opt> The date to use for the lookup (defaults to today)
+5 ; LROUT :<opt><byref> Holds the SCT code info. See Outputs.
+6 ;
+7 ; Outputs
+8 ; Returns 0 if invalid or 1 if valid
+9 ; Returns SCT info in the LROUT array
+10 ;
+11 NEW LRZ,STATUS
+12 NEW DIERR
+13 SET SCT=$GET(SCT)
+14 SET DATE=$GET(DATE)
+15 SET LROUT=$GET(LROUT)
+16 IF 'DATE
SET DATE=$$DT^XLFDT()
+17 SET STATUS=0
+18 SET STATUS=+$$CODE(SCT,"SCT",DATE,"LRZ")
+19 MERGE LROUT=LRZ
+20 IF +STATUS'=1
SET STATUS=0
+21 QUIT STATUS
+22 ;
+23 ;
GETSCT(LRFILE,LRIEN) ;
+1 ; Returns the SCT code for the File/record specified
+2 ; Inputs
+3 ; LRFILE: File # (61, 62, 61.2)
+4 ; LRIEN: IEN of file entry
+5 NEW LRFLD
+6 NEW DIERR,LRTARG,LRMSG
+7 SET LRFLD=""
+8 IF LRFILE=61
SET LRFLD=20
+9 IF LRFILE=62
SET LRFLD=20
+10 IF LRFILE=61.2
SET LRFLD=20
+11 IF 'LRFLD
QUIT 0
+12 QUIT $$GET1^DIQ(LRFILE,LRIEN_",",LRFLD,"I","LRTARG","LRMSG")
+13 ;
+14 ;
FINDSCT(LRFILE,LRSCT) ;
+1 ; Finds an SCT code in the specified file.
+2 ; Inputs
+3 ; LRFILE: File number
+4 ; LRSCT: The SCT code
+5 ; Outputs
+6 ; "IEN^external value" of the entry from the specified file.
+7 ;
+8 NEW LRIEN,NAME,DATA
+9 SET LRFILE=$GET(LRFILE)
+10 SET LRSCT=$GET(LRSCT)
+11 IF 'LRFILE
QUIT 0
+12 IF LRSCT=""
QUIT 0
+13 SET LRIEN=0
+14 SET DATA=""
+15 ;
IF LRFILE=61
Begin DoDot:1
+16 SET LRIEN=+$ORDER(^LAB(61,"F",LRSCT,0))
+17 IF LRIEN
SET DATA=$GET(^LAB(61,LRIEN,0))
End DoDot:1
+18 ;
+19 ;
IF LRFILE=61.2
Begin DoDot:1
+20 SET LRIEN=+$ORDER(^LAB(61.2,"F",LRSCT,0))
+21 IF LRIEN
SET DATA=$GET(^LAB(61.2,LRIEN,0))
End DoDot:1
+22 ;
+23 ;
IF LRFILE=62
Begin DoDot:1
+24 SET LRIEN=+$ORDER(^LAB(62,"F",LRSCT,0))
+25 IF LRIEN
SET DATA=$GET(^LAB(62,LRIEN,0))
End DoDot:1
+26 ;
+27 SET NAME=$PIECE(DATA,U,1)
+28 IF LRIEN
SET LRIEN=LRIEN_"^"_NAME
+29 QUIT LRIEN
+30 ;
+31 ;
GETPREF(SCT) ;
+1 ; Returns the Preferred Name for an SCT code
+2 NEW PREF,DATA,X
+3 SET PREF=""
+4 SET X=$$CODE(SCT,"SCT",,"DATA")
+5 SET PREF=$GET(DATA("P"))
+6 QUIT PREF
+7 ;
+8 ;
+9 ;
GETFSN(SCT) ;
+1 ; Returns fully specified SCT term
+2 NEW FSN,DATA,X
+3 SET FSN=""
+4 SET X=$$CODE(SCT,"SCT",,"DATA")
+5 SET FSN=$GET(DATA("F"))
+6 QUIT FSN
+7 ;
+8 ;
TXT4CS(LRTXT,LRCS,LRARR,LRHIER) ;
+1 ;
+2 ; Inputs
+3 ; LRTXT: Text to find in SCT codeset
+4 ; LRCS: Codeset to search (dflt=SCT)
+5 ; LRARR:<byref> See Outputs
+6 ; LRHIER:<opt>
+7 ; Outputs
+8 ; Returns # of matches" or "0^error message"
+9 ; LRARR array will contain info about matches
+10 ; LRARR(code)=hierarchy
+11 ;
+12 NEW X,LEX,DIERR
+13 SET LRTXT=$GET(LRTXT)
+14 SET LRCS=$GET(LRCS,"SCT")
+15 SET LRHIER=$GET(LRHIER)
+16 KILL LRARR
+17 SET X=$$TXT4CS^LEXTRAN(LRTXT,LRCS,"",LRHIER)
+18 IF X>0
SET X=$PIECE(X,"^",2)
+19 IF X<0
SET $PIECE(X,"^",1)=0
+20 MERGE LRARR=LEX
+21 QUIT X
+22 ;
+23 ;
DELHIER(TEXT) ;
+1 ; Removes any SCT Hierachy text from TEXT
+2 ; Inputs
+3 ; TEXT: The text to check
+4 ; Outputs -- The text less the SCT Hierarchy (if applicable)
+5 NEW STR,X
+6 SET TEXT=$GET(TEXT)
+7 SET STR=TEXT
+8 SET STR=$$TRIM^XLFSTR(STR)
+9 ; last char = ) and also contains a (
+10 ;
IF $EXTRACT(STR,$LENGTH(STR),$LENGTH(STR))=")"
IF STR["("
Begin DoDot:1
+11 NEW TXT2,TXT3,STOP
+12 SET STOP=0
+13 ; Text to use -- ie: this is the text
+14 SET TXT2=$REVERSE(TEXT)
SET TXT2=$PIECE(TXT2,"(",2,$LENGTH(TXT2))
SET TXT2=$REVERSE(TXT2)
+15 SET TXT2=$$TRIM^XLFSTR(TXT2)
+16 ; get last ( piece -- ie: (body structure)
+17 SET TXT3=$REVERSE(TEXT)
SET TXT3=$PIECE(TXT3,"(",1)
SET TXT3=$REVERSE(TXT3)
SET TXT3=$PIECE(TXT3,")",1)
+18 SET TXT3=$$TRIM^XLFSTR(TXT3)
+19 if TXT3=""
QUIT
+20 SET X="SCT "_TXT3
+21 SET STOP=1
+22 ; dont remove non-SCT hierarchy phrases in paranthesis
+23 ;valid SCT Hierachy?
IF $DATA(^LAB(64.061,"B",X))
SET STOP=0
+24 IF $DATA(^LAB(64.061,"C",$$UP^XLFSTR(X)))
SET STOP=0
+25 if STOP
QUIT
+26 SET STR=TXT2
End DoDot:1
+27 QUIT STR
+28 ;
+29 ;
LEX6247(R6247,LROUT) ;
+1 ; Gets SCT/LEX info for a File #62.47 entry
+2 ; Inputs
+3 ; R6247: File #62.47 IEN
+4 ; LROUT:<byref><opt>
+5 ; Outputs
+6 ; Returns the #64.061 IEN of the #62.47 entry queried.
+7 ; Also returns aditional info in the LROUT array:
+8 ; LROUT("SCTIEN")
+9 ; LROUT("SCTTOP")
+10 ; LROUT("LEXABRV")
+11 ;
+12 NEW R64061,SCTIEN,DATA,X
+13 SET R6247=+$GET(R6247)
+14 KILL LROUT
+15 SET LROUT("SCTIEN")=""
+16 SET LROUT("SCTTOP")=""
+17 SET LROUT("LEXABRV")=""
+18 IF 'R6247
QUIT 0
+19 SET DATA=$GET(^LAB(62.47,R6247,0))
+20 ;fld .03
SET R64061=$PIECE(DATA,U,3)
+21 IF 'R64061
QUIT 0
+22 SET DATA=$GET(^LAB(64.061,R64061,63))
+23 ;fld 63.3
SET SCTIEN=$PIECE(DATA,U,4)
+24 ;IEN
SET LROUT("SCTIEN")=SCTIEN
+25 SET DATA=$GET(^LAB(64.061,+SCTIEN,0))
+26 SET X=$PIECE(DATA,U,1)
+27 SET LROUT("SCTTOP")=X
+28 ;S DATA=$G(^LAB(64.061,+SCTIEN,0))
+29 ;S X=$P(DATA,U,1)
+30 ;S LROUT("SCTHIER")=X
+31 SET DATA=$GET(^LAB(64.061,+SCTIEN,1))
+32 ;fld 12
SET X=$PIECE(DATA,U,1)
+33 SET LROUT("LEXABRV")=X
+34 QUIT R64061
