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

LEXASO.m

Go to the documentation of this file. 
  1. LEXASO ;ISL/KER - Look-up Display String (Sources) ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**25,32,73,80**;Sep 23, 1996;Build 10
  1.  ;
  1.  ; Entry S X=$$SO^LEXASO(IEN,SAB,ALL,DATE)
  1.  ;
  1.  ;       IEN is an internal entry number in file 757.01
  1.  ;           representing an expression
  1.  ;
  1.  ;       SAB is the source abbreviation of the classification
  1.  ;           coding system, i.e., ICD, CPT, DSM, etc.
  1.  ;
  1.  ;       ALL is a flag 
  1.  ;
  1.  ;           0 - do not display all codes associated of the
  1.  ;               major concept, display the codes only for the
  1.  ;               expression
  1.  ;
  1.  ;           1 - display all codes associated for the major 
  1.  ;               concept
  1.  ;
  1.  ;       DATE is used to screen out inactive codes
  1.  ;
  1.  ; LEXCC(   Array of classification codes
  1.  ;
  1.  ; LEXA     Flag - 1 All codes, 0 only the expression codes
  1.  ; LEXM     Flag - M Major Concept
  1.  ;
  1.  ; LEXC     Counter, # $Piece of string LEXSA (SAB)
  1.  ;
  1.  ; LEXMC    IEN in file 757      Major Concept
  1.  ; LEXME    IEN in file 757.01   Major Concept Expression
  1.  ; LEXEX    IEN in file 757.01   Expression
  1.  ; LEXSO    IEN in file 757.02   Sources
  1.  ;
  1.  ; LEXSA    Source Abbreviation i.e., ICD or ICD/CPT
  1.  ; LEXSC    Source Classification Code
  1.  ; LEXSR    Source Abbreviation single only i.e., ICD, CPT
  1.  ; LEXST    String of classification sources and codes
  1.  ;
  1.  ; LEXX     Return value
  1.  ;
  1. SO(LEXX,LEXSA,LEXA,LEXVDT) ; Return string of source codes for LEXX SAB
  1.  Q:+($G(LEXX))=0!('$L($G(LEXSA))) ""  Q:'$L($G(^LEX(757.01,LEXX,0))) ""
  1.  N LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST D VDT^LEXU
  1.  S LEXEX=+LEXX,LEXX="",LEXA=+($G(LEXA)),LEXMC=0
  1.  S LEXM=$P($G(^LEX(757.01,LEXEX,1)),"^",2),LEXST=""
  1.  ; Codes for an expression     D EXP
  1.  I LEXM'=1!(+($G(LEXA))=0) D EXP G EXIT
  1.  ; Codes for a major concept   D MAJ
  1.  I LEXM=1 S LEXMC=LEXEX D MAJ
  1. EXIT ; Clean up and quit
  1.  Q LEXX
  1. EXP ; Source string for an expression
  1.  I LEXSA'["/" D CODES(LEXEX,LEXSA,$G(LEXVDT)) S LEXX=$$ASSEM Q
  1.  I LEXSA["/" D  S LEXX=$$ASSEM
  1.  . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
  1.  . . D CODES(LEXEX,$P(LEXSA,"/",LEXC),$G(LEXVDT))
  1.  Q
  1. MAJ ; Source string for a major concept
  1.  S LEXMC=$P($G(^LEX(757.01,LEXEX,1)),"^",1),LEXEX=0
  1.  S LEXEX=0 F  S LEXEX=$O(^LEX(757.02,"AMC",LEXMC,LEXEX)) Q:+LEXEX=0  D
  1.  . N LEXME S LEXME=+($G(^LEX(757.02,LEXEX,0)))
  1.  . I LEXSA'["/" D CODES(LEXME,LEXSA,$G(LEXVDT)) Q
  1.  . I LEXSA["/" D  Q
  1.  . . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
  1.  . . . D CODES(LEXME,$P(LEXSA,"/",LEXC),$G(LEXVDT))
  1.  S LEXX=$$ASSEM
  1.  Q
  1. CODES(LEXEX,LEXSA,LEXVDT) ; Get Source Codes
  1.  Q:$L($G(LEXSA))'=3  N LEXCD,LEXCN,LEXCS,LEXHE,LEXHI,LEXHN,LEXHS,LEXSAI,LEXSO,LEXSR,LEXST,LEXSTA
  1.  S LEXST="",LEXSAI=+($O(^LEX(757.03,"ASAB",LEXSA,0))) Q:+LEXSAI'>0  S LEXSO=0 F  S LEXSO=$O(^LEX(757.02,"B",LEXEX,LEXSO)) Q:+LEXSO=0  D
  1.  . S LEXCN=$G(^LEX(757.02,LEXSO,0)),LEXCD=$P(LEXCN,"^",2) Q:'$L(LEXCD)  S LEXCS=$P(LEXCN,"^",3) Q:+LEXCS'=+LEXSAI
  1.  . S LEXHE=$S(+LEXVDT>0:(LEXVDT_".99999"),1:" "),LEXHE=$O(^LEX(757.02,+LEXSO,4,"B",LEXHE),-1) Q:+LEXHE'>0
  1.  . S LEXHI=$O(^LEX(757.02,+LEXSO,4,"B",+LEXHE," "),-1)
  1.  . S LEXHN=$G(^LEX(757.02,+LEXSO,4,+LEXHI,0)),LEXHS=$P(LEXHN,"^",2) Q:+($G(LEXHS))'>0
  1.  . S LEXSR=$P($G(^LEX(757.03,$P($G(^LEX(757.02,LEXSO,0)),"^",3),0)),"^",2)
  1.  . S LEXCC(LEXSR,(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
  1.  . ; Primary Code Saved - p32
  1.  . S:$P($G(^LEX(757.02,LEXSO,0)),"^",7)=1 LEXCC(LEXSR,"P",(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
  1.  Q
  1. ASSEM(LEXX) ; Assemble display string  (SOURCE CODE/CODE/CODE)
  1.  Q:'$D(LEXCC) ""  Q:$O(LEXCC(""))="" ""  N LEXSR,LEXST S LEXSR=""
  1.  D SHELLY F  S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR=""  D
  1.  . N LEXSC S LEXSC="",LEXST="("_LEXSR_" "
  1.  . ; Primary Code listed first - p32
  1.  . I $D(LEXCC(LEXSR,"P")) D
  1.  . . N LEXSC S LEXSC=$O(LEXCC(LEXSR,"P",""))
  1.  . . S:$L(LEXSC) LEXST=LEXST_$$TRIM(LEXSC)_"/"
  1.  . . K LEXCC(LEXSR,"P") K:$L(LEXSC) LEXCC(LEXSR,LEXSC)
  1.  . S LEXSC="" F  S LEXSC=$O(LEXCC(LEXSR,LEXSC)) Q:LEXSC=""  D
  1.  . . S LEXST=LEXST_$$TRIM(LEXSC)_"/"
  1.  . . K LEXCC(LEXSR,LEXSC)
  1.  . S LEXCC(LEXSR)=$E(LEXST,1,($L(LEXST)-1))_")"
  1.  S (LEXST,LEXSR)=""
  1.  F  S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR=""  D
  1.  . S LEXST=LEXST_" "_LEXCC(LEXSR)
  1.  F  Q:$E(LEXST,1)'=" "  S LEXST=$E(LEXST,2,$L(LEXST))
  1.  S LEXX=LEXST Q LEXX
  1. SHELLY ; Suppress other (non-primary) codes
  1.  N LEXSY,LEXCD S LEXSY="" F  S LEXSY=$O(LEXCC(LEXSY)) Q:'$L(LEXSY)  D
  1.  . N LEXPF S LEXPF=$O(LEXCC(LEXSY,"P","")) Q:'$L(LEXPF)
  1.  . S LEXCD="" F  S LEXCD=$O(LEXCC(LEXSY,LEXCD)) Q:'$L(LEXCD)  D
  1.  . . Q:LEXCD="P"  K:LEXCD'=LEXPF LEXCC(LEXSY,LEXCD)
  1.  Q
  1. TRIM(LEXX) ; Trim spaces
  1.  F  Q:$E(LEXX,1)'=" "  S LEXX=$E(LEXX,2,$L(LEXX))
  1.  F  Q:$E(LEXX,$L(LEXX))'=" "  S LEXX=$E(LEXX,1,($L(LEXX)-1))
  1.  Q LEXX