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 Sep 23, 2025@19:45:43 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
