- 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 Jan 18, 2025@03:10:39 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