- LEXU2 ;ISL/KER - Miscellaneous Lexicon Utilities ;12/19/2014
- ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
- ;
- ; Global Variables
- ; ^ICPT( ICR 5408
- ; ^TMP("ICPTD") ICR 1995
- ;
- ; External References
- ; $$CPTD^ICPTCOD ICR 1995
- ; $$CPT^ICPTCOD ICR 1995
- ; $$DT^XLFDT ICR 10103
- ; $$ICDDX^ICDEX ICR 5747
- ; $$ICDD^ICDEX ICR 5747
- ; $$ICDOP^ICDEX ICR 5747
- ; $$MOR^ICDEX ICR 5747
- ; $$TITLE^XLFSTR ICR 10104
- ; CPTD^ICPTCOD ICR 1995
- ; MD^ICDEX ICR 5747
- ; MODA^ICPTMOD ICR 1996
- ;
- CSDATA(CODE,CSYS,CDT,ARY) ; Get Information about a Code
- ;
- ; Input:
- ;
- ; CODE Classification Code (Required)
- ; CSYS Coding System (taken from file 757.03)
- ; Acceptable values include
- ; Pointer to file 757.03
- ; SOURCE ABBREVIATION field .01
- ; Mnemonic (3 character SOURCE ABBREVIATION
- ; from ASAB cross-reference)
- ; CDT Code Set Versioning Date (default = TODAY)
- ; .ARY Output array passed by reference
- ;
- ; Output:
- ;
- ; $$CSDATA 1 if successful (fully or partial)
- ; 0 if unsuccessful
- ;
- ; or
- ;
- ; -1 ^ Error Message
- ;
- ; It is considered partially successful if:
- ;
- ; 1) It is in the Lexicon and not in an SDO file
- ; 2) It is in an SDO file and not in the Lexicon
- ;
- ; ARY()
- ;
- ;
- ; Lexicon Data
- ;
- ; ARY("LEX",1) IEN ^ Preferred Term
- ; ARY("LEX",2) Status ^ Effective Date
- ; ARY("LEX",3) IEN ^ Major Concept Term
- ; ARY("LEX",4) IEN ^ Fully Specified Name
- ; ARY("LEX",5) Hierarchy (if it exists)
- ; ARY("LEX",6,0) Synonyms/Other Forms
- ; ARY("LEX",6,1) Synonym #1
- ; ARY("LEX",6,n) #n
- ; ARY("LEX",7,0) Semantic Map
- ; ARY("LEX",7,1,1) Class ^ Type (internal)
- ; ARY("LEX",7,1,2) Class ^ Type (external)
- ; ARY("LEX",7,1,n) #n
- ; ARY("LEX",7,1,n) #n
- ; ARY("LEX",8) Deactivated Concept Flag
- ;
- ; Coding System Data
- ;
- ; ARY("SYS",1) IEN
- ; ARY("SYS",2) Short Name
- ; ARY("SYS",3) Age High
- ; ARY("SYS",4) Age Low
- ; ARY("SYS",5) Sex
- ; ARY("SYS",6,0) MDC/DRG Pairing
- ; ARY("SYS",6,1,1) MDC
- ; ARY("SYS",6,1,2) DRGs
- ; ARY("SYS",6,n,1) #n
- ; ARY("SYS",6,n,2) #n
- ; ARY("SYS",7) Complication/Comorbidity
- ; ARY("SYS",8) MDC13
- ; ARY("SYS",9) MDC24
- ; ARY("SYS",10) MDC24
- ; ARY("SYS",11) Unacceptable as Principal Dx
- ; ARY("SYS",12) Major O.R. Procedure
- ; ARY("SYS",13) Procedure Category
- ; ARY("SYS",14,0) Description
- ; ARY("SYS",14,1) Text 1
- ; ARY("SYS",14,n) #n
- ;
- ; Each data element will be in the following format:
- ;
- ; ARY(ID,SUB) = DATA
- ; ARY(ID,SUB,"N") = NAME
- ;
- ; Where
- ;
- ; ID Identifier, may be:
- ;
- ; "LEX" for Lexicon data
- ; "SYS" for Coding System data
- ;
- ; SUB Numeric Subscript
- ;
- ; DATA This may be:
- ;
- ; A value if it applies and is found
- ; Null if it applies but not found
- ; N/A if it does not apply
- ;
- ; NAME This is the common name given to the
- ; data element
- ;
- N LEXSO,LEXSRC,LEXSAB,LEXVDT,LEXSCK,LEXSTA,LEXSIEN,LEXEIEN,LEXMIEN,LEXEFF,LEXOK
- S LEXSO=$G(CODE) Q:'$L(LEXSO) "-1^Code missing"
- Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) "-1^Invalid Code"
- S LEXSAB=$G(CSYS)
- S LEXSRC=+($$CSYS^LEXU(LEXSAB)) S:LEXSRC'>0 LEXSRC=$$SYSC^LEXU4(LEXSO)
- Q:+LEXSRC'>0 "-1^Invalid source" S LEXSAB=$P($$CSYS^LEXU(+LEXSRC),"^",2)
- Q:$L(LEXSAB)'=3 "-1^Invalid source"
- Q:+($$CODSAB(LEXSO,LEXSAB))'>0 "-1^Invalid source for code"
- S LEXVDT=$G(CDT) D VDT^LEXU3 D LEX
- I LEXSRC=1!(LEXSRC=30) D ICDDX
- I LEXSRC=2!(LEXSRC=31) D ICDOP
- I LEXSRC=3!(LEXSRC=4) D CPTCPC
- D CS,LX
- Q:$D(ARY("LEX"))!($D(ARY("SYS"))) 1
- Q 0
- LEX ; Lexicon
- Q:'$D(^LEX(757.02,"ACT",(LEXSO_" "))) S LEXSCK=$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT),,LEXSAB)
- S LEXSTA=$P(LEXSCK,"^",1),LEXSIEN=$P(LEXSCK,"^",2),LEXEFF=$P(LEXSCK,"^",3)
- S LEXEIEN=+($G(^LEX(757.02,+LEXSIEN,0))),LEXMIEN=+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",4))
- Q:LEXSIEN<0 S:LEXSTA'>0&(LEXSIEN>0)&(LEXEFF'?7N) ARY("LEX",2)=0
- S:LEXSTA?1N&(LEXSIEN>0)&(LEXEFF?7N) ARY("LEX",2)=LEXSTA_"^"_LEXEFF
- S ARY("LEX",1)=LEXEIEN_"^"_$G(^LEX(757.01,+LEXEIEN,0))
- N LEXFLG,LEXSM,LEXTIEN,LEXMC
- S LEXSM=0 F S LEXSM=$O(^LEX(757.1,"B",LEXMIEN,LEXSM)) Q:+LEXSM'>0 D
- . N LEXN,LEXI,LEXC,LEXCE,LEXT,LEXTE S LEXN=$G(^LEX(757.1,+LEXSM,0))
- . S LEXC=$P(LEXN,"^",2),LEXT=$P(LEXN,"^",3) Q:LEXC'>0 Q:LEXT'>0
- . S LEXCE=$P($G(^LEX(757.11,+LEXC,0)),"^",2) Q:'$L(LEXCE)
- . S LEXTE=$P($G(^LEX(757.12,+LEXT,0)),"^",2) Q:'$L(LEXTE)
- . S LEXI=$O(ARY("LEX",7," "),-1)+1
- . S ARY("LEX",7,LEXI,1)=LEXC_"^"_LEXT
- . S ARY("LEX",7,LEXI,2)=LEXCE_"^"_LEXTE
- S ARY("LEX",7,0)=+($O(ARY("LEX",7," "),-1))
- S LEXTIEN=0,LEXFLG="",LEXMC="" F S LEXTIEN=$O(^LEX(757.01,"AMC",LEXMIEN,LEXTIEN)) Q:+LEXTIEN'>0 D
- . N LEX0,LEX1,LEXT,LEXF
- . S LEX0=$G(^LEX(757.01,LEXTIEN,0)),LEX1=$G(^LEX(757.01,LEXTIEN,1)),LEXT=$P(LEX1,"^",2),LEXF=$P(LEX1,"^",5)
- . S:LEXF>0 LEXFLG=1 I LEXT=8 D
- . . N LEXE,LEXH S LEXE=$G(^LEX(757.01,+LEXTIEN,0)) S ARY("LEX",4)=LEXTIEN_"^"_LEXE
- . . S LEXH=$P($P(LEXE,"(",$L(LEXE,"(")),")") S:$L(LEXH) LEXH=$$TITLE^XLFSTR(LEXH)
- . . S:$L(LEXH) ARY("LEX",5)=LEXH
- . I LEXT=1 S LEXMC=LEXTIEN
- . I LEXT'=1,LEXT'=8,LEXTIEN'=LEXEIEN D
- . . N LEXI S LEXI=$O(ARY("LEX",6," "),-1)+1
- . . S ARY("LEX",6,LEXI)=LEXTIEN_"^"_$G(^LEX(757.01,+LEXTIEN,0)),ARY("LEX",6,0)=LEXI
- S:+LEXMC>0 ARY("LEX",3)=LEXMC_"^"_$G(^LEX(757.01,+LEXMC,0))
- S:+LEXFLG>0 ARY("LEX",8)="Deactivated Concept"
- Q
- ICDDX ; ICD DX CS array
- N LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXOUT,LEXSDO
- S LEXDAT=$$ICDDX^ICDEX(LEXSO,LEXVDT,LEXSRC,"E") Q:+LEXDAT<0 S LEXSDO=+LEXDAT
- S ARY("SYS",1)=LEXSDO,ARY("SYS",2)=$P(LEXDAT,"^",4),ARY("SYS",3)=$P(LEXDAT,"^",16)
- S ARY("SYS",4)=$P(LEXDAT,"^",15),ARY("SYS",5)=$P(LEXDAT,"^",11)
- D MD^ICDEX(80,LEXSDO,LEXVDT,.LEXMD)
- S LEXFY="" F S LEXFY=$O(LEXMD(LEXFY)) Q:'$L(LEXFY) D
- . N LEXNDC S LEXMDC=0 F S LEXMDC=$O(LEXMD(LEXFY,LEXMDC)) Q:+LEXMDC'>0 D
- . . N LEXDRG,LEXLEXI S LEXDRG=$G(LEXMD(LEXFY,LEXMDC)),LEXDRG=$P(LEXDRG,";",1),LEXDRG=$TR(LEXDRG,"^",";")
- . . S LEXI=$O(ARY("SYS",6," "),-1)+1,ARY("SYS",6,LEXI,1)=LEXMDC
- . . S ARY("SYS",6,LEXI,2)=$$TM(LEXDRG,";")
- . . S ARY("SYS",6,0)=LEXI
- S ARY("SYS",7)=$P(LEXDAT,"^",19),ARY("SYS",8)=$P(LEXDAT,"^",7),ARY("SYS",9)=$P(LEXDAT,"^",13)
- S ARY("SYS",10)=$P(LEXDAT,"^",14),ARY("SYS",11)=$P(LEXDAT,"^",5)
- K LEXDD S LEXOUT=$$ICDD^ICDEX(LEXSO,.LEXDD,LEXVDT,LEXSRC) I +LEXOUT>0 D
- . N LEXI,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(LEXDD(LEXI)) Q:+LEXI'>0 D
- . . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(LEXDD(LEXI)),ARY("SYS",14,0)=LEXC
- Q
- ICDOP ; ICD OP CS array
- N LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXMOR,LEXOUT,LEXSDO
- S LEXDAT=$$ICDOP^ICDEX(LEXSO,LEXVDT,LEXSRC,"E") Q:+LEXDAT<0 S LEXSDO=+LEXDAT
- S ARY("SYS",1)=LEXSDO,ARY("SYS",2)=$P(LEXDAT,"^",5),ARY("SYS",5)=$P(LEXDAT,"^",11)
- D MD^ICDEX(80.1,LEXSDO,LEXVDT,.LEXMD)
- S LEXFY="" F S LEXFY=$O(LEXMD(LEXFY)) Q:'$L(LEXFY) D
- . N LEXNDC S LEXMDC=0 F S LEXMDC=$O(LEXMD(LEXFY,LEXMDC)) Q:+LEXMDC'>0 D
- . . N LEXDRG,LEXLEXI S LEXDRG=$G(LEXMD(LEXFY,LEXMDC)),LEXDRG=$P(LEXDRG,";",1),LEXDRG=$TR(LEXDRG,"^",";")
- . . S LEXI=$O(ARY("SYS",6," "),-1)+1,ARY("SYS",6,LEXI,1)=LEXMDC
- . . S ARY("SYS",6,LEXI,2)=$$TM(LEXDRG,";")
- . . S ARY("SYS",6,0)=LEXI
- S ARY("SYS",10)=$P(LEXDAT,"^",4)
- S LEXMOR=$$MOR^ICDEX(LEXSDO)
- S ARY("SYS",12)=LEXMOR
- K LEXDD S LEXOUT=$$ICDD^ICDEX(LEXSO,.LEXDD,LEXVDT,LEXSRC)
- I +LEXOUT>0 D
- . N LEXI,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(LEXDD(LEXI)) Q:+LEXI'>0 D
- . . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(LEXDD(LEXI)),ARY("SYS",14,0)=LEXC
- Q
- CPTCPC ; CPT-4/HCPCS
- N LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXMOR,LEXOUT,LEXSDO
- S LEXDAT=$$CPT^ICPTCOD(LEXSO,LEXVDT) Q:+LEXDAT<0 S LEXSDO=+LEXDAT
- S ARY("SYS",1)=LEXSDO,ARY("SYS",2)=$P(LEXDAT,"^",3)
- S ARY("SYS",13)=$P(LEXDAT,"^",4) K ^TMP("ICPTD",$J)
- S LEXOUT=$$CPTD^ICPTCOD(LEXSO,,,$G(LEXVDT))
- I +LEXOUT>2,'$L($$TM($G(^TMP("ICPTD",$J,(LEXOUT-1))))) D
- . K ^TMP("ICPTD",$J,(LEXOUT-1)),^TMP("ICPTD",$J,LEXOUT)
- I +LEXOUT>0 D
- . N LEXI,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(^TMP("ICPTD",$J,LEXI)) Q:+LEXI'>0 D
- . . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(^TMP("ICPTD",$J,LEXI)),ARY("SYS",14,0)=LEXC
- K ^TMP("ICPTD",$J)
- Q
- CS ; CS Segment if CS is NULL
- N LEXI,LEXC S LEXSRC=+($G(LEXSRC))
- S ARY("SYS",1)=$G(ARY("SYS",1)),ARY("SYS",1,"N")="IEN"
- S ARY("SYS",2)=$G(ARY("SYS",2)),ARY("SYS",2,"N")="Short Name"
- S ARY("SYS",3)=$G(ARY("SYS",3)),ARY("SYS",3,"N")="Age High"
- S ARY("SYS",4)=$G(ARY("SYS",4)),ARY("SYS",4,"N")="Age Low"
- S ARY("SYS",5)=$G(ARY("SYS",5)),ARY("SYS",5,"N")="Sex"
- S (LEXI,LEXC)=0 F S LEXI=$O(ARY("SYS",6,LEXI)) Q:+LEXI'>0 D
- . S LEXC=LEXC+1 S ARY("SYS",6,LEXC,1)=$G(ARY("SYS",6,LEXC,1)),ARY("SYS",6,LEXC,1,"N")="MDC"
- . S ARY("SYS",6,LEXC,2)=$G(ARY("SYS",6,LEXC,2)),ARY("SYS",6,LEXC,2,"N")="DRGs"
- S ARY("SYS",6,0)=LEXC,ARY("SYS",6,0,"N")="MDC/DRG"
- S ARY("SYS",7)=$G(ARY("SYS",7)),ARY("SYS",7,"N")="Complication/Comorbidity"
- S ARY("SYS",8)=$G(ARY("SYS",8)),ARY("SYS",8,"N")="MDC13"
- S ARY("SYS",9)=$G(ARY("SYS",9)),ARY("SYS",9,"N")="MDC24"
- S ARY("SYS",10)=$G(ARY("SYS",10)),ARY("SYS",10,"N")="MDC24"
- S ARY("SYS",11)=$G(ARY("SYS",11)),ARY("SYS",11,"N")="Unacceptable as Principal Dx"
- S ARY("SYS",12)=$G(ARY("SYS",12)),ARY("SYS",12,"N")="Major O.R Procedure"
- S ARY("SYS",13)=$G(ARY("SYS",13)),ARY("SYS",13,"N")="CPT Category"
- S (LEXI,LEXC)=0 F S LEXI=$O(ARY("SYS",14,LEXI)) Q:+LEXI'>0 D
- . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(ARY("SYS",14,LEXC))
- S ARY("SYS",14,0)=LEXC,ARY("SYS",14,0,"N")="Description"
- I LEXSRC=1!(LEXSRC=30) D Q
- . K ARY("SYS",12) S ARY("SYS",12)="N/A" K ARY("SYS",13) S ARY("SYS",13)="N/A"
- I LEXSRC=2!(LEXSRC=31) D Q
- . K ARY("SYS",3) S ARY("SYS",2)="N/A" K ARY("SYS",4) S ARY("SYS",4)="N/A" K ARY("SYS",7) S ARY("SYS",7)="N/A"
- . K ARY("SYS",8) S ARY("SYS",8)="N/A" K ARY("SYS",10) S ARY("SYS",10)="N/A" K ARY("SYS",11) S ARY("SYS",11)="N/A"
- . K ARY("SYS",13) S ARY("SYS",13)="N/A"
- I LEXSRC=3!(LEXSRC=4) D Q
- . K ARY("SYS",3) S ARY("SYS",2)="N/A" K ARY("SYS",4) S ARY("SYS",4)="N/A" K ARY("SYS",5) S ARY("SYS",5)="N/A"
- . K ARY("SYS",6) S ARY("SYS",6)="N/A" K ARY("SYS",7) S ARY("SYS",7)="N/A" K ARY("SYS",8) S ARY("SYS",8)="N/A"
- . K ARY("SYS",9) S ARY("SYS",9)="N/A" K ARY("SYS",10) S ARY("SYS",10)="N/A" K ARY("SYS",11) S ARY("SYS",11)="N/A"
- . K ARY("SYS",12) S ARY("SYS",12)="N/A"
- K ARY("SYS") S ARY("SYS",1)="N/A",ARY("SYS",2)="N/A",ARY("SYS",3)="N/A",ARY("SYS",4)="N/A",ARY("SYS",5)="N/A"
- S ARY("SYS",6)="N/A",ARY("SYS",7)="N/A",ARY("SYS",8)="N/A",ARY("SYS",9)="N/A",ARY("SYS",10)="N/A"
- S ARY("SYS",11)="N/A",ARY("SYS",12)="N/A",ARY("SYS",13)="N/A",ARY("SYS",14)="N/A"
- Q
- LX ; Lexicon Segment
- N LEXC,LEXI S ARY("LEX",1)=$G(ARY("LEX",1)),ARY("LEX",1,"N")="IEN ^ Preferred Term"
- S ARY("LEX",2)=$G(ARY("LEX",2)),ARY("LEX",2,"N")="Status ^ Effective Date"
- S ARY("LEX",3)=$G(ARY("LEX",3)),ARY("LEX",3,"N")="IEN ^ Major Concept Term"
- S ARY("LEX",4)=$G(ARY("LEX",4)),ARY("LEX",4,"N")="IEN ^ Fully Specified Name"
- S ARY("LEX",5)=$G(ARY("LEX",5)),ARY("LEX",5,"N")="Hierarchy (if exists)"
- S ARY("LEX",6,0)=$G(ARY("LEX",6,0)),ARY("LEX",6,0,"N")="Synonyms and Other Forms"
- S (LEXI,LEXC)=0 F S LEXI=$O(ARY("LEX",6,LEXI)) Q:+LEXI'>0 D
- . S LEXC=LEXC+1 S ARY("LEX",6,LEXC)=$G(ARY("LEX",6,LEXC))
- S ARY("LEX",6,0)=LEXC
- S ARY("LEX",7,0)=$G(ARY("LEX",7,0)),ARY("LEX",7,0,"N")="Semantic Map"
- S (LEXI,LEXC)=0 F S LEXI=$O(ARY("LEX",7,LEXI)) Q:+LEXI'>0 D
- . S LEXC=LEXC+1 S ARY("LEX",7,LEXC,1)=$G(ARY("LEX",7,LEXC,1))
- . S ARY("LEX",7,LEXC,1,"N")="Semantic Class ^ Semantic Type (internal)"
- . S ARY("LEX",7,LEXC,2)=$G(ARY("LEX",7,LEXC,2))
- . S ARY("LEX",7,LEXC,2,"N")="Semantic Class ^ Semantic Type (external)"
- S ARY("LEX",7,0)=LEXC
- S ARY("LEX",8)=$G(ARY("LEX",8)),ARY("LEX",8,"N")="Deactivated Concept Flag"
- Q
- ;
- MODS ; CPT Modifiers
- N IEN,STR,MAX,OUT,LEN,CODE,TD S TD=$$DT^XLFDT,MAX=0,OUT=""
- S IEN=0 F S IEN=$O(^ICPT(IEN)) Q:+IEN'>0 D
- . S CODE=$P($G(^ICPT(IEN,0)),"^",1)
- . K ARY D MS(CODE,TD,.ARY)
- Q
- MS(X,CDT,LEXS) ; Modifier Strings
- N LEXDT,LEXSO,LEXCT,LEX,LEXM,LEXMOD K LEXS S LEXSO=$G(X),LEXDT=$G(CDT) S:LEXDT'?7N LEXDT=$$DT^XLFDT D MODA^ICPTMOD(LEXSO,LEXDT,.LEX)
- S LEXMOD="",LEXM="",LEXCT=0 F S LEXM=$O(LEX("A",LEXM)) Q:'$L(LEXM) D
- . Q:$L(LEXM)'=2 S LEXCT=LEXCT+1,LEXMOD=LEXMOD_"^"_LEXM
- . I LEXCT>19 D
- . . N LEXI S LEXI=$O(LEXS(" "),-1)+1
- . . S LEXS(LEXI)=$$TM(LEXMOD,"^") S LEXMOD="",LEXCT=0
- I $L($G(LEXMOD)) D
- . N LEXI S LEXI=$O(LEXS(" "),-1)+1 S LEXS(LEXI)=$$TM(LEXMOD,"^")
- Q
- CODSAB(X,Y) ; Is Code valid for SAB
- N COD,SAB,SRC,OK,SIEN S COD=$G(X),SAB=$$CSYS^LEXU($G(Y)) Q:'$L(COD) 0 Q:+SAB'>0 0
- S SAB=$P(SAB,"^",2) Q:'$L(SAB) 0 Q:'$D(^LEX(757.03,"ASAB",SAB)) 0
- S SRC=$O(^LEX(757.03,"ASAB",SAB,0)) Q:+SRC'>0 0 S OK=0
- S SIEN=0 F S SIEN=$O(^LEX(757.02,"CODE",(COD_" "),SIEN)) Q:+SIEN'>0 D
- . S:$P($G(^LEX(757.02,+SIEN,0)),"^",3)=SRC OK=1
- S X=OK
- Q X
- TM(X,Y) ; Trim Character Y - Default " "
- S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
- F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
- F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXU2 14171 printed Feb 18, 2025@23:35:54 Page 2
- LEXU2 ;ISL/KER - Miscellaneous Lexicon Utilities ;12/19/2014
- +1 ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
- +2 ;
- +3 ; Global Variables
- +4 ; ^ICPT( ICR 5408
- +5 ; ^TMP("ICPTD") ICR 1995
- +6 ;
- +7 ; External References
- +8 ; $$CPTD^ICPTCOD ICR 1995
- +9 ; $$CPT^ICPTCOD ICR 1995
- +10 ; $$DT^XLFDT ICR 10103
- +11 ; $$ICDDX^ICDEX ICR 5747
- +12 ; $$ICDD^ICDEX ICR 5747
- +13 ; $$ICDOP^ICDEX ICR 5747
- +14 ; $$MOR^ICDEX ICR 5747
- +15 ; $$TITLE^XLFSTR ICR 10104
- +16 ; CPTD^ICPTCOD ICR 1995
- +17 ; MD^ICDEX ICR 5747
- +18 ; MODA^ICPTMOD ICR 1996
- +19 ;
- CSDATA(CODE,CSYS,CDT,ARY) ; Get Information about a Code
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; CODE Classification Code (Required)
- +5 ; CSYS Coding System (taken from file 757.03)
- +6 ; Acceptable values include
- +7 ; Pointer to file 757.03
- +8 ; SOURCE ABBREVIATION field .01
- +9 ; Mnemonic (3 character SOURCE ABBREVIATION
- +10 ; from ASAB cross-reference)
- +11 ; CDT Code Set Versioning Date (default = TODAY)
- +12 ; .ARY Output array passed by reference
- +13 ;
- +14 ; Output:
- +15 ;
- +16 ; $$CSDATA 1 if successful (fully or partial)
- +17 ; 0 if unsuccessful
- +18 ;
- +19 ; or
- +20 ;
- +21 ; -1 ^ Error Message
- +22 ;
- +23 ; It is considered partially successful if:
- +24 ;
- +25 ; 1) It is in the Lexicon and not in an SDO file
- +26 ; 2) It is in an SDO file and not in the Lexicon
- +27 ;
- +28 ; ARY()
- +29 ;
- +30 ;
- +31 ; Lexicon Data
- +32 ;
- +33 ; ARY("LEX",1) IEN ^ Preferred Term
- +34 ; ARY("LEX",2) Status ^ Effective Date
- +35 ; ARY("LEX",3) IEN ^ Major Concept Term
- +36 ; ARY("LEX",4) IEN ^ Fully Specified Name
- +37 ; ARY("LEX",5) Hierarchy (if it exists)
- +38 ; ARY("LEX",6,0) Synonyms/Other Forms
- +39 ; ARY("LEX",6,1) Synonym #1
- +40 ; ARY("LEX",6,n) #n
- +41 ; ARY("LEX",7,0) Semantic Map
- +42 ; ARY("LEX",7,1,1) Class ^ Type (internal)
- +43 ; ARY("LEX",7,1,2) Class ^ Type (external)
- +44 ; ARY("LEX",7,1,n) #n
- +45 ; ARY("LEX",7,1,n) #n
- +46 ; ARY("LEX",8) Deactivated Concept Flag
- +47 ;
- +48 ; Coding System Data
- +49 ;
- +50 ; ARY("SYS",1) IEN
- +51 ; ARY("SYS",2) Short Name
- +52 ; ARY("SYS",3) Age High
- +53 ; ARY("SYS",4) Age Low
- +54 ; ARY("SYS",5) Sex
- +55 ; ARY("SYS",6,0) MDC/DRG Pairing
- +56 ; ARY("SYS",6,1,1) MDC
- +57 ; ARY("SYS",6,1,2) DRGs
- +58 ; ARY("SYS",6,n,1) #n
- +59 ; ARY("SYS",6,n,2) #n
- +60 ; ARY("SYS",7) Complication/Comorbidity
- +61 ; ARY("SYS",8) MDC13
- +62 ; ARY("SYS",9) MDC24
- +63 ; ARY("SYS",10) MDC24
- +64 ; ARY("SYS",11) Unacceptable as Principal Dx
- +65 ; ARY("SYS",12) Major O.R. Procedure
- +66 ; ARY("SYS",13) Procedure Category
- +67 ; ARY("SYS",14,0) Description
- +68 ; ARY("SYS",14,1) Text 1
- +69 ; ARY("SYS",14,n) #n
- +70 ;
- +71 ; Each data element will be in the following format:
- +72 ;
- +73 ; ARY(ID,SUB) = DATA
- +74 ; ARY(ID,SUB,"N") = NAME
- +75 ;
- +76 ; Where
- +77 ;
- +78 ; ID Identifier, may be:
- +79 ;
- +80 ; "LEX" for Lexicon data
- +81 ; "SYS" for Coding System data
- +82 ;
- +83 ; SUB Numeric Subscript
- +84 ;
- +85 ; DATA This may be:
- +86 ;
- +87 ; A value if it applies and is found
- +88 ; Null if it applies but not found
- +89 ; N/A if it does not apply
- +90 ;
- +91 ; NAME This is the common name given to the
- +92 ; data element
- +93 ;
- +94 NEW LEXSO,LEXSRC,LEXSAB,LEXVDT,LEXSCK,LEXSTA,LEXSIEN,LEXEIEN,LEXMIEN,LEXEFF,LEXOK
- +95 SET LEXSO=$GET(CODE)
- if '$LENGTH(LEXSO)
- QUIT "-1^Code missing"
- +96 if '$DATA(^LEX(757.02,"CODE",(LEXSO_" ")))
- QUIT "-1^Invalid Code"
- +97 SET LEXSAB=$GET(CSYS)
- +98 SET LEXSRC=+($$CSYS^LEXU(LEXSAB))
- if LEXSRC'>0
- SET LEXSRC=$$SYSC^LEXU4(LEXSO)
- +99 if +LEXSRC'>0
- QUIT "-1^Invalid source"
- SET LEXSAB=$PIECE($$CSYS^LEXU(+LEXSRC),"^",2)
- +100 if $LENGTH(LEXSAB)'=3
- QUIT "-1^Invalid source"
- +101 if +($$CODSAB(LEXSO,LEXSAB))'>0
- QUIT "-1^Invalid source for code"
- +102 SET LEXVDT=$GET(CDT)
- DO VDT^LEXU3
- DO LEX
- +103 IF LEXSRC=1!(LEXSRC=30)
- DO ICDDX
- +104 IF LEXSRC=2!(LEXSRC=31)
- DO ICDOP
- +105 IF LEXSRC=3!(LEXSRC=4)
- DO CPTCPC
- +106 DO CS
- DO LX
- +107 if $DATA(ARY("LEX"))!($DATA(ARY("SYS")))
- QUIT 1
- +108 QUIT 0
- LEX ; Lexicon
- +1 if '$DATA(^LEX(757.02,"ACT",(LEXSO_" ")))
- QUIT
- SET LEXSCK=$$STATCHK^LEXSRC2(LEXSO,$GET(LEXVDT),,LEXSAB)
- +2 SET LEXSTA=$PIECE(LEXSCK,"^",1)
- SET LEXSIEN=$PIECE(LEXSCK,"^",2)
- SET LEXEFF=$PIECE(LEXSCK,"^",3)
- +3 SET LEXEIEN=+($GET(^LEX(757.02,+LEXSIEN,0)))
- SET LEXMIEN=+($PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",4))
- +4 if LEXSIEN<0
- QUIT
- if LEXSTA'>0&(LEXSIEN>0)&(LEXEFF'?7N)
- SET ARY("LEX",2)=0
- +5 if LEXSTA?1N&(LEXSIEN>0)&(LEXEFF?7N)
- SET ARY("LEX",2)=LEXSTA_"^"_LEXEFF
- +6 SET ARY("LEX",1)=LEXEIEN_"^"_$GET(^LEX(757.01,+LEXEIEN,0))
- +7 NEW LEXFLG,LEXSM,LEXTIEN,LEXMC
- +8 SET LEXSM=0
- FOR
- SET LEXSM=$ORDER(^LEX(757.1,"B",LEXMIEN,LEXSM))
- if +LEXSM'>0
- QUIT
- Begin DoDot:1
- +9 NEW LEXN,LEXI,LEXC,LEXCE,LEXT,LEXTE
- SET LEXN=$GET(^LEX(757.1,+LEXSM,0))
- +10 SET LEXC=$PIECE(LEXN,"^",2)
- SET LEXT=$PIECE(LEXN,"^",3)
- if LEXC'>0
- QUIT
- if LEXT'>0
- QUIT
- +11 SET LEXCE=$PIECE($GET(^LEX(757.11,+LEXC,0)),"^",2)
- if '$LENGTH(LEXCE)
- QUIT
- +12 SET LEXTE=$PIECE($GET(^LEX(757.12,+LEXT,0)),"^",2)
- if '$LENGTH(LEXTE)
- QUIT
- +13 SET LEXI=$ORDER(ARY("LEX",7," "),-1)+1
- +14 SET ARY("LEX",7,LEXI,1)=LEXC_"^"_LEXT
- +15 SET ARY("LEX",7,LEXI,2)=LEXCE_"^"_LEXTE
- End DoDot:1
- +16 SET ARY("LEX",7,0)=+($ORDER(ARY("LEX",7," "),-1))
- +17 SET LEXTIEN=0
- SET LEXFLG=""
- SET LEXMC=""
- FOR
- SET LEXTIEN=$ORDER(^LEX(757.01,"AMC",LEXMIEN,LEXTIEN))
- if +LEXTIEN'>0
- QUIT
- Begin DoDot:1
- +18 NEW LEX0,LEX1,LEXT,LEXF
- +19 SET LEX0=$GET(^LEX(757.01,LEXTIEN,0))
- SET LEX1=$GET(^LEX(757.01,LEXTIEN,1))
- SET LEXT=$PIECE(LEX1,"^",2)
- SET LEXF=$PIECE(LEX1,"^",5)
- +20 if LEXF>0
- SET LEXFLG=1
- IF LEXT=8
- Begin DoDot:2
- +21 NEW LEXE,LEXH
- SET LEXE=$GET(^LEX(757.01,+LEXTIEN,0))
- SET ARY("LEX",4)=LEXTIEN_"^"_LEXE
- +22 SET LEXH=$PIECE($PIECE(LEXE,"(",$LENGTH(LEXE,"(")),")")
- if $LENGTH(LEXH)
- SET LEXH=$$TITLE^XLFSTR(LEXH)
- +23 if $LENGTH(LEXH)
- SET ARY("LEX",5)=LEXH
- End DoDot:2
- +24 IF LEXT=1
- SET LEXMC=LEXTIEN
- +25 IF LEXT'=1
- IF LEXT'=8
- IF LEXTIEN'=LEXEIEN
- Begin DoDot:2
- +26 NEW LEXI
- SET LEXI=$ORDER(ARY("LEX",6," "),-1)+1
- +27 SET ARY("LEX",6,LEXI)=LEXTIEN_"^"_$GET(^LEX(757.01,+LEXTIEN,0))
- SET ARY("LEX",6,0)=LEXI
- End DoDot:2
- End DoDot:1
- +28 if +LEXMC>0
- SET ARY("LEX",3)=LEXMC_"^"_$GET(^LEX(757.01,+LEXMC,0))
- +29 if +LEXFLG>0
- SET ARY("LEX",8)="Deactivated Concept"
- +30 QUIT
- ICDDX ; ICD DX CS array
- +1 NEW LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXOUT,LEXSDO
- +2 SET LEXDAT=$$ICDDX^ICDEX(LEXSO,LEXVDT,LEXSRC,"E")
- if +LEXDAT<0
- QUIT
- SET LEXSDO=+LEXDAT
- +3 SET ARY("SYS",1)=LEXSDO
- SET ARY("SYS",2)=$PIECE(LEXDAT,"^",4)
- SET ARY("SYS",3)=$PIECE(LEXDAT,"^",16)
- +4 SET ARY("SYS",4)=$PIECE(LEXDAT,"^",15)
- SET ARY("SYS",5)=$PIECE(LEXDAT,"^",11)
- +5 DO MD^ICDEX(80,LEXSDO,LEXVDT,.LEXMD)
- +6 SET LEXFY=""
- FOR
- SET LEXFY=$ORDER(LEXMD(LEXFY))
- if '$LENGTH(LEXFY)
- QUIT
- Begin DoDot:1
- +7 NEW LEXNDC
- SET LEXMDC=0
- FOR
- SET LEXMDC=$ORDER(LEXMD(LEXFY,LEXMDC))
- if +LEXMDC'>0
- QUIT
- Begin DoDot:2
- +8 NEW LEXDRG,LEXLEXI
- SET LEXDRG=$GET(LEXMD(LEXFY,LEXMDC))
- SET LEXDRG=$PIECE(LEXDRG,";",1)
- SET LEXDRG=$TRANSLATE(LEXDRG,"^",";")
- +9 SET LEXI=$ORDER(ARY("SYS",6," "),-1)+1
- SET ARY("SYS",6,LEXI,1)=LEXMDC
- +10 SET ARY("SYS",6,LEXI,2)=$$TM(LEXDRG,";")
- +11 SET ARY("SYS",6,0)=LEXI
- End DoDot:2
- End DoDot:1
- +12 SET ARY("SYS",7)=$PIECE(LEXDAT,"^",19)
- SET ARY("SYS",8)=$PIECE(LEXDAT,"^",7)
- SET ARY("SYS",9)=$PIECE(LEXDAT,"^",13)
- +13 SET ARY("SYS",10)=$PIECE(LEXDAT,"^",14)
- SET ARY("SYS",11)=$PIECE(LEXDAT,"^",5)
- +14 KILL LEXDD
- SET LEXOUT=$$ICDD^ICDEX(LEXSO,.LEXDD,LEXVDT,LEXSRC)
- IF +LEXOUT>0
- Begin DoDot:1
- +15 NEW LEXI,LEXC
- SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(LEXDD(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +16 SET LEXC=LEXC+1
- SET ARY("SYS",14,LEXC)=$GET(LEXDD(LEXI))
- SET ARY("SYS",14,0)=LEXC
- End DoDot:2
- End DoDot:1
- +17 QUIT
- ICDOP ; ICD OP CS array
- +1 NEW LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXMOR,LEXOUT,LEXSDO
- +2 SET LEXDAT=$$ICDOP^ICDEX(LEXSO,LEXVDT,LEXSRC,"E")
- if +LEXDAT<0
- QUIT
- SET LEXSDO=+LEXDAT
- +3 SET ARY("SYS",1)=LEXSDO
- SET ARY("SYS",2)=$PIECE(LEXDAT,"^",5)
- SET ARY("SYS",5)=$PIECE(LEXDAT,"^",11)
- +4 DO MD^ICDEX(80.1,LEXSDO,LEXVDT,.LEXMD)
- +5 SET LEXFY=""
- FOR
- SET LEXFY=$ORDER(LEXMD(LEXFY))
- if '$LENGTH(LEXFY)
- QUIT
- Begin DoDot:1
- +6 NEW LEXNDC
- SET LEXMDC=0
- FOR
- SET LEXMDC=$ORDER(LEXMD(LEXFY,LEXMDC))
- if +LEXMDC'>0
- QUIT
- Begin DoDot:2
- +7 NEW LEXDRG,LEXLEXI
- SET LEXDRG=$GET(LEXMD(LEXFY,LEXMDC))
- SET LEXDRG=$PIECE(LEXDRG,";",1)
- SET LEXDRG=$TRANSLATE(LEXDRG,"^",";")
- +8 SET LEXI=$ORDER(ARY("SYS",6," "),-1)+1
- SET ARY("SYS",6,LEXI,1)=LEXMDC
- +9 SET ARY("SYS",6,LEXI,2)=$$TM(LEXDRG,";")
- +10 SET ARY("SYS",6,0)=LEXI
- End DoDot:2
- End DoDot:1
- +11 SET ARY("SYS",10)=$PIECE(LEXDAT,"^",4)
- +12 SET LEXMOR=$$MOR^ICDEX(LEXSDO)
- +13 SET ARY("SYS",12)=LEXMOR
- +14 KILL LEXDD
- SET LEXOUT=$$ICDD^ICDEX(LEXSO,.LEXDD,LEXVDT,LEXSRC)
- +15 IF +LEXOUT>0
- Begin DoDot:1
- +16 NEW LEXI,LEXC
- SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(LEXDD(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +17 SET LEXC=LEXC+1
- SET ARY("SYS",14,LEXC)=$GET(LEXDD(LEXI))
- SET ARY("SYS",14,0)=LEXC
- End DoDot:2
- End DoDot:1
- +18 QUIT
- CPTCPC ; CPT-4/HCPCS
- +1 NEW LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXMOR,LEXOUT,LEXSDO
- +2 SET LEXDAT=$$CPT^ICPTCOD(LEXSO,LEXVDT)
- if +LEXDAT<0
- QUIT
- SET LEXSDO=+LEXDAT
- +3 SET ARY("SYS",1)=LEXSDO
- SET ARY("SYS",2)=$PIECE(LEXDAT,"^",3)
- +4 SET ARY("SYS",13)=$PIECE(LEXDAT,"^",4)
- KILL ^TMP("ICPTD",$JOB)
- +5 SET LEXOUT=$$CPTD^ICPTCOD(LEXSO,,,$GET(LEXVDT))
- +6 IF +LEXOUT>2
- IF '$LENGTH($$TM($GET(^TMP("ICPTD",$JOB,(LEXOUT-1)))))
- Begin DoDot:1
- +7 KILL ^TMP("ICPTD",$JOB,(LEXOUT-1)),^TMP("ICPTD",$JOB,LEXOUT)
- End DoDot:1
- +8 IF +LEXOUT>0
- Begin DoDot:1
- +9 NEW LEXI,LEXC
- SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(^TMP("ICPTD",$JOB,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +10 SET LEXC=LEXC+1
- SET ARY("SYS",14,LEXC)=$GET(^TMP("ICPTD",$JOB,LEXI))
- SET ARY("SYS",14,0)=LEXC
- End DoDot:2
- End DoDot:1
- +11 KILL ^TMP("ICPTD",$JOB)
- +12 QUIT
- CS ; CS Segment if CS is NULL
- +1 NEW LEXI,LEXC
- SET LEXSRC=+($GET(LEXSRC))
- +2 SET ARY("SYS",1)=$GET(ARY("SYS",1))
- SET ARY("SYS",1,"N")="IEN"
- +3 SET ARY("SYS",2)=$GET(ARY("SYS",2))
- SET ARY("SYS",2,"N")="Short Name"
- +4 SET ARY("SYS",3)=$GET(ARY("SYS",3))
- SET ARY("SYS",3,"N")="Age High"
- +5 SET ARY("SYS",4)=$GET(ARY("SYS",4))
- SET ARY("SYS",4,"N")="Age Low"
- +6 SET ARY("SYS",5)=$GET(ARY("SYS",5))
- SET ARY("SYS",5,"N")="Sex"
- +7 SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(ARY("SYS",6,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +8 SET LEXC=LEXC+1
- SET ARY("SYS",6,LEXC,1)=$GET(ARY("SYS",6,LEXC,1))
- SET ARY("SYS",6,LEXC,1,"N")="MDC"
- +9 SET ARY("SYS",6,LEXC,2)=$GET(ARY("SYS",6,LEXC,2))
- SET ARY("SYS",6,LEXC,2,"N")="DRGs"
- End DoDot:1
- +10 SET ARY("SYS",6,0)=LEXC
- SET ARY("SYS",6,0,"N")="MDC/DRG"
- +11 SET ARY("SYS",7)=$GET(ARY("SYS",7))
- SET ARY("SYS",7,"N")="Complication/Comorbidity"
- +12 SET ARY("SYS",8)=$GET(ARY("SYS",8))
- SET ARY("SYS",8,"N")="MDC13"
- +13 SET ARY("SYS",9)=$GET(ARY("SYS",9))
- SET ARY("SYS",9,"N")="MDC24"
- +14 SET ARY("SYS",10)=$GET(ARY("SYS",10))
- SET ARY("SYS",10,"N")="MDC24"
- +15 SET ARY("SYS",11)=$GET(ARY("SYS",11))
- SET ARY("SYS",11,"N")="Unacceptable as Principal Dx"
- +16 SET ARY("SYS",12)=$GET(ARY("SYS",12))
- SET ARY("SYS",12,"N")="Major O.R Procedure"
- +17 SET ARY("SYS",13)=$GET(ARY("SYS",13))
- SET ARY("SYS",13,"N")="CPT Category"
- +18 SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(ARY("SYS",14,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +19 SET LEXC=LEXC+1
- SET ARY("SYS",14,LEXC)=$GET(ARY("SYS",14,LEXC))
- End DoDot:1
- +20 SET ARY("SYS",14,0)=LEXC
- SET ARY("SYS",14,0,"N")="Description"
- +21 IF LEXSRC=1!(LEXSRC=30)
- Begin DoDot:1
- +22 KILL ARY("SYS",12)
- SET ARY("SYS",12)="N/A"
- KILL ARY("SYS",13)
- SET ARY("SYS",13)="N/A"
- End DoDot:1
- QUIT
- +23 IF LEXSRC=2!(LEXSRC=31)
- Begin DoDot:1
- +24 KILL ARY("SYS",3)
- SET ARY("SYS",2)="N/A"
- KILL ARY("SYS",4)
- SET ARY("SYS",4)="N/A"
- KILL ARY("SYS",7)
- SET ARY("SYS",7)="N/A"
- +25 KILL ARY("SYS",8)
- SET ARY("SYS",8)="N/A"
- KILL ARY("SYS",10)
- SET ARY("SYS",10)="N/A"
- KILL ARY("SYS",11)
- SET ARY("SYS",11)="N/A"
- +26 KILL ARY("SYS",13)
- SET ARY("SYS",13)="N/A"
- End DoDot:1
- QUIT
- +27 IF LEXSRC=3!(LEXSRC=4)
- Begin DoDot:1
- +28 KILL ARY("SYS",3)
- SET ARY("SYS",2)="N/A"
- KILL ARY("SYS",4)
- SET ARY("SYS",4)="N/A"
- KILL ARY("SYS",5)
- SET ARY("SYS",5)="N/A"
- +29 KILL ARY("SYS",6)
- SET ARY("SYS",6)="N/A"
- KILL ARY("SYS",7)
- SET ARY("SYS",7)="N/A"
- KILL ARY("SYS",8)
- SET ARY("SYS",8)="N/A"
- +30 KILL ARY("SYS",9)
- SET ARY("SYS",9)="N/A"
- KILL ARY("SYS",10)
- SET ARY("SYS",10)="N/A"
- KILL ARY("SYS",11)
- SET ARY("SYS",11)="N/A"
- +31 KILL ARY("SYS",12)
- SET ARY("SYS",12)="N/A"
- End DoDot:1
- QUIT
- +32 KILL ARY("SYS")
- SET ARY("SYS",1)="N/A"
- SET ARY("SYS",2)="N/A"
- SET ARY("SYS",3)="N/A"
- SET ARY("SYS",4)="N/A"
- SET ARY("SYS",5)="N/A"
- +33 SET ARY("SYS",6)="N/A"
- SET ARY("SYS",7)="N/A"
- SET ARY("SYS",8)="N/A"
- SET ARY("SYS",9)="N/A"
- SET ARY("SYS",10)="N/A"
- +34 SET ARY("SYS",11)="N/A"
- SET ARY("SYS",12)="N/A"
- SET ARY("SYS",13)="N/A"
- SET ARY("SYS",14)="N/A"
- +35 QUIT
- LX ; Lexicon Segment
- +1 NEW LEXC,LEXI
- SET ARY("LEX",1)=$GET(ARY("LEX",1))
- SET ARY("LEX",1,"N")="IEN ^ Preferred Term"
- +2 SET ARY("LEX",2)=$GET(ARY("LEX",2))
- SET ARY("LEX",2,"N")="Status ^ Effective Date"
- +3 SET ARY("LEX",3)=$GET(ARY("LEX",3))
- SET ARY("LEX",3,"N")="IEN ^ Major Concept Term"
- +4 SET ARY("LEX",4)=$GET(ARY("LEX",4))
- SET ARY("LEX",4,"N")="IEN ^ Fully Specified Name"
- +5 SET ARY("LEX",5)=$GET(ARY("LEX",5))
- SET ARY("LEX",5,"N")="Hierarchy (if exists)"
- +6 SET ARY("LEX",6,0)=$GET(ARY("LEX",6,0))
- SET ARY("LEX",6,0,"N")="Synonyms and Other Forms"
- +7 SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(ARY("LEX",6,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +8 SET LEXC=LEXC+1
- SET ARY("LEX",6,LEXC)=$GET(ARY("LEX",6,LEXC))
- End DoDot:1
- +9 SET ARY("LEX",6,0)=LEXC
- +10 SET ARY("LEX",7,0)=$GET(ARY("LEX",7,0))
- SET ARY("LEX",7,0,"N")="Semantic Map"
- +11 SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(ARY("LEX",7,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +12 SET LEXC=LEXC+1
- SET ARY("LEX",7,LEXC,1)=$GET(ARY("LEX",7,LEXC,1))
- +13 SET ARY("LEX",7,LEXC,1,"N")="Semantic Class ^ Semantic Type (internal)"
- +14 SET ARY("LEX",7,LEXC,2)=$GET(ARY("LEX",7,LEXC,2))
- +15 SET ARY("LEX",7,LEXC,2,"N")="Semantic Class ^ Semantic Type (external)"
- End DoDot:1
- +16 SET ARY("LEX",7,0)=LEXC
- +17 SET ARY("LEX",8)=$GET(ARY("LEX",8))
- SET ARY("LEX",8,"N")="Deactivated Concept Flag"
- +18 QUIT
- +19 ;
- MODS ; CPT Modifiers
- +1 NEW IEN,STR,MAX,OUT,LEN,CODE,TD
- SET TD=$$DT^XLFDT
- SET MAX=0
- SET OUT=""
- +2 SET IEN=0
- FOR
- SET IEN=$ORDER(^ICPT(IEN))
- if +IEN'>0
- QUIT
- Begin DoDot:1
- +3 SET CODE=$PIECE($GET(^ICPT(IEN,0)),"^",1)
- +4 KILL ARY
- DO MS(CODE,TD,.ARY)
- End DoDot:1
- +5 QUIT
- MS(X,CDT,LEXS) ; Modifier Strings
- +1 NEW LEXDT,LEXSO,LEXCT,LEX,LEXM,LEXMOD
- KILL LEXS
- SET LEXSO=$GET(X)
- SET LEXDT=$GET(CDT)
- if LEXDT'?7N
- SET LEXDT=$$DT^XLFDT
- DO MODA^ICPTMOD(LEXSO,LEXDT,.LEX)
- +2 SET LEXMOD=""
- SET LEXM=""
- SET LEXCT=0
- FOR
- SET LEXM=$ORDER(LEX("A",LEXM))
- if '$LENGTH(LEXM)
- QUIT
- Begin DoDot:1
- +3 if $LENGTH(LEXM)'=2
- QUIT
- SET LEXCT=LEXCT+1
- SET LEXMOD=LEXMOD_"^"_LEXM
- +4 IF LEXCT>19
- Begin DoDot:2
- +5 NEW LEXI
- SET LEXI=$ORDER(LEXS(" "),-1)+1
- +6 SET LEXS(LEXI)=$$TM(LEXMOD,"^")
- SET LEXMOD=""
- SET LEXCT=0
- End DoDot:2
- End DoDot:1
- +7 IF $LENGTH($GET(LEXMOD))
- Begin DoDot:1
- +8 NEW LEXI
- SET LEXI=$ORDER(LEXS(" "),-1)+1
- SET LEXS(LEXI)=$$TM(LEXMOD,"^")
- End DoDot:1
- +9 QUIT
- CODSAB(X,Y) ; Is Code valid for SAB
- +1 NEW COD,SAB,SRC,OK,SIEN
- SET COD=$GET(X)
- SET SAB=$$CSYS^LEXU($GET(Y))
- if '$LENGTH(COD)
- QUIT 0
- if +SAB'>0
- QUIT 0
- +2 SET SAB=$PIECE(SAB,"^",2)
- if '$LENGTH(SAB)
- QUIT 0
- if '$DATA(^LEX(757.03,"ASAB",SAB))
- QUIT 0
- +3 SET SRC=$ORDER(^LEX(757.03,"ASAB",SAB,0))
- if +SRC'>0
- QUIT 0
- SET OK=0
- +4 SET SIEN=0
- FOR
- SET SIEN=$ORDER(^LEX(757.02,"CODE",(COD_" "),SIEN))
- if +SIEN'>0
- QUIT
- Begin DoDot:1
- +5 if $PIECE($GET(^LEX(757.02,+SIEN,0)),"^",3)=SRC
- SET OK=1
- End DoDot:1
- +6 SET X=OK
- +7 QUIT X
- TM(X,Y) ; Trim Character Y - Default " "
- +1 SET X=$GET(X)
- if X=""
- QUIT X
- SET Y=$GET(Y)
- if '$LENGTH(Y)
- SET Y=" "
- +2 FOR
- if $EXTRACT(X,1)'=Y
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +3 FOR
- if $EXTRACT(X,$LENGTH(X))'=Y
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +4 QUIT X