LEXSRC2 ;ISL/KER - Classification Code Source Util ;05/23/2017
;;2.0;LEXICON UTILITY;**25,28,73,80,110,103**;Sep 23, 1996;Build 2
;
; Global Variables
; None
;
; External References
; $$STATCHK^ICDEX ICR 5747
; $$SYS^ICDEX ICR 5747
; $$STATCHK^ICPTAPIU ICR 1997
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
;
Q
CPT(LEXC,LEXVDT) ; Return Pointer to Active CPT
;
; Input CPT Code
; Output IEN file 81 of Active Codes only
S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
S LEXC=$$STATCHK^ICPTAPIU(LEXC,LEXVDT) Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
Q +LEXC
;
ICD(LEXC,LEXVDT) ; Return Pointer to Active ICD/ICP
;
; Input ICD Diagnosis or Procedure
; Output IEN file 80 or 80.1 of Active Codes only
N LEXS S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
S LEXS=$$SYS^ICDEX(LEXC,LEXVDT),LEXC=$$STATCHK^ICDEX(LEXC,LEXVDT,$G(LEXS))
Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
Q +LEXC
;
STATCHK(CODE,CDT,LEX,SAB) ; Check Status of a Code
;
; Input:
; CODE - Any Code (ICD/CPT/DSM etc) (Required)
; CDT - Date to screen against (Optional, default TODAY)
; LEX - Output Array, passed by reference (Optional)
; SAB - Source Abbreviation or pointer to 757.03 (Optional)
;
; Output:
;
; 2, 3 or 4 Piece String containing the code's status,
; the IEN, and if the status exist, the effective
; date, else -1 in lieu of the IEN.
;
; The following are possible outputs:
;
; 1 ^ IEN ^ Active Date ^ Initial Date Active Code
; 1 ^ IEN ^ Revision Date ^ Initial Date Revised Code
; 0 ^ IEN ^ Effective Date Inactive Code
; 0 ^ IEN Not Yet Active
; 0 ^ -1 Code not Found
;
; LEX passed by reference (optional)
;
; Code, Expression, Coding System, Major
; Concept Map and Semantic Map in array LEX
;
; LEX(0) = Code, a 2 Piece String containing:
;
; 1 - IEN in the CODES file #757.02
; 2 - the code (external)
;
; LEX(1) = Expression, a 2 Piece String containing:
;
; 1 - IEN in the EXPRESSION file #757.01
; 2 - the code expression (external)
;
; LEX(2) = Coding System, a 4 Piece String containing:
;
; 1 - IEN in the CODING SYSTEMS file #757.03
; 2 - Source Abbreviation (i.e., ICD or CPT)
; 3 - Source Nomenclature (i.e., ICD-9-CM or CPT-4)
; 4 - Source Full Name
;
; LEX(3) = Major Concept, a 3 Piece String containing:
;
; 1 - IEN in the MAJOR CONCEPT MAP file #757
; 2 - IEN in the EXPRESSIONS file #757.01
; 3 - The Major Concept expression, which may be
; different from the code's expression in LEX(1)
;
; LEX(4,#)= Semantics (multiple), a 5 Piece String:
;
; 1 - IEN in the SEMANTIC MAP file #757.1
; 2 - IEN in the SEMANTIC CLASS file #757.11
; 3 - IEN in the SEMANTIC TYPE file #757.12
; 4 - External Semantic Class
; 5 - External Semantic Type
;
N LEXAE,LEXAP,LEXC,LEXDT,LEXE,LEXED,LEXEE,LEXI,LEXIE,LEXIP,LEXMR
N LEXMRI,LEXN,LEXINIT,LEXO,LEXSAB,LEXSTAT,LEXTDT,X
;
; LEXC Code from input parameter
; LEXDT Date from input parameter
; LEXSAB Source from input parameter (patch 57)
; LEXAE Last Activation IEN for SAB
; LEXAP Last Activation Date for SAB
; LEXIE Last Inactivation IEN for SAB
; LEXIP Last Inactivation Date for SAB
; LEXED Earliest Date Possible for SAB
; LEXEE Earliest Date IEN for SAB
; LEXE Counter (for Earliest loop)
; LEXI Counter (for IEN loop)
; LEXMR Most Recent Date
; LEXMRI IEN for Most Recent Date for SAB
; LEXN Data Node
; LEXO Temporary Value for $O Loops
; LEXSTAT Status
; LEXTDT Input Date Offset
; X Output
; LEX Output Array (when passed)
;
S LEXC=$G(CODE) I '$L(LEXC) S (LEX,X)="0^-1" D UPD Q X
S LEXDT=$P($G(CDT),".",1),LEXDT=$S(+LEXDT>0:LEXDT,1:$$DT^XLFDT)
S LEXSAB=$$SAB($G(SAB)),LEXTDT=LEXDT+.00001
; Find preceding active date/IEN for SAB LEXAP/LEXAE
; and earliest possible active date/IEN for SAB LEXED/LEXEE
S (LEXED,LEXEE,LEXAE,LEXAP)="",LEXO=LEXTDT F S LEXO=$O(^LEX(757.02,"ACT",(LEXC_" "),3,LEXO),-1) D Q:+LEXO'>0
. I '$L(LEXO)!(+LEXO'>0) D Q
. . N LEXE S LEXE=LEXTDT F S LEXE=$O(^LEX(757.02,"ACT",(LEXC_" "),1,LEXE)) Q:+LEXE'>0 D Q:+LEXED>0&(+LEXEE>0)
. . . N LEXI S LEXI=0 F S LEXI=$O(^LEX(757.02,"ACT",(LEXC_" "),1,LEXE,LEXI)) Q:+LEXI'>0 D Q:+LEXED>0&(+LEXEE>0)
. . . . Q:+LEXED>0&(+LEXEE>0) N LEXN S LEXN=$G(^LEX(757.02,+LEXI,0)) Q:+LEXSAB>0&($P(LEXN,"^",3)'=+LEXSAB)
. . . . S:'$L(LEXED) LEXED=LEXE S:'$L(LEXEE) LEXEE=LEXI
. N LEXI S LEXI=" " F S LEXI=$O(^LEX(757.02,"ACT",(LEXC_" "),3,LEXO,LEXI),-1) Q:+LEXI'>0 D
. . N LEXN S LEXN=$G(^LEX(757.02,+LEXI,0)) Q:+LEXSAB>0&($P(LEXN,"^",3)'=+LEXSAB)
. . S:'$L(LEXAP) LEXAP=LEXO S:'$L(LEXAE) LEXAE=LEXI
; Find preceding inactive date/IEN for SAB LEXIP/LEXIE
N LEXO,LEXIP,LEXIE S (LEXIE,LEXIP)="",LEXO=LEXTDT F S LEXO=$O(^LEX(757.02,"ACT",LEXC_" ",2,LEXO),-1) Q:+LEXO'>0 D
. N LEXI S LEXI=" " F S LEXI=$O(^LEX(757.02,"ACT",LEXC_" ",2,LEXO,LEXI),-1) Q:+LEXI'>0 D
. . N LEXN S LEXN=$G(^LEX(757.02,+LEXI,0)) Q:+LEXSAB>0&($P(LEXN,"^",3)'=+LEXSAB)
. . S:'$L(LEXIP) LEXIP=LEXO S:'$L(LEXIE) LEXIE=LEXI
; Quit if input date is before earliest date
I +LEXAP'>0,+LEXIP'>0,+LEXEE>0,+LEXED>0,LEXED?7N,LEXED>LEXDT S X="0^"_LEXEE D UPD Q X
; Quit if both active/inactive dates are zero
I +LEXAP=0,+LEXIP=0 S (LEX,X)="0^-1" D UPD Q X
; Find the most recent date/IEN/Status LEXMR/LEXMRI/LEXSTAT
S:LEXAP>LEXIP!(LEXAP=LEXIP) LEXMR=LEXAP,LEXMRI=LEXAE,LEXSTAT=1
S:LEXAP<LEXIP LEXMR=LEXIP,LEXMRI=LEXIE,LEXSTAT=0
; Check for difficulties from date errors for SAB
D ADJ
S LEXINIT="" I LEXMR?7N,LEXSTAT>0 S LEXINIT=$$INIT(LEXC,LEXMR)
; Quit with status, code IEN and effective date
S (LEX,X)=LEXSTAT_"^"_LEXMRI_"^"_LEXMR D UPD
S:(LEXMR?7N)&(LEXSTAT>0)&(LEXINIT?7N)&(LEXMR'=LEXINIT) $P(LEX,"^",4)=LEXINIT,X=LEX
Q X
SAB(X) ; Resolve SAB
N Y S Y=$G(X) Q:'$L($G(Y)) "" S X=+($O(^LEX(757.03,"ASAB",$E($G(Y),1,3),0))) Q:+X>0 X S X=+Y Q:$D(^LEX(757.03,+Y,0)) X
Q ""
ADJ ; Do we have adjacent dates for SAB
N LEXND,LEXNI,LEXNS,LEXNO,LEXN S LEXND=$$FMADD^XLFDT($G(LEXMR),1)
S LEXNO='LEXSTAT,LEXNS=2+LEXNO Q:LEXND'?7N
S LEXNI=$O(^LEX(757.02,"ACT",(LEXC_" "),LEXNS,LEXND," "),-1)
Q:+LEXNI'>0 S LEXN=$G(^LEX(757.02,+LEXMRI,0))
I +($G(LEXSAB))>0&($P(LEXN,"^",3)=+($G(LEXSAB))) S LEXSTAT=LEXNO,LEXMR=LEXND,LEXMRI=LEXNI
Q
INIT(X,Y) ; Inital Activation Dates (revised codes only)
N LEXA,LEXC,LEXI,LEXOFF,LEXMR S LEXC=$G(X),LEXMR=$P($G(Y),".",1),X="" Q:'$L($G(LEXC)) "" Q:$G(LEXMR)'?7N ""
S:'$D(^LEX(757.02,"ACT",(LEXC_" "),1,LEXMR)) LEXMR=$O(^LEX(757.02,"ACT",(LEXC_" "),1,LEXMR),-1) Q:$G(LEXMR)'?7N ""
S LEXA=(LEXMR-.001) S LEXOFF=$$FMADD^XLFDT(LEXMR,-1)
F S LEXA=$O(^LEX(757.02,"ACT",(LEXC_" "),1,LEXA),-1) Q:LEXA'?7N D
. S LEXI=$O(^LEX(757.02,"ACT",(LEXC_" "),0,LEXA))
. I LEXI>LEXA,LEXI?7N,LEXI'<LEXOFF S X=LEXA
S:'$L(X)&(LEXMR?7N) X=LEXMR
Q X
UPD ; Update Array
N LEXI,LEXC,LEXN,LEXM,LEXE,LEXS,LEXC S LEXI=+($P($G(X),"^",2)) Q:+LEXI'>0
S LEXN=$G(^LEX(757.02,+LEXI,0)),LEXE=+LEXN,LEXC=$P(LEXN,"^",2)
S LEXS=+($P(LEXN,"^",3)),LEXM=+($P(LEXN,"^",4)),LEX(0)=+LEXI_"^"_LEXC
S LEX(1)=LEXE_"^"_$P($G(^LEX(757.01,+LEXE,0)),"^",1)
S LEX(2)=LEXS_"^"_$P($G(^LEX(757.03,+LEXS,0)),"^",1,3)
S LEX(3)=LEXM_"^"_$P($G(^LEX(757,+LEXM,0)),"^",1)_"^"_$G(^LEX(757.01,+($P($G(^LEX(757,+LEXM,0)),"^",1)),0))
S (LEXI,LEXS)=0 F S LEXS=$O(^LEX(757.1,"B",+LEXM,LEXS)) Q:+LEXS'>0 D
. N LEXN,LEXC,LEXT,LEXCT,LEXTT S LEXN=$G(^LEX(757.1,+LEXS,0)),LEXC=$P(LEXN,"^",2),LEXT=$P(LEXN,"^",3)
. S LEXCT=$P($G(^LEX(757.11,+LEXC,0)),"^",2),LEXTT=$P($G(^LEX(757.12,+LEXT,0)),"^",2)
. I LEXC>0,LEXT>0,$L(LEXCT),$L(LEXTT) D
. . S LEXI=LEXI+1,LEX(4,LEXI)=LEXS_"^"_LEXC_"^"_LEXT_"^"_LEXCT_"^"_LEXTT
Q
PI(X) ; Preferred IEN for code X
N LEXE,LEXLA,LEXA,LEXS,LEXC,LEXP,LEXPF,LEXF,LEXI,LEXC,LEXFL
S LEXC=$G(X) Q:'$L(LEXC) "" S (LEXP,LEXF,LEXI)=0,LEXPF(0)=LEXC
F S LEXI=$O(^LEX(757.02,"CODE",(LEXC_" "),LEXI)) Q:+LEXI=0!(LEXP>0) D
. S:+LEXF'>0 LEXF=LEXI S LEXFL=$S(+($P($G(^LEX(757.02,+LEXI,0)),"^",5))>0:1,1:0)
. S LEXE=0,LEXLA="" F S LEXE=$O(^LEX(757.02,+LEXI,4,LEXE)) Q:+LEXE=0 D
. . S LEXS=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",2) Q:+LEXS'>0
. . S LEXA=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",1)
. . S:+LEXA>+LEXLA LEXLA=+LEXA
. S:+LEXLA>0 LEXPF(LEXFL,LEXLA,LEXI)=""
S X="" I $D(LEXPF(1)) S X=$O(LEXPF(1," "),-1),X=$O(LEXPF(1,+X," "),-1)
I '$D(LEXPF(1)),$D(LEXPF(0)) S X=$O(LEXPF(0," "),-1),X=$O(LEXPF(0,+X," "),-1)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXSRC2 9395 printed Sep 23, 2025@19:45:36 Page 2
LEXSRC2 ;ISL/KER - Classification Code Source Util ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**25,28,73,80,110,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; $$STATCHK^ICDEX ICR 5747
+8 ; $$SYS^ICDEX ICR 5747
+9 ; $$STATCHK^ICPTAPIU ICR 1997
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMADD^XLFDT ICR 10103
+12 ;
+13 QUIT
CPT(LEXC,LEXVDT) ; Return Pointer to Active CPT
+1 ;
+2 ; Input CPT Code
+3 ; Output IEN file 81 of Active Codes only
+4 SET LEXC=$GET(LEXC)
if '$LENGTH(LEXC)
QUIT ""
SET LEXVDT=$GET(LEXVDT)
if +LEXVDT'>0
SET LEXVDT=$$DT^XLFDT
+5 SET LEXC=$$STATCHK^ICPTAPIU(LEXC,LEXVDT)
if +LEXC'>0
QUIT ""
SET LEXC=$PIECE(LEXC,"^",2)
if +LEXC'>0
QUIT ""
+6 QUIT +LEXC
+7 ;
ICD(LEXC,LEXVDT) ; Return Pointer to Active ICD/ICP
+1 ;
+2 ; Input ICD Diagnosis or Procedure
+3 ; Output IEN file 80 or 80.1 of Active Codes only
+4 NEW LEXS
SET LEXC=$GET(LEXC)
if '$LENGTH(LEXC)
QUIT ""
SET LEXVDT=$GET(LEXVDT)
if +LEXVDT'>0
SET LEXVDT=$$DT^XLFDT
+5 SET LEXS=$$SYS^ICDEX(LEXC,LEXVDT)
SET LEXC=$$STATCHK^ICDEX(LEXC,LEXVDT,$GET(LEXS))
+6 if +LEXC'>0
QUIT ""
SET LEXC=$PIECE(LEXC,"^",2)
if +LEXC'>0
QUIT ""
+7 QUIT +LEXC
+8 ;
STATCHK(CODE,CDT,LEX,SAB) ; Check Status of a Code
+1 ;
+2 ; Input:
+3 ; CODE - Any Code (ICD/CPT/DSM etc) (Required)
+4 ; CDT - Date to screen against (Optional, default TODAY)
+5 ; LEX - Output Array, passed by reference (Optional)
+6 ; SAB - Source Abbreviation or pointer to 757.03 (Optional)
+7 ;
+8 ; Output:
+9 ;
+10 ; 2, 3 or 4 Piece String containing the code's status,
+11 ; the IEN, and if the status exist, the effective
+12 ; date, else -1 in lieu of the IEN.
+13 ;
+14 ; The following are possible outputs:
+15 ;
+16 ; 1 ^ IEN ^ Active Date ^ Initial Date Active Code
+17 ; 1 ^ IEN ^ Revision Date ^ Initial Date Revised Code
+18 ; 0 ^ IEN ^ Effective Date Inactive Code
+19 ; 0 ^ IEN Not Yet Active
+20 ; 0 ^ -1 Code not Found
+21 ;
+22 ; LEX passed by reference (optional)
+23 ;
+24 ; Code, Expression, Coding System, Major
+25 ; Concept Map and Semantic Map in array LEX
+26 ;
+27 ; LEX(0) = Code, a 2 Piece String containing:
+28 ;
+29 ; 1 - IEN in the CODES file #757.02
+30 ; 2 - the code (external)
+31 ;
+32 ; LEX(1) = Expression, a 2 Piece String containing:
+33 ;
+34 ; 1 - IEN in the EXPRESSION file #757.01
+35 ; 2 - the code expression (external)
+36 ;
+37 ; LEX(2) = Coding System, a 4 Piece String containing:
+38 ;
+39 ; 1 - IEN in the CODING SYSTEMS file #757.03
+40 ; 2 - Source Abbreviation (i.e., ICD or CPT)
+41 ; 3 - Source Nomenclature (i.e., ICD-9-CM or CPT-4)
+42 ; 4 - Source Full Name
+43 ;
+44 ; LEX(3) = Major Concept, a 3 Piece String containing:
+45 ;
+46 ; 1 - IEN in the MAJOR CONCEPT MAP file #757
+47 ; 2 - IEN in the EXPRESSIONS file #757.01
+48 ; 3 - The Major Concept expression, which may be
+49 ; different from the code's expression in LEX(1)
+50 ;
+51 ; LEX(4,#)= Semantics (multiple), a 5 Piece String:
+52 ;
+53 ; 1 - IEN in the SEMANTIC MAP file #757.1
+54 ; 2 - IEN in the SEMANTIC CLASS file #757.11
+55 ; 3 - IEN in the SEMANTIC TYPE file #757.12
+56 ; 4 - External Semantic Class
+57 ; 5 - External Semantic Type
+58 ;
+59 NEW LEXAE,LEXAP,LEXC,LEXDT,LEXE,LEXED,LEXEE,LEXI,LEXIE,LEXIP,LEXMR
+60 NEW LEXMRI,LEXN,LEXINIT,LEXO,LEXSAB,LEXSTAT,LEXTDT,X
+61 ;
+62 ; LEXC Code from input parameter
+63 ; LEXDT Date from input parameter
+64 ; LEXSAB Source from input parameter (patch 57)
+65 ; LEXAE Last Activation IEN for SAB
+66 ; LEXAP Last Activation Date for SAB
+67 ; LEXIE Last Inactivation IEN for SAB
+68 ; LEXIP Last Inactivation Date for SAB
+69 ; LEXED Earliest Date Possible for SAB
+70 ; LEXEE Earliest Date IEN for SAB
+71 ; LEXE Counter (for Earliest loop)
+72 ; LEXI Counter (for IEN loop)
+73 ; LEXMR Most Recent Date
+74 ; LEXMRI IEN for Most Recent Date for SAB
+75 ; LEXN Data Node
+76 ; LEXO Temporary Value for $O Loops
+77 ; LEXSTAT Status
+78 ; LEXTDT Input Date Offset
+79 ; X Output
+80 ; LEX Output Array (when passed)
+81 ;
+82 SET LEXC=$GET(CODE)
IF '$LENGTH(LEXC)
SET (LEX,X)="0^-1"
DO UPD
QUIT X
+83 SET LEXDT=$PIECE($GET(CDT),".",1)
SET LEXDT=$SELECT(+LEXDT>0:LEXDT,1:$$DT^XLFDT)
+84 SET LEXSAB=$$SAB($GET(SAB))
SET LEXTDT=LEXDT+.00001
+85 ; Find preceding active date/IEN for SAB LEXAP/LEXAE
+86 ; and earliest possible active date/IEN for SAB LEXED/LEXEE
+87 SET (LEXED,LEXEE,LEXAE,LEXAP)=""
SET LEXO=LEXTDT
FOR
SET LEXO=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),3,LEXO),-1)
Begin DoDot:1
+88 IF '$LENGTH(LEXO)!(+LEXO'>0)
Begin DoDot:2
+89 NEW LEXE
SET LEXE=LEXTDT
FOR
SET LEXE=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),1,LEXE))
if +LEXE'>0
QUIT
Begin DoDot:3
+90 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),1,LEXE,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:4
+91 if +LEXED>0&(+LEXEE>0)
QUIT
NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEXI,0))
if +LEXSAB>0&($PIECE(LEXN,"^",3)'=+LEXSAB)
QUIT
+92 if '$LENGTH(LEXED)
SET LEXED=LEXE
if '$LENGTH(LEXEE)
SET LEXEE=LEXI
End DoDot:4
if +LEXED>0&(+LEXEE>0)
QUIT
End DoDot:3
if +LEXED>0&(+LEXEE>0)
QUIT
End DoDot:2
QUIT
+93 NEW LEXI
SET LEXI=" "
FOR
SET LEXI=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),3,LEXO,LEXI),-1)
if +LEXI'>0
QUIT
Begin DoDot:2
+94 NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEXI,0))
if +LEXSAB>0&($PIECE(LEXN,"^",3)'=+LEXSAB)
QUIT
+95 if '$LENGTH(LEXAP)
SET LEXAP=LEXO
if '$LENGTH(LEXAE)
SET LEXAE=LEXI
End DoDot:2
End DoDot:1
if +LEXO'>0
QUIT
+96 ; Find preceding inactive date/IEN for SAB LEXIP/LEXIE
+97 NEW LEXO,LEXIP,LEXIE
SET (LEXIE,LEXIP)=""
SET LEXO=LEXTDT
FOR
SET LEXO=$ORDER(^LEX(757.02,"ACT",LEXC_" ",2,LEXO),-1)
if +LEXO'>0
QUIT
Begin DoDot:1
+98 NEW LEXI
SET LEXI=" "
FOR
SET LEXI=$ORDER(^LEX(757.02,"ACT",LEXC_" ",2,LEXO,LEXI),-1)
if +LEXI'>0
QUIT
Begin DoDot:2
+99 NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEXI,0))
if +LEXSAB>0&($PIECE(LEXN,"^",3)'=+LEXSAB)
QUIT
+100 if '$LENGTH(LEXIP)
SET LEXIP=LEXO
if '$LENGTH(LEXIE)
SET LEXIE=LEXI
End DoDot:2
End DoDot:1
+101 ; Quit if input date is before earliest date
+102 IF +LEXAP'>0
IF +LEXIP'>0
IF +LEXEE>0
IF +LEXED>0
IF LEXED?7N
IF LEXED>LEXDT
SET X="0^"_LEXEE
DO UPD
QUIT X
+103 ; Quit if both active/inactive dates are zero
+104 IF +LEXAP=0
IF +LEXIP=0
SET (LEX,X)="0^-1"
DO UPD
QUIT X
+105 ; Find the most recent date/IEN/Status LEXMR/LEXMRI/LEXSTAT
+106 if LEXAP>LEXIP!(LEXAP=LEXIP)
SET LEXMR=LEXAP
SET LEXMRI=LEXAE
SET LEXSTAT=1
+107 if LEXAP<LEXIP
SET LEXMR=LEXIP
SET LEXMRI=LEXIE
SET LEXSTAT=0
+108 ; Check for difficulties from date errors for SAB
+109 DO ADJ
+110 SET LEXINIT=""
IF LEXMR?7N
IF LEXSTAT>0
SET LEXINIT=$$INIT(LEXC,LEXMR)
+111 ; Quit with status, code IEN and effective date
+112 SET (LEX,X)=LEXSTAT_"^"_LEXMRI_"^"_LEXMR
DO UPD
+113 if (LEXMR?7N)&(LEXSTAT>0)&(LEXINIT?7N)&(LEXMR'=LEXINIT)
SET $PIECE(LEX,"^",4)=LEXINIT
SET X=LEX
+114 QUIT X
SAB(X) ; Resolve SAB
+1 NEW Y
SET Y=$GET(X)
if '$LENGTH($GET(Y))
QUIT ""
SET X=+($ORDER(^LEX(757.03,"ASAB",$EXTRACT($GET(Y),1,3),0)))
if +X>0
QUIT X
SET X=+Y
if $DATA(^LEX(757.03,+Y,0))
QUIT X
+2 QUIT ""
ADJ ; Do we have adjacent dates for SAB
+1 NEW LEXND,LEXNI,LEXNS,LEXNO,LEXN
SET LEXND=$$FMADD^XLFDT($GET(LEXMR),1)
+2 SET LEXNO='LEXSTAT
SET LEXNS=2+LEXNO
if LEXND'?7N
QUIT
+3 SET LEXNI=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),LEXNS,LEXND," "),-1)
+4 if +LEXNI'>0
QUIT
SET LEXN=$GET(^LEX(757.02,+LEXMRI,0))
+5 IF +($GET(LEXSAB))>0&($PIECE(LEXN,"^",3)=+($GET(LEXSAB)))
SET LEXSTAT=LEXNO
SET LEXMR=LEXND
SET LEXMRI=LEXNI
+6 QUIT
INIT(X,Y) ; Inital Activation Dates (revised codes only)
+1 NEW LEXA,LEXC,LEXI,LEXOFF,LEXMR
SET LEXC=$GET(X)
SET LEXMR=$PIECE($GET(Y),".",1)
SET X=""
if '$LENGTH($GET(LEXC))
QUIT ""
if $GET(LEXMR)'?7N
QUIT ""
+2 if '$DATA(^LEX(757.02,"ACT",(LEXC_" "),1,LEXMR))
SET LEXMR=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),1,LEXMR),-1)
if $GET(LEXMR)'?7N
QUIT ""
+3 SET LEXA=(LEXMR-.001)
SET LEXOFF=$$FMADD^XLFDT(LEXMR,-1)
+4 FOR
SET LEXA=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),1,LEXA),-1)
if LEXA'?7N
QUIT
Begin DoDot:1
+5 SET LEXI=$ORDER(^LEX(757.02,"ACT",(LEXC_" "),0,LEXA))
+6 IF LEXI>LEXA
IF LEXI?7N
IF LEXI'<LEXOFF
SET X=LEXA
End DoDot:1
+7 if '$LENGTH(X)&(LEXMR?7N)
SET X=LEXMR
+8 QUIT X
UPD ; Update Array
+1 NEW LEXI,LEXC,LEXN,LEXM,LEXE,LEXS,LEXC
SET LEXI=+($PIECE($GET(X),"^",2))
if +LEXI'>0
QUIT
+2 SET LEXN=$GET(^LEX(757.02,+LEXI,0))
SET LEXE=+LEXN
SET LEXC=$PIECE(LEXN,"^",2)
+3 SET LEXS=+($PIECE(LEXN,"^",3))
SET LEXM=+($PIECE(LEXN,"^",4))
SET LEX(0)=+LEXI_"^"_LEXC
+4 SET LEX(1)=LEXE_"^"_$PIECE($GET(^LEX(757.01,+LEXE,0)),"^",1)
+5 SET LEX(2)=LEXS_"^"_$PIECE($GET(^LEX(757.03,+LEXS,0)),"^",1,3)
+6 SET LEX(3)=LEXM_"^"_$PIECE($GET(^LEX(757,+LEXM,0)),"^",1)_"^"_$GET(^LEX(757.01,+($PIECE($GET(^LEX(757,+LEXM,0)),"^",1)),0))
+7 SET (LEXI,LEXS)=0
FOR
SET LEXS=$ORDER(^LEX(757.1,"B",+LEXM,LEXS))
if +LEXS'>0
QUIT
Begin DoDot:1
+8 NEW LEXN,LEXC,LEXT,LEXCT,LEXTT
SET LEXN=$GET(^LEX(757.1,+LEXS,0))
SET LEXC=$PIECE(LEXN,"^",2)
SET LEXT=$PIECE(LEXN,"^",3)
+9 SET LEXCT=$PIECE($GET(^LEX(757.11,+LEXC,0)),"^",2)
SET LEXTT=$PIECE($GET(^LEX(757.12,+LEXT,0)),"^",2)
+10 IF LEXC>0
IF LEXT>0
IF $LENGTH(LEXCT)
IF $LENGTH(LEXTT)
Begin DoDot:2
+11 SET LEXI=LEXI+1
SET LEX(4,LEXI)=LEXS_"^"_LEXC_"^"_LEXT_"^"_LEXCT_"^"_LEXTT
End DoDot:2
End DoDot:1
+12 QUIT
PI(X) ; Preferred IEN for code X
+1 NEW LEXE,LEXLA,LEXA,LEXS,LEXC,LEXP,LEXPF,LEXF,LEXI,LEXC,LEXFL
+2 SET LEXC=$GET(X)
if '$LENGTH(LEXC)
QUIT ""
SET (LEXP,LEXF,LEXI)=0
SET LEXPF(0)=LEXC
+3 FOR
SET LEXI=$ORDER(^LEX(757.02,"CODE",(LEXC_" "),LEXI))
if +LEXI=0!(LEXP>0)
QUIT
Begin DoDot:1
+4 if +LEXF'>0
SET LEXF=LEXI
SET LEXFL=$SELECT(+($PIECE($GET(^LEX(757.02,+LEXI,0)),"^",5))>0:1,1:0)
+5 SET LEXE=0
SET LEXLA=""
FOR
SET LEXE=$ORDER(^LEX(757.02,+LEXI,4,LEXE))
if +LEXE=0
QUIT
Begin DoDot:2
+6 SET LEXS=$PIECE($GET(^LEX(757.02,+LEXI,4,LEXE,0)),"^",2)
if +LEXS'>0
QUIT
+7 SET LEXA=$PIECE($GET(^LEX(757.02,+LEXI,4,LEXE,0)),"^",1)
+8 if +LEXA>+LEXLA
SET LEXLA=+LEXA
End DoDot:2
+9 if +LEXLA>0
SET LEXPF(LEXFL,LEXLA,LEXI)=""
End DoDot:1
+10 SET X=""
IF $DATA(LEXPF(1))
SET X=$ORDER(LEXPF(1," "),-1)
SET X=$ORDER(LEXPF(1,+X," "),-1)
+11 IF '$DATA(LEXPF(1))
IF $DATA(LEXPF(0))
SET X=$ORDER(LEXPF(0," "),-1)
SET X=$ORDER(LEXPF(0,+X," "),-1)
+12 QUIT X
