Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRSCT

LRSCT.m

Go to the documentation of this file.
  1. LRSCT ;DALOI/STAFF - SNOMED SCT UTILITIES ;01/10/11 10:46
  1. ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
  1. ;
  1. ;
  1. Q
  1. ;
  1. CODE(LRCODE,LRSRC,LRDT,LRARR) ;
  1. ;
  1. ; Wrapper for LEX CODE API
  1. ; If LRARR not specified, the default LEX array is killed on exit
  1. ; Inputs
  1. ; LRCODE : The SCT code
  1. ; LRSRC : The code source
  1. ; LRDT : <opt> The effective date
  1. ; LRARR : <opt><byname> The output array (not byref)
  1. ; Outputs
  1. ; The modified CODE^LEXTRAN return string:
  1. ; 1=valid -1=not found -2=inactive -99=API error
  1. ; The CODE^LEXTRAN output array (in LRARR)
  1. ;
  1. N STATUS,LRX,STOP,X
  1. N DIERR,LEX ; New LEX which is used/returned by Lexicon when return array not defined.
  1. S LRARR=$G(LRARR)
  1. I LRARR'="" K @LRARR
  1. I $G(LRDT)="" S LRDT=$$DT^XLFDT()
  1. S STOP=0
  1. S STATUS=$$CODE^LEXTRAN($G(LRCODE),$G(LRSRC),$G(LRDT),LRARR)
  1. ;
  1. I +STATUS=-2 D
  1. . S STOP=1
  1. . S $P(STATUS,"^",1)=-1
  1. ;
  1. I +STATUS=-4 D
  1. . S STOP=1,$P(STATUS,"^",1)=-2
  1. . S X=$P(STATUS,"not active for ",2)
  1. . I X?1(7N,7N1"."1.N) S $P(STATUS,"not active for ",2)=$$FMTE^XLFDT(X,"MZ")
  1. ;
  1. I +STATUS=-8 D
  1. . S STOP=1,$P(STATUS,"^",1)=-2
  1. . S X=+$P(STATUS," ",2)
  1. . I X?1(7N,7N1"."1.N) S $P(STATUS," ",2)=$$FMTE^XLFDT(X,"MZ")
  1. . I LRDT=DT Q
  1. . K:LRARR'="" @LRARR
  1. . S LRX=$$CODE^LEXTRAN(LRCODE,LRSRC,DT,LRARR)
  1. ;
  1. I 'STOP,+STATUS=-1 S $P(STATUS,"^",1)=-99
  1. ;
  1. Q STATUS
  1. ;
  1. ;
  1. SCTOK(SCT,DATE,LROUT) ;
  1. ; Is this SCT code valid?
  1. ; Inputs
  1. ; SCT : The SCT Code
  1. ; DATE :<opt> The date to use for the lookup (defaults to today)
  1. ; LROUT :<opt><byref> Holds the SCT code info. See Outputs.
  1. ;
  1. ; Outputs
  1. ; Returns 0 if invalid or 1 if valid
  1. ; Returns SCT info in the LROUT array
  1. ;
  1. N LRZ,STATUS
  1. N DIERR
  1. S SCT=$G(SCT)
  1. S DATE=$G(DATE)
  1. S LROUT=$G(LROUT)
  1. I 'DATE S DATE=$$DT^XLFDT()
  1. S STATUS=0
  1. S STATUS=+$$CODE(SCT,"SCT",DATE,"LRZ")
  1. M LROUT=LRZ
  1. I +STATUS'=1 S STATUS=0
  1. Q STATUS
  1. ;
  1. ;
  1. GETSCT(LRFILE,LRIEN) ;
  1. ; Returns the SCT code for the File/record specified
  1. ; Inputs
  1. ; LRFILE: File # (61, 62, 61.2)
  1. ; LRIEN: IEN of file entry
  1. N LRFLD
  1. N DIERR,LRTARG,LRMSG
  1. S LRFLD=""
  1. I LRFILE=61 S LRFLD=20
  1. I LRFILE=62 S LRFLD=20
  1. I LRFILE=61.2 S LRFLD=20
  1. I 'LRFLD Q 0
  1. Q $$GET1^DIQ(LRFILE,LRIEN_",",LRFLD,"I","LRTARG","LRMSG")
  1. ;
  1. ;
  1. FINDSCT(LRFILE,LRSCT) ;
  1. ; Finds an SCT code in the specified file.
  1. ; Inputs
  1. ; LRFILE: File number
  1. ; LRSCT: The SCT code
  1. ; Outputs
  1. ; "IEN^external value" of the entry from the specified file.
  1. ;
  1. N LRIEN,NAME,DATA
  1. S LRFILE=$G(LRFILE)
  1. S LRSCT=$G(LRSCT)
  1. I 'LRFILE Q 0
  1. I LRSCT="" Q 0
  1. S LRIEN=0
  1. S DATA=""
  1. I LRFILE=61 D ;
  1. . S LRIEN=+$O(^LAB(61,"F",LRSCT,0))
  1. . I LRIEN S DATA=$G(^LAB(61,LRIEN,0))
  1. ;
  1. I LRFILE=61.2 D ;
  1. . S LRIEN=+$O(^LAB(61.2,"F",LRSCT,0))
  1. . I LRIEN S DATA=$G(^LAB(61.2,LRIEN,0))
  1. ;
  1. I LRFILE=62 D ;
  1. . S LRIEN=+$O(^LAB(62,"F",LRSCT,0))
  1. . I LRIEN S DATA=$G(^LAB(62,LRIEN,0))
  1. ;
  1. S NAME=$P(DATA,U,1)
  1. I LRIEN S LRIEN=LRIEN_"^"_NAME
  1. Q LRIEN
  1. ;
  1. ;
  1. GETPREF(SCT) ;
  1. ; Returns the Preferred Name for an SCT code
  1. N PREF,DATA,X
  1. S PREF=""
  1. S X=$$CODE(SCT,"SCT",,"DATA")
  1. S PREF=$G(DATA("P"))
  1. Q PREF
  1. ;
  1. ;
  1. ;
  1. GETFSN(SCT) ;
  1. ; Returns fully specified SCT term
  1. N FSN,DATA,X
  1. S FSN=""
  1. S X=$$CODE(SCT,"SCT",,"DATA")
  1. S FSN=$G(DATA("F"))
  1. Q FSN
  1. ;
  1. ;
  1. TXT4CS(LRTXT,LRCS,LRARR,LRHIER) ;
  1. ;
  1. ; Inputs
  1. ; LRTXT: Text to find in SCT codeset
  1. ; LRCS: Codeset to search (dflt=SCT)
  1. ; LRARR:<byref> See Outputs
  1. ; LRHIER:<opt>
  1. ; Outputs
  1. ; Returns # of matches" or "0^error message"
  1. ; LRARR array will contain info about matches
  1. ; LRARR(code)=hierarchy
  1. ;
  1. N X,LEX,DIERR
  1. S LRTXT=$G(LRTXT)
  1. S LRCS=$G(LRCS,"SCT")
  1. S LRHIER=$G(LRHIER)
  1. K LRARR
  1. S X=$$TXT4CS^LEXTRAN(LRTXT,LRCS,"",LRHIER)
  1. I X>0 S X=$P(X,"^",2)
  1. I X<0 S $P(X,"^",1)=0
  1. M LRARR=LEX
  1. Q X
  1. ;
  1. ;
  1. DELHIER(TEXT) ;
  1. ; Removes any SCT Hierachy text from TEXT
  1. ; Inputs
  1. ; TEXT: The text to check
  1. ; Outputs -- The text less the SCT Hierarchy (if applicable)
  1. N STR,X
  1. S TEXT=$G(TEXT)
  1. S STR=TEXT
  1. S STR=$$TRIM^XLFSTR(STR)
  1. ; last char = ) and also contains a (
  1. I $E(STR,$L(STR),$L(STR))=")" I STR["(" D ;
  1. . N TXT2,TXT3,STOP
  1. . S STOP=0
  1. . ; Text to use -- ie: this is the text
  1. . S TXT2=$RE(TEXT) S TXT2=$P(TXT2,"(",2,$L(TXT2)) S TXT2=$RE(TXT2)
  1. . S TXT2=$$TRIM^XLFSTR(TXT2)
  1. . ; get last ( piece -- ie: (body structure)
  1. . S TXT3=$RE(TEXT) S TXT3=$P(TXT3,"(",1) S TXT3=$RE(TXT3) S TXT3=$P(TXT3,")",1)
  1. . S TXT3=$$TRIM^XLFSTR(TXT3)
  1. . Q:TXT3=""
  1. . S X="SCT "_TXT3
  1. . S STOP=1
  1. . ; dont remove non-SCT hierarchy phrases in paranthesis
  1. . I $D(^LAB(64.061,"B",X)) S STOP=0 ;valid SCT Hierachy?
  1. . I $D(^LAB(64.061,"C",$$UP^XLFSTR(X))) S STOP=0
  1. . Q:STOP
  1. . S STR=TXT2
  1. Q STR
  1. ;
  1. ;
  1. LEX6247(R6247,LROUT) ;
  1. ; Gets SCT/LEX info for a File #62.47 entry
  1. ; Inputs
  1. ; R6247: File #62.47 IEN
  1. ; LROUT:<byref><opt>
  1. ; Outputs
  1. ; Returns the #64.061 IEN of the #62.47 entry queried.
  1. ; Also returns aditional info in the LROUT array:
  1. ; LROUT("SCTIEN")
  1. ; LROUT("SCTTOP")
  1. ; LROUT("LEXABRV")
  1. ;
  1. N R64061,SCTIEN,DATA,X
  1. S R6247=+$G(R6247)
  1. K LROUT
  1. S LROUT("SCTIEN")=""
  1. S LROUT("SCTTOP")=""
  1. S LROUT("LEXABRV")=""
  1. I 'R6247 Q 0
  1. S DATA=$G(^LAB(62.47,R6247,0))
  1. S R64061=$P(DATA,U,3) ;fld .03
  1. I 'R64061 Q 0
  1. S DATA=$G(^LAB(64.061,R64061,63))
  1. S SCTIEN=$P(DATA,U,4) ;fld 63.3
  1. S LROUT("SCTIEN")=SCTIEN ;IEN
  1. S DATA=$G(^LAB(64.061,+SCTIEN,0))
  1. S X=$P(DATA,U,1)
  1. S LROUT("SCTTOP")=X
  1. ;S DATA=$G(^LAB(64.061,+SCTIEN,0))
  1. ;S X=$P(DATA,U,1)
  1. ;S LROUT("SCTHIER")=X
  1. S DATA=$G(^LAB(64.061,+SCTIEN,1))
  1. S X=$P(DATA,U,1) ;fld 12
  1. S LROUT("LEXABRV")=X
  1. Q R64061