| 1 | LEXASO ; ISL/KER Look-up Display String (Sources) ; 05/14/2003
|
|---|
| 2 | ;;2.0;LEXICON UTILITY;**25,32**;Sep 23, 1996;Build 1
|
|---|
| 3 | ;
|
|---|
| 4 | ; Entry S X=$$SO^LEXASO(IEN,SAB,ALL,DATE)
|
|---|
| 5 | ;
|
|---|
| 6 | ; IEN is an internal entry number in file 757.01
|
|---|
| 7 | ; representing an expression
|
|---|
| 8 | ;
|
|---|
| 9 | ; SAB is the source abbreviation of the classification
|
|---|
| 10 | ; coding system, i.e., ICD, CPT, DSM, etc.
|
|---|
| 11 | ;
|
|---|
| 12 | ; ALL is a flag
|
|---|
| 13 | ;
|
|---|
| 14 | ; 0 - do not display all codes associated of the
|
|---|
| 15 | ; major concept, display the codes only for the
|
|---|
| 16 | ; expression
|
|---|
| 17 | ;
|
|---|
| 18 | ; 1 - display all codes associated for the major
|
|---|
| 19 | ; concept
|
|---|
| 20 | ;
|
|---|
| 21 | ; DATE is used to screen out inactive codes
|
|---|
| 22 | ;
|
|---|
| 23 | ; LEXCC( Array of classification codes
|
|---|
| 24 | ;
|
|---|
| 25 | ; LEXA Flag - 1 All codes, 0 only the expression codes
|
|---|
| 26 | ; LEXM Flag - M Major Concept
|
|---|
| 27 | ;
|
|---|
| 28 | ; LEXC Counter, # $Piece of string LEXSA (SAB)
|
|---|
| 29 | ;
|
|---|
| 30 | ; LEXMC IEN in file 757 Major Concept
|
|---|
| 31 | ; LEXME IEN in file 757.01 Major Concept Expression
|
|---|
| 32 | ; LEXEX IEN in file 757.01 Expression
|
|---|
| 33 | ; LEXSO IEN in file 757.02 Sources
|
|---|
| 34 | ;
|
|---|
| 35 | ; LEXSA Source Abbreviation i.e., ICD or ICD/CPT
|
|---|
| 36 | ; LEXSC Source Classification Code
|
|---|
| 37 | ; LEXSR Source Abbreviation single only i.e., ICD, CPT
|
|---|
| 38 | ; LEXST String of classification sources and codes
|
|---|
| 39 | ;
|
|---|
| 40 | ; LEXX Return value
|
|---|
| 41 | ;
|
|---|
| 42 | SO(LEXX,LEXSA,LEXA,LEXVDT) ; Return string of source codes for LEXX SAB
|
|---|
| 43 | Q:+($G(LEXX))=0!('$L($G(LEXSA))) ""
|
|---|
| 44 | Q:'$L($G(^LEX(757.01,LEXX,0))) ""
|
|---|
| 45 | ;
|
|---|
| 46 | N LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST
|
|---|
| 47 | ;
|
|---|
| 48 | S LEXEX=+LEXX,LEXX="",LEXA=+($G(LEXA)),LEXMC=0
|
|---|
| 49 | S LEXM=$P($G(^LEX(757.01,LEXEX,1)),"^",2),LEXST=""
|
|---|
| 50 | ; Codes for an expression D EXP
|
|---|
| 51 | I LEXM'=1!(+($G(LEXA))=0) D EXP G EXIT
|
|---|
| 52 | ; Codes for a major concept D MAJ
|
|---|
| 53 | I LEXM=1 S LEXMC=LEXEX D MAJ
|
|---|
| 54 | EXIT ; Clean up and quit
|
|---|
| 55 | Q LEXX
|
|---|
| 56 | EXP ; Source string for an expression
|
|---|
| 57 | I LEXSA'["/" D CODES(LEXEX,LEXSA,$G(LEXVDT)) S LEXX=$$ASSEM Q
|
|---|
| 58 | I LEXSA["/" D S LEXX=$$ASSEM
|
|---|
| 59 | . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
|
|---|
| 60 | . . D CODES(LEXEX,$P(LEXSA,"/",LEXC),$G(LEXVDT))
|
|---|
| 61 | Q
|
|---|
| 62 | MAJ ; Source string for a major concept
|
|---|
| 63 | S LEXMC=$P($G(^LEX(757.01,LEXEX,1)),"^",1),LEXEX=0
|
|---|
| 64 | S LEXEX=0 F S LEXEX=$O(^LEX(757.02,"AMC",LEXMC,LEXEX)) Q:+LEXEX=0 D
|
|---|
| 65 | . N LEXME S LEXME=+($G(^LEX(757.02,LEXEX,0)))
|
|---|
| 66 | . I LEXSA'["/" D CODES(LEXME,LEXSA,$G(LEXVDT)) Q
|
|---|
| 67 | . I LEXSA["/" D Q
|
|---|
| 68 | . . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
|
|---|
| 69 | . . . D CODES(LEXME,$P(LEXSA,"/",LEXC),$G(LEXVDT))
|
|---|
| 70 | S LEXX=$$ASSEM
|
|---|
| 71 | Q
|
|---|
| 72 | CODES(LEXEX,LEXSA,LEXVDT) ; Get Source Codes
|
|---|
| 73 | Q:$L($G(LEXSA))'=3 N LEXSO,LEXSR,LEXST,LEXSTA,LEXCD S LEXST=""
|
|---|
| 74 | S LEXSO=0 F S LEXSO=$O(^LEX(757.02,"B",LEXEX,LEXSO)) Q:+LEXSO=0 D
|
|---|
| 75 | . S LEXCD=$P($G(^LEX(757.02,LEXSO,0)),"^",2) Q:'$L(LEXCD)
|
|---|
| 76 | . S LEXSTA=$$STATCHK^LEXSRC2(LEXCD,$G(LEXVDT)) Q:+LEXSTA'>0
|
|---|
| 77 | . I $E($G(^LEX(757.03,$P($G(^LEX(757.02,LEXSO,0)),"^",3),0)),1,3)=LEXSA D
|
|---|
| 78 | . . S LEXSR=$P($G(^LEX(757.03,$P($G(^LEX(757.02,LEXSO,0)),"^",3),0)),"^",2)
|
|---|
| 79 | . . S LEXCC(LEXSR,(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
|
|---|
| 80 | . . ; Primary Code Saved - p32
|
|---|
| 81 | . . S:$P($G(^LEX(757.02,LEXSO,0)),"^",7)=1 LEXCC(LEXSR,"P",(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
|
|---|
| 82 | Q
|
|---|
| 83 | ASSEM(LEXX) ; Assemble display string (SOURCE CODE/CODE/CODE)
|
|---|
| 84 | Q:'$D(LEXCC) ""
|
|---|
| 85 | Q:$O(LEXCC(""))="" ""
|
|---|
| 86 | N LEXSR,LEXST S LEXSR=""
|
|---|
| 87 | F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
|
|---|
| 88 | . N LEXSC S LEXSC="",LEXST="("_LEXSR_" "
|
|---|
| 89 | . ; Primary Code listed first - p32
|
|---|
| 90 | . I $D(LEXCC(LEXSR,"P")) D
|
|---|
| 91 | . . N LEXSC S LEXSC=$O(LEXCC(LEXSR,"P",""))
|
|---|
| 92 | . . S:$L(LEXSC) LEXST=LEXST_$$TRIM(LEXSC)_"/"
|
|---|
| 93 | . . K LEXCC(LEXSR,"P") K:$L(LEXSC) LEXCC(LEXSR,LEXSC)
|
|---|
| 94 | . S LEXSC="" F S LEXSC=$O(LEXCC(LEXSR,LEXSC)) Q:LEXSC="" D
|
|---|
| 95 | . . S LEXST=LEXST_$$TRIM(LEXSC)_"/"
|
|---|
| 96 | . . K LEXCC(LEXSR,LEXSC)
|
|---|
| 97 | . S LEXCC(LEXSR)=$E(LEXST,1,($L(LEXST)-1))_")"
|
|---|
| 98 | S (LEXST,LEXSR)=""
|
|---|
| 99 | F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
|
|---|
| 100 | . S LEXST=LEXST_" "_LEXCC(LEXSR)
|
|---|
| 101 | F Q:$E(LEXST,1)'=" " S LEXST=$E(LEXST,2,$L(LEXST))
|
|---|
| 102 | S LEXX=LEXST Q LEXX
|
|---|
| 103 | TRIM(LEXX) ; Trim spaces
|
|---|
| 104 | F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
|
|---|
| 105 | F Q:$E(LEXX,$L(LEXX))'=" " S LEXX=$E(LEXX,1,($L(LEXX)-1))
|
|---|
| 106 | Q LEXX
|
|---|
