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

LEXU2.m

Go to the documentation of this file.
  1. LEXU2 ;ISL/KER - Miscellaneous Lexicon Utilities ;12/19/2014
  1. ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
  1. ;
  1. ; Global Variables
  1. ; ^ICPT( ICR 5408
  1. ; ^TMP("ICPTD") ICR 1995
  1. ;
  1. ; External References
  1. ; $$CPTD^ICPTCOD ICR 1995
  1. ; $$CPT^ICPTCOD ICR 1995
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$ICDDX^ICDEX ICR 5747
  1. ; $$ICDD^ICDEX ICR 5747
  1. ; $$ICDOP^ICDEX ICR 5747
  1. ; $$MOR^ICDEX ICR 5747
  1. ; $$TITLE^XLFSTR ICR 10104
  1. ; CPTD^ICPTCOD ICR 1995
  1. ; MD^ICDEX ICR 5747
  1. ; MODA^ICPTMOD ICR 1996
  1. ;
  1. CSDATA(CODE,CSYS,CDT,ARY) ; Get Information about a Code
  1. ;
  1. ; Input:
  1. ;
  1. ; CODE Classification Code (Required)
  1. ; CSYS Coding System (taken from file 757.03)
  1. ; Acceptable values include
  1. ; Pointer to file 757.03
  1. ; SOURCE ABBREVIATION field .01
  1. ; Mnemonic (3 character SOURCE ABBREVIATION
  1. ; from ASAB cross-reference)
  1. ; CDT Code Set Versioning Date (default = TODAY)
  1. ; .ARY Output array passed by reference
  1. ;
  1. ; Output:
  1. ;
  1. ; $$CSDATA 1 if successful (fully or partial)
  1. ; 0 if unsuccessful
  1. ;
  1. ; or
  1. ;
  1. ; -1 ^ Error Message
  1. ;
  1. ; It is considered partially successful if:
  1. ;
  1. ; 1) It is in the Lexicon and not in an SDO file
  1. ; 2) It is in an SDO file and not in the Lexicon
  1. ;
  1. ; ARY()
  1. ;
  1. ;
  1. ; Lexicon Data
  1. ;
  1. ; ARY("LEX",1) IEN ^ Preferred Term
  1. ; ARY("LEX",2) Status ^ Effective Date
  1. ; ARY("LEX",3) IEN ^ Major Concept Term
  1. ; ARY("LEX",4) IEN ^ Fully Specified Name
  1. ; ARY("LEX",5) Hierarchy (if it exists)
  1. ; ARY("LEX",6,0) Synonyms/Other Forms
  1. ; ARY("LEX",6,1) Synonym #1
  1. ; ARY("LEX",6,n) #n
  1. ; ARY("LEX",7,0) Semantic Map
  1. ; ARY("LEX",7,1,1) Class ^ Type (internal)
  1. ; ARY("LEX",7,1,2) Class ^ Type (external)
  1. ; ARY("LEX",7,1,n) #n
  1. ; ARY("LEX",7,1,n) #n
  1. ; ARY("LEX",8) Deactivated Concept Flag
  1. ;
  1. ; Coding System Data
  1. ;
  1. ; ARY("SYS",1) IEN
  1. ; ARY("SYS",2) Short Name
  1. ; ARY("SYS",3) Age High
  1. ; ARY("SYS",4) Age Low
  1. ; ARY("SYS",5) Sex
  1. ; ARY("SYS",6,0) MDC/DRG Pairing
  1. ; ARY("SYS",6,1,1) MDC
  1. ; ARY("SYS",6,1,2) DRGs
  1. ; ARY("SYS",6,n,1) #n
  1. ; ARY("SYS",6,n,2) #n
  1. ; ARY("SYS",7) Complication/Comorbidity
  1. ; ARY("SYS",8) MDC13
  1. ; ARY("SYS",9) MDC24
  1. ; ARY("SYS",10) MDC24
  1. ; ARY("SYS",11) Unacceptable as Principal Dx
  1. ; ARY("SYS",12) Major O.R. Procedure
  1. ; ARY("SYS",13) Procedure Category
  1. ; ARY("SYS",14,0) Description
  1. ; ARY("SYS",14,1) Text 1
  1. ; ARY("SYS",14,n) #n
  1. ;
  1. ; Each data element will be in the following format:
  1. ;
  1. ; ARY(ID,SUB) = DATA
  1. ; ARY(ID,SUB,"N") = NAME
  1. ;
  1. ; Where
  1. ;
  1. ; ID Identifier, may be:
  1. ;
  1. ; "LEX" for Lexicon data
  1. ; "SYS" for Coding System data
  1. ;
  1. ; SUB Numeric Subscript
  1. ;
  1. ; DATA This may be:
  1. ;
  1. ; A value if it applies and is found
  1. ; Null if it applies but not found
  1. ; N/A if it does not apply
  1. ;
  1. ; NAME This is the common name given to the
  1. ; data element
  1. ;
  1. N LEXSO,LEXSRC,LEXSAB,LEXVDT,LEXSCK,LEXSTA,LEXSIEN,LEXEIEN,LEXMIEN,LEXEFF,LEXOK
  1. S LEXSO=$G(CODE) Q:'$L(LEXSO) "-1^Code missing"
  1. Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) "-1^Invalid Code"
  1. S LEXSAB=$G(CSYS)
  1. S LEXSRC=+($$CSYS^LEXU(LEXSAB)) S:LEXSRC'>0 LEXSRC=$$SYSC^LEXU4(LEXSO)
  1. Q:+LEXSRC'>0 "-1^Invalid source" S LEXSAB=$P($$CSYS^LEXU(+LEXSRC),"^",2)
  1. Q:$L(LEXSAB)'=3 "-1^Invalid source"
  1. Q:+($$CODSAB(LEXSO,LEXSAB))'>0 "-1^Invalid source for code"
  1. S LEXVDT=$G(CDT) D VDT^LEXU3 D LEX
  1. I LEXSRC=1!(LEXSRC=30) D ICDDX
  1. I LEXSRC=2!(LEXSRC=31) D ICDOP
  1. I LEXSRC=3!(LEXSRC=4) D CPTCPC
  1. D CS,LX
  1. Q:$D(ARY("LEX"))!($D(ARY("SYS"))) 1
  1. Q 0
  1. LEX ; Lexicon
  1. Q:'$D(^LEX(757.02,"ACT",(LEXSO_" "))) S LEXSCK=$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT),,LEXSAB)
  1. S LEXSTA=$P(LEXSCK,"^",1),LEXSIEN=$P(LEXSCK,"^",2),LEXEFF=$P(LEXSCK,"^",3)
  1. S LEXEIEN=+($G(^LEX(757.02,+LEXSIEN,0))),LEXMIEN=+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",4))
  1. Q:LEXSIEN<0 S:LEXSTA'>0&(LEXSIEN>0)&(LEXEFF'?7N) ARY("LEX",2)=0
  1. S:LEXSTA?1N&(LEXSIEN>0)&(LEXEFF?7N) ARY("LEX",2)=LEXSTA_"^"_LEXEFF
  1. S ARY("LEX",1)=LEXEIEN_"^"_$G(^LEX(757.01,+LEXEIEN,0))
  1. N LEXFLG,LEXSM,LEXTIEN,LEXMC
  1. S LEXSM=0 F S LEXSM=$O(^LEX(757.1,"B",LEXMIEN,LEXSM)) Q:+LEXSM'>0 D
  1. . N LEXN,LEXI,LEXC,LEXCE,LEXT,LEXTE S LEXN=$G(^LEX(757.1,+LEXSM,0))
  1. . S LEXC=$P(LEXN,"^",2),LEXT=$P(LEXN,"^",3) Q:LEXC'>0 Q:LEXT'>0
  1. . S LEXCE=$P($G(^LEX(757.11,+LEXC,0)),"^",2) Q:'$L(LEXCE)
  1. . S LEXTE=$P($G(^LEX(757.12,+LEXT,0)),"^",2) Q:'$L(LEXTE)
  1. . S LEXI=$O(ARY("LEX",7," "),-1)+1
  1. . S ARY("LEX",7,LEXI,1)=LEXC_"^"_LEXT
  1. . S ARY("LEX",7,LEXI,2)=LEXCE_"^"_LEXTE
  1. S ARY("LEX",7,0)=+($O(ARY("LEX",7," "),-1))
  1. S LEXTIEN=0,LEXFLG="",LEXMC="" F S LEXTIEN=$O(^LEX(757.01,"AMC",LEXMIEN,LEXTIEN)) Q:+LEXTIEN'>0 D
  1. . N LEX0,LEX1,LEXT,LEXF
  1. . S LEX0=$G(^LEX(757.01,LEXTIEN,0)),LEX1=$G(^LEX(757.01,LEXTIEN,1)),LEXT=$P(LEX1,"^",2),LEXF=$P(LEX1,"^",5)
  1. . S:LEXF>0 LEXFLG=1 I LEXT=8 D
  1. . . N LEXE,LEXH S LEXE=$G(^LEX(757.01,+LEXTIEN,0)) S ARY("LEX",4)=LEXTIEN_"^"_LEXE
  1. . . S LEXH=$P($P(LEXE,"(",$L(LEXE,"(")),")") S:$L(LEXH) LEXH=$$TITLE^XLFSTR(LEXH)
  1. . . S:$L(LEXH) ARY("LEX",5)=LEXH
  1. . I LEXT=1 S LEXMC=LEXTIEN
  1. . I LEXT'=1,LEXT'=8,LEXTIEN'=LEXEIEN D
  1. . . N LEXI S LEXI=$O(ARY("LEX",6," "),-1)+1
  1. . . S ARY("LEX",6,LEXI)=LEXTIEN_"^"_$G(^LEX(757.01,+LEXTIEN,0)),ARY("LEX",6,0)=LEXI
  1. S:+LEXMC>0 ARY("LEX",3)=LEXMC_"^"_$G(^LEX(757.01,+LEXMC,0))
  1. S:+LEXFLG>0 ARY("LEX",8)="Deactivated Concept"
  1. Q
  1. ICDDX ; ICD DX CS array
  1. N LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXOUT,LEXSDO
  1. S LEXDAT=$$ICDDX^ICDEX(LEXSO,LEXVDT,LEXSRC,"E") Q:+LEXDAT<0 S LEXSDO=+LEXDAT
  1. S ARY("SYS",1)=LEXSDO,ARY("SYS",2)=$P(LEXDAT,"^",4),ARY("SYS",3)=$P(LEXDAT,"^",16)
  1. S ARY("SYS",4)=$P(LEXDAT,"^",15),ARY("SYS",5)=$P(LEXDAT,"^",11)
  1. D MD^ICDEX(80,LEXSDO,LEXVDT,.LEXMD)
  1. S LEXFY="" F S LEXFY=$O(LEXMD(LEXFY)) Q:'$L(LEXFY) D
  1. . N LEXNDC S LEXMDC=0 F S LEXMDC=$O(LEXMD(LEXFY,LEXMDC)) Q:+LEXMDC'>0 D
  1. . . N LEXDRG,LEXLEXI S LEXDRG=$G(LEXMD(LEXFY,LEXMDC)),LEXDRG=$P(LEXDRG,";",1),LEXDRG=$TR(LEXDRG,"^",";")
  1. . . S LEXI=$O(ARY("SYS",6," "),-1)+1,ARY("SYS",6,LEXI,1)=LEXMDC
  1. . . S ARY("SYS",6,LEXI,2)=$$TM(LEXDRG,";")
  1. . . S ARY("SYS",6,0)=LEXI
  1. S ARY("SYS",7)=$P(LEXDAT,"^",19),ARY("SYS",8)=$P(LEXDAT,"^",7),ARY("SYS",9)=$P(LEXDAT,"^",13)
  1. S ARY("SYS",10)=$P(LEXDAT,"^",14),ARY("SYS",11)=$P(LEXDAT,"^",5)
  1. K LEXDD S LEXOUT=$$ICDD^ICDEX(LEXSO,.LEXDD,LEXVDT,LEXSRC) I +LEXOUT>0 D
  1. . N LEXI,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(LEXDD(LEXI)) Q:+LEXI'>0 D
  1. . . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(LEXDD(LEXI)),ARY("SYS",14,0)=LEXC
  1. Q
  1. ICDOP ; ICD OP CS array
  1. N LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXMOR,LEXOUT,LEXSDO
  1. S LEXDAT=$$ICDOP^ICDEX(LEXSO,LEXVDT,LEXSRC,"E") Q:+LEXDAT<0 S LEXSDO=+LEXDAT
  1. S ARY("SYS",1)=LEXSDO,ARY("SYS",2)=$P(LEXDAT,"^",5),ARY("SYS",5)=$P(LEXDAT,"^",11)
  1. D MD^ICDEX(80.1,LEXSDO,LEXVDT,.LEXMD)
  1. S LEXFY="" F S LEXFY=$O(LEXMD(LEXFY)) Q:'$L(LEXFY) D
  1. . N LEXNDC S LEXMDC=0 F S LEXMDC=$O(LEXMD(LEXFY,LEXMDC)) Q:+LEXMDC'>0 D
  1. . . N LEXDRG,LEXLEXI S LEXDRG=$G(LEXMD(LEXFY,LEXMDC)),LEXDRG=$P(LEXDRG,";",1),LEXDRG=$TR(LEXDRG,"^",";")
  1. . . S LEXI=$O(ARY("SYS",6," "),-1)+1,ARY("SYS",6,LEXI,1)=LEXMDC
  1. . . S ARY("SYS",6,LEXI,2)=$$TM(LEXDRG,";")
  1. . . S ARY("SYS",6,0)=LEXI
  1. S ARY("SYS",10)=$P(LEXDAT,"^",4)
  1. S LEXMOR=$$MOR^ICDEX(LEXSDO)
  1. S ARY("SYS",12)=LEXMOR
  1. K LEXDD S LEXOUT=$$ICDD^ICDEX(LEXSO,.LEXDD,LEXVDT,LEXSRC)
  1. I +LEXOUT>0 D
  1. . N LEXI,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(LEXDD(LEXI)) Q:+LEXI'>0 D
  1. . . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(LEXDD(LEXI)),ARY("SYS",14,0)=LEXC
  1. Q
  1. CPTCPC ; CPT-4/HCPCS
  1. N LEXC,LEXDAT,LEXDD,LEXDRG,LEXFY,LEXI,LEXLEXI,LEXMD,LEXMDC,LEXMOR,LEXOUT,LEXSDO
  1. S LEXDAT=$$CPT^ICPTCOD(LEXSO,LEXVDT) Q:+LEXDAT<0 S LEXSDO=+LEXDAT
  1. S ARY("SYS",1)=LEXSDO,ARY("SYS",2)=$P(LEXDAT,"^",3)
  1. S ARY("SYS",13)=$P(LEXDAT,"^",4) K ^TMP("ICPTD",$J)
  1. S LEXOUT=$$CPTD^ICPTCOD(LEXSO,,,$G(LEXVDT))
  1. I +LEXOUT>2,'$L($$TM($G(^TMP("ICPTD",$J,(LEXOUT-1))))) D
  1. . K ^TMP("ICPTD",$J,(LEXOUT-1)),^TMP("ICPTD",$J,LEXOUT)
  1. I +LEXOUT>0 D
  1. . N LEXI,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(^TMP("ICPTD",$J,LEXI)) Q:+LEXI'>0 D
  1. . . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(^TMP("ICPTD",$J,LEXI)),ARY("SYS",14,0)=LEXC
  1. K ^TMP("ICPTD",$J)
  1. Q
  1. CS ; CS Segment if CS is NULL
  1. N LEXI,LEXC S LEXSRC=+($G(LEXSRC))
  1. S ARY("SYS",1)=$G(ARY("SYS",1)),ARY("SYS",1,"N")="IEN"
  1. S ARY("SYS",2)=$G(ARY("SYS",2)),ARY("SYS",2,"N")="Short Name"
  1. S ARY("SYS",3)=$G(ARY("SYS",3)),ARY("SYS",3,"N")="Age High"
  1. S ARY("SYS",4)=$G(ARY("SYS",4)),ARY("SYS",4,"N")="Age Low"
  1. S ARY("SYS",5)=$G(ARY("SYS",5)),ARY("SYS",5,"N")="Sex"
  1. S (LEXI,LEXC)=0 F S LEXI=$O(ARY("SYS",6,LEXI)) Q:+LEXI'>0 D
  1. . S LEXC=LEXC+1 S ARY("SYS",6,LEXC,1)=$G(ARY("SYS",6,LEXC,1)),ARY("SYS",6,LEXC,1,"N")="MDC"
  1. . S ARY("SYS",6,LEXC,2)=$G(ARY("SYS",6,LEXC,2)),ARY("SYS",6,LEXC,2,"N")="DRGs"
  1. S ARY("SYS",6,0)=LEXC,ARY("SYS",6,0,"N")="MDC/DRG"
  1. S ARY("SYS",7)=$G(ARY("SYS",7)),ARY("SYS",7,"N")="Complication/Comorbidity"
  1. S ARY("SYS",8)=$G(ARY("SYS",8)),ARY("SYS",8,"N")="MDC13"
  1. S ARY("SYS",9)=$G(ARY("SYS",9)),ARY("SYS",9,"N")="MDC24"
  1. S ARY("SYS",10)=$G(ARY("SYS",10)),ARY("SYS",10,"N")="MDC24"
  1. S ARY("SYS",11)=$G(ARY("SYS",11)),ARY("SYS",11,"N")="Unacceptable as Principal Dx"
  1. S ARY("SYS",12)=$G(ARY("SYS",12)),ARY("SYS",12,"N")="Major O.R Procedure"
  1. S ARY("SYS",13)=$G(ARY("SYS",13)),ARY("SYS",13,"N")="CPT Category"
  1. S (LEXI,LEXC)=0 F S LEXI=$O(ARY("SYS",14,LEXI)) Q:+LEXI'>0 D
  1. . S LEXC=LEXC+1 S ARY("SYS",14,LEXC)=$G(ARY("SYS",14,LEXC))
  1. S ARY("SYS",14,0)=LEXC,ARY("SYS",14,0,"N")="Description"
  1. I LEXSRC=1!(LEXSRC=30) D Q
  1. . K ARY("SYS",12) S ARY("SYS",12)="N/A" K ARY("SYS",13) S ARY("SYS",13)="N/A"
  1. I LEXSRC=2!(LEXSRC=31) D Q
  1. . 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"
  1. . 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"
  1. . K ARY("SYS",13) S ARY("SYS",13)="N/A"
  1. I LEXSRC=3!(LEXSRC=4) D Q
  1. . 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"
  1. . 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"
  1. . 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"
  1. . K ARY("SYS",12) S ARY("SYS",12)="N/A"
  1. 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"
  1. 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"
  1. S ARY("SYS",11)="N/A",ARY("SYS",12)="N/A",ARY("SYS",13)="N/A",ARY("SYS",14)="N/A"
  1. Q
  1. LX ; Lexicon Segment
  1. N LEXC,LEXI S ARY("LEX",1)=$G(ARY("LEX",1)),ARY("LEX",1,"N")="IEN ^ Preferred Term"
  1. S ARY("LEX",2)=$G(ARY("LEX",2)),ARY("LEX",2,"N")="Status ^ Effective Date"
  1. S ARY("LEX",3)=$G(ARY("LEX",3)),ARY("LEX",3,"N")="IEN ^ Major Concept Term"
  1. S ARY("LEX",4)=$G(ARY("LEX",4)),ARY("LEX",4,"N")="IEN ^ Fully Specified Name"
  1. S ARY("LEX",5)=$G(ARY("LEX",5)),ARY("LEX",5,"N")="Hierarchy (if exists)"
  1. S ARY("LEX",6,0)=$G(ARY("LEX",6,0)),ARY("LEX",6,0,"N")="Synonyms and Other Forms"
  1. S (LEXI,LEXC)=0 F S LEXI=$O(ARY("LEX",6,LEXI)) Q:+LEXI'>0 D
  1. . S LEXC=LEXC+1 S ARY("LEX",6,LEXC)=$G(ARY("LEX",6,LEXC))
  1. S ARY("LEX",6,0)=LEXC
  1. S ARY("LEX",7,0)=$G(ARY("LEX",7,0)),ARY("LEX",7,0,"N")="Semantic Map"
  1. S (LEXI,LEXC)=0 F S LEXI=$O(ARY("LEX",7,LEXI)) Q:+LEXI'>0 D
  1. . S LEXC=LEXC+1 S ARY("LEX",7,LEXC,1)=$G(ARY("LEX",7,LEXC,1))
  1. . S ARY("LEX",7,LEXC,1,"N")="Semantic Class ^ Semantic Type (internal)"
  1. . S ARY("LEX",7,LEXC,2)=$G(ARY("LEX",7,LEXC,2))
  1. . S ARY("LEX",7,LEXC,2,"N")="Semantic Class ^ Semantic Type (external)"
  1. S ARY("LEX",7,0)=LEXC
  1. S ARY("LEX",8)=$G(ARY("LEX",8)),ARY("LEX",8,"N")="Deactivated Concept Flag"
  1. Q
  1. ;
  1. MODS ; CPT Modifiers
  1. N IEN,STR,MAX,OUT,LEN,CODE,TD S TD=$$DT^XLFDT,MAX=0,OUT=""
  1. S IEN=0 F S IEN=$O(^ICPT(IEN)) Q:+IEN'>0 D
  1. . S CODE=$P($G(^ICPT(IEN,0)),"^",1)
  1. . K ARY D MS(CODE,TD,.ARY)
  1. Q
  1. MS(X,CDT,LEXS) ; Modifier Strings
  1. 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)
  1. S LEXMOD="",LEXM="",LEXCT=0 F S LEXM=$O(LEX("A",LEXM)) Q:'$L(LEXM) D
  1. . Q:$L(LEXM)'=2 S LEXCT=LEXCT+1,LEXMOD=LEXMOD_"^"_LEXM
  1. . I LEXCT>19 D
  1. . . N LEXI S LEXI=$O(LEXS(" "),-1)+1
  1. . . S LEXS(LEXI)=$$TM(LEXMOD,"^") S LEXMOD="",LEXCT=0
  1. I $L($G(LEXMOD)) D
  1. . N LEXI S LEXI=$O(LEXS(" "),-1)+1 S LEXS(LEXI)=$$TM(LEXMOD,"^")
  1. Q
  1. CODSAB(X,Y) ; Is Code valid for SAB
  1. N COD,SAB,SRC,OK,SIEN S COD=$G(X),SAB=$$CSYS^LEXU($G(Y)) Q:'$L(COD) 0 Q:+SAB'>0 0
  1. S SAB=$P(SAB,"^",2) Q:'$L(SAB) 0 Q:'$D(^LEX(757.03,"ASAB",SAB)) 0
  1. S SRC=$O(^LEX(757.03,"ASAB",SAB,0)) Q:+SRC'>0 0 S OK=0
  1. S SIEN=0 F S SIEN=$O(^LEX(757.02,"CODE",(COD_" "),SIEN)) Q:+SIEN'>0 D
  1. . S:$P($G(^LEX(757.02,+SIEN,0)),"^",3)=SRC OK=1
  1. S X=OK
  1. Q X
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
  1. F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X