- 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 Jan 18, 2025@03:20:58 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