LEXASO ;ISL/KER - Look-up Display String (Sources) ;04/21/2014
;;2.0;LEXICON UTILITY;**25,32,73,80**;Sep 23, 1996;Build 10
;
; Entry S X=$$SO^LEXASO(IEN,SAB,ALL,DATE)
;
; IEN is an internal entry number in file 757.01
; representing an expression
;
; SAB is the source abbreviation of the classification
; coding system, i.e., ICD, CPT, DSM, etc.
;
; ALL is a flag
;
; 0 - do not display all codes associated of the
; major concept, display the codes only for the
; expression
;
; 1 - display all codes associated for the major
; concept
;
; DATE is used to screen out inactive codes
;
; LEXCC( Array of classification codes
;
; LEXA Flag - 1 All codes, 0 only the expression codes
; LEXM Flag - M Major Concept
;
; LEXC Counter, # $Piece of string LEXSA (SAB)
;
; LEXMC IEN in file 757 Major Concept
; LEXME IEN in file 757.01 Major Concept Expression
; LEXEX IEN in file 757.01 Expression
; LEXSO IEN in file 757.02 Sources
;
; LEXSA Source Abbreviation i.e., ICD or ICD/CPT
; LEXSC Source Classification Code
; LEXSR Source Abbreviation single only i.e., ICD, CPT
; LEXST String of classification sources and codes
;
; LEXX Return value
;
SO(LEXX,LEXSA,LEXA,LEXVDT) ; Return string of source codes for LEXX SAB
Q:+($G(LEXX))=0!('$L($G(LEXSA))) "" Q:'$L($G(^LEX(757.01,LEXX,0))) ""
N LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST D VDT^LEXU
S LEXEX=+LEXX,LEXX="",LEXA=+($G(LEXA)),LEXMC=0
S LEXM=$P($G(^LEX(757.01,LEXEX,1)),"^",2),LEXST=""
; Codes for an expression D EXP
I LEXM'=1!(+($G(LEXA))=0) D EXP G EXIT
; Codes for a major concept D MAJ
I LEXM=1 S LEXMC=LEXEX D MAJ
EXIT ; Clean up and quit
Q LEXX
EXP ; Source string for an expression
I LEXSA'["/" D CODES(LEXEX,LEXSA,$G(LEXVDT)) S LEXX=$$ASSEM Q
I LEXSA["/" D S LEXX=$$ASSEM
. N LEXC F LEXC=1:1:$L(LEXSA,"/") D
. . D CODES(LEXEX,$P(LEXSA,"/",LEXC),$G(LEXVDT))
Q
MAJ ; Source string for a major concept
S LEXMC=$P($G(^LEX(757.01,LEXEX,1)),"^",1),LEXEX=0
S LEXEX=0 F S LEXEX=$O(^LEX(757.02,"AMC",LEXMC,LEXEX)) Q:+LEXEX=0 D
. N LEXME S LEXME=+($G(^LEX(757.02,LEXEX,0)))
. I LEXSA'["/" D CODES(LEXME,LEXSA,$G(LEXVDT)) Q
. I LEXSA["/" D Q
. . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
. . . D CODES(LEXME,$P(LEXSA,"/",LEXC),$G(LEXVDT))
S LEXX=$$ASSEM
Q
CODES(LEXEX,LEXSA,LEXVDT) ; Get Source Codes
Q:$L($G(LEXSA))'=3 N LEXCD,LEXCN,LEXCS,LEXHE,LEXHI,LEXHN,LEXHS,LEXSAI,LEXSO,LEXSR,LEXST,LEXSTA
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
. S LEXCN=$G(^LEX(757.02,LEXSO,0)),LEXCD=$P(LEXCN,"^",2) Q:'$L(LEXCD) S LEXCS=$P(LEXCN,"^",3) Q:+LEXCS'=+LEXSAI
. S LEXHE=$S(+LEXVDT>0:(LEXVDT_".99999"),1:" "),LEXHE=$O(^LEX(757.02,+LEXSO,4,"B",LEXHE),-1) Q:+LEXHE'>0
. S LEXHI=$O(^LEX(757.02,+LEXSO,4,"B",+LEXHE," "),-1)
. S LEXHN=$G(^LEX(757.02,+LEXSO,4,+LEXHI,0)),LEXHS=$P(LEXHN,"^",2) Q:+($G(LEXHS))'>0
. S LEXSR=$P($G(^LEX(757.03,$P($G(^LEX(757.02,LEXSO,0)),"^",3),0)),"^",2)
. S LEXCC(LEXSR,(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
. ; Primary Code Saved - p32
. S:$P($G(^LEX(757.02,LEXSO,0)),"^",7)=1 LEXCC(LEXSR,"P",(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
Q
ASSEM(LEXX) ; Assemble display string (SOURCE CODE/CODE/CODE)
Q:'$D(LEXCC) "" Q:$O(LEXCC(""))="" "" N LEXSR,LEXST S LEXSR=""
D SHELLY F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
. N LEXSC S LEXSC="",LEXST="("_LEXSR_" "
. ; Primary Code listed first - p32
. I $D(LEXCC(LEXSR,"P")) D
. . N LEXSC S LEXSC=$O(LEXCC(LEXSR,"P",""))
. . S:$L(LEXSC) LEXST=LEXST_$$TRIM(LEXSC)_"/"
. . K LEXCC(LEXSR,"P") K:$L(LEXSC) LEXCC(LEXSR,LEXSC)
. S LEXSC="" F S LEXSC=$O(LEXCC(LEXSR,LEXSC)) Q:LEXSC="" D
. . S LEXST=LEXST_$$TRIM(LEXSC)_"/"
. . K LEXCC(LEXSR,LEXSC)
. S LEXCC(LEXSR)=$E(LEXST,1,($L(LEXST)-1))_")"
S (LEXST,LEXSR)=""
F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
. S LEXST=LEXST_" "_LEXCC(LEXSR)
F Q:$E(LEXST,1)'=" " S LEXST=$E(LEXST,2,$L(LEXST))
S LEXX=LEXST Q LEXX
SHELLY ; Suppress other (non-primary) codes
N LEXSY,LEXCD S LEXSY="" F S LEXSY=$O(LEXCC(LEXSY)) Q:'$L(LEXSY) D
. N LEXPF S LEXPF=$O(LEXCC(LEXSY,"P","")) Q:'$L(LEXPF)
. S LEXCD="" F S LEXCD=$O(LEXCC(LEXSY,LEXCD)) Q:'$L(LEXCD) D
. . Q:LEXCD="P" K:LEXCD'=LEXPF LEXCC(LEXSY,LEXCD)
Q
TRIM(LEXX) ; Trim spaces
F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
F Q:$E(LEXX,$L(LEXX))'=" " S LEXX=$E(LEXX,1,($L(LEXX)-1))
Q LEXX
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
+2 ;
+3 ; Entry S X=$$SO^LEXASO(IEN,SAB,ALL,DATE)
+4 ;
+5 ; IEN is an internal entry number in file 757.01
+6 ; representing an expression
+7 ;
+8 ; SAB is the source abbreviation of the classification
+9 ; coding system, i.e., ICD, CPT, DSM, etc.
+10 ;
+11 ; ALL is a flag
+12 ;
+13 ; 0 - do not display all codes associated of the
+14 ; major concept, display the codes only for the
+15 ; expression
+16 ;
+17 ; 1 - display all codes associated for the major
+18 ; concept
+19 ;
+20 ; DATE is used to screen out inactive codes
+21 ;
+22 ; LEXCC( Array of classification codes
+23 ;
+24 ; LEXA Flag - 1 All codes, 0 only the expression codes
+25 ; LEXM Flag - M Major Concept
+26 ;
+27 ; LEXC Counter, # $Piece of string LEXSA (SAB)
+28 ;
+29 ; LEXMC IEN in file 757 Major Concept
+30 ; LEXME IEN in file 757.01 Major Concept Expression
+31 ; LEXEX IEN in file 757.01 Expression
+32 ; LEXSO IEN in file 757.02 Sources
+33 ;
+34 ; LEXSA Source Abbreviation i.e., ICD or ICD/CPT
+35 ; LEXSC Source Classification Code
+36 ; LEXSR Source Abbreviation single only i.e., ICD, CPT
+37 ; LEXST String of classification sources and codes
+38 ;
+39 ; LEXX Return value
+40 ;
SO(LEXX,LEXSA,LEXA,LEXVDT) ; Return string of source codes for LEXX SAB
+1 IF +($GET(LEXX))=0!('$LENGTH($GET(LEXSA)))
QUIT ""
IF '$LENGTH($GET(^LEX(757.01,LEXX,0)))
QUIT ""
+2 NEW LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST
DO VDT^LEXU
+3 SET LEXEX=+LEXX
SET LEXX=""
SET LEXA=+($GET(LEXA))
SET LEXMC=0
+4 SET LEXM=$PIECE($GET(^LEX(757.01,LEXEX,1)),"^",2)
SET LEXST=""
+5 ; Codes for an expression D EXP
+6 IF LEXM'=1!(+($GET(LEXA))=0)
DO EXP
GOTO EXIT
+7 ; Codes for a major concept D MAJ
+8 IF LEXM=1
SET LEXMC=LEXEX
DO MAJ
EXIT ; Clean up and quit
+1 QUIT LEXX
EXP ; Source string for an expression
+1 IF LEXSA'["/"
DO CODES(LEXEX,LEXSA,$GET(LEXVDT))
SET LEXX=$$ASSEM
QUIT
+2 IF LEXSA["/"
Begin DoDot:1
+3 NEW LEXC
FOR LEXC=1:1:$LENGTH(LEXSA,"/")
Begin DoDot:2
+4 DO CODES(LEXEX,$PIECE(LEXSA,"/",LEXC),$GET(LEXVDT))
End DoDot:2
End DoDot:1
SET LEXX=$$ASSEM
+5 QUIT
MAJ ; Source string for a major concept
+1 SET LEXMC=$PIECE($GET(^LEX(757.01,LEXEX,1)),"^",1)
SET LEXEX=0
+2 SET LEXEX=0
FOR
SET LEXEX=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXEX))
IF +LEXEX=0
QUIT
Begin DoDot:1
+3 NEW LEXME
SET LEXME=+($GET(^LEX(757.02,LEXEX,0)))
+4 IF LEXSA'["/"
DO CODES(LEXME,LEXSA,$GET(LEXVDT))
QUIT
+5 IF LEXSA["/"
Begin DoDot:2
+6 NEW LEXC
FOR LEXC=1:1:$LENGTH(LEXSA,"/")
Begin DoDot:3
+7 DO CODES(LEXME,$PIECE(LEXSA,"/",LEXC),$GET(LEXVDT))
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+8 SET LEXX=$$ASSEM
+9 QUIT
CODES(LEXEX,LEXSA,LEXVDT) ; Get Source Codes
+1 IF $LENGTH($GET(LEXSA))'=3
QUIT
NEW LEXCD,LEXCN,LEXCS,LEXHE,LEXHI,LEXHN,LEXHS,LEXSAI,LEXSO,LEXSR,LEXST,LEXSTA
+2 SET LEXST=""
SET LEXSAI=+($ORDER(^LEX(757.03,"ASAB",LEXSA,0)))
IF +LEXSAI'>0
QUIT
SET LEXSO=0
FOR
SET LEXSO=$ORDER(^LEX(757.02,"B",LEXEX,LEXSO))
IF +LEXSO=0
QUIT
Begin DoDot:1
+3 SET LEXCN=$GET(^LEX(757.02,LEXSO,0))
SET LEXCD=$PIECE(LEXCN,"^",2)
IF '$LENGTH(LEXCD)
QUIT
SET LEXCS=$PIECE(LEXCN,"^",3)
IF +LEXCS'=+LEXSAI
QUIT
+4 SET LEXHE=$SELECT(+LEXVDT>0:(LEXVDT_".99999"),1:" ")
SET LEXHE=$ORDER(^LEX(757.02,+LEXSO,4,"B",LEXHE),-1)
IF +LEXHE'>0
QUIT
+5 SET LEXHI=$ORDER(^LEX(757.02,+LEXSO,4,"B",+LEXHE," "),-1)
+6 SET LEXHN=$GET(^LEX(757.02,+LEXSO,4,+LEXHI,0))
SET LEXHS=$PIECE(LEXHN,"^",2)
IF +($GET(LEXHS))'>0
QUIT
+7 SET LEXSR=$PIECE($GET(^LEX(757.03,$PIECE($GET(^LEX(757.02,LEXSO,0)),"^",3),0)),"^",2)
+8 SET LEXCC(LEXSR,(($PIECE($GET(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
+9 ; Primary Code Saved - p32
+10 IF $PIECE($GET(^LEX(757.02,LEXSO,0)),"^",7)=1
SET LEXCC(LEXSR,"P",(($PIECE($GET(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
End DoDot:1
+11 QUIT
ASSEM(LEXX) ; Assemble display string (SOURCE CODE/CODE/CODE)
+1 IF '$DATA(LEXCC)
QUIT ""
IF $ORDER(LEXCC(""))=""
QUIT ""
NEW LEXSR,LEXST
SET LEXSR=""
+2 DO SHELLY
FOR
SET LEXSR=$ORDER(LEXCC(LEXSR))
IF LEXSR=""
QUIT
Begin DoDot:1
+3 NEW LEXSC
SET LEXSC=""
SET LEXST="("_LEXSR_" "
+4 ; Primary Code listed first - p32
+5 IF $DATA(LEXCC(LEXSR,"P"))
Begin DoDot:2
+6 NEW LEXSC
SET LEXSC=$ORDER(LEXCC(LEXSR,"P",""))
+7 IF $LENGTH(LEXSC)
SET LEXST=LEXST_$$TRIM(LEXSC)_"/"
+8 KILL LEXCC(LEXSR,"P")
IF $LENGTH(LEXSC)
KILL LEXCC(LEXSR,LEXSC)
End DoDot:2
+9 SET LEXSC=""
FOR
SET LEXSC=$ORDER(LEXCC(LEXSR,LEXSC))
IF LEXSC=""
QUIT
Begin DoDot:2
+10 SET LEXST=LEXST_$$TRIM(LEXSC)_"/"
+11 KILL LEXCC(LEXSR,LEXSC)
End DoDot:2
+12 SET LEXCC(LEXSR)=$EXTRACT(LEXST,1,($LENGTH(LEXST)-1))_")"
End DoDot:1
+13 SET (LEXST,LEXSR)=""
+14 FOR
SET LEXSR=$ORDER(LEXCC(LEXSR))
IF LEXSR=""
QUIT
Begin DoDot:1
+15 SET LEXST=LEXST_" "_LEXCC(LEXSR)
End DoDot:1
+16 FOR
IF $EXTRACT(LEXST,1)'=" "
QUIT
SET LEXST=$EXTRACT(LEXST,2,$LENGTH(LEXST))
+17 SET LEXX=LEXST
QUIT LEXX
SHELLY ; Suppress other (non-primary) codes
+1 NEW LEXSY,LEXCD
SET LEXSY=""
FOR
SET LEXSY=$ORDER(LEXCC(LEXSY))
IF '$LENGTH(LEXSY)
QUIT
Begin DoDot:1
+2 NEW LEXPF
SET LEXPF=$ORDER(LEXCC(LEXSY,"P",""))
IF '$LENGTH(LEXPF)
QUIT
+3 SET LEXCD=""
FOR
SET LEXCD=$ORDER(LEXCC(LEXSY,LEXCD))
IF '$LENGTH(LEXCD)
QUIT
Begin DoDot:2
+4 IF LEXCD="P"
QUIT
IF LEXCD'=LEXPF
KILL LEXCC(LEXSY,LEXCD)
End DoDot:2
End DoDot:1
+5 QUIT
TRIM(LEXX) ; Trim spaces
+1 FOR
IF $EXTRACT(LEXX,1)'=" "
QUIT
SET LEXX=$EXTRACT(LEXX,2,$LENGTH(LEXX))
+2 FOR
IF $EXTRACT(LEXX,$LENGTH(LEXX))'=" "
QUIT
SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))
+3 QUIT LEXX
