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

LEXSRC2.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Global Variables
  1. ; None
  1. ;
  1. ; External References
  1. ; $$STATCHK^ICDEX ICR 5747
  1. ; $$SYS^ICDEX ICR 5747
  1. ; $$STATCHK^ICPTAPIU ICR 1997
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMADD^XLFDT ICR 10103
  1. ;
  1. Q
  1. CPT(LEXC,LEXVDT) ; Return Pointer to Active CPT
  1. ;
  1. ; Input CPT Code
  1. ; Output IEN file 81 of Active Codes only
  1. S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
  1. S LEXC=$$STATCHK^ICPTAPIU(LEXC,LEXVDT) Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
  1. Q +LEXC
  1. ;
  1. ICD(LEXC,LEXVDT) ; Return Pointer to Active ICD/ICP
  1. ;
  1. ; Input ICD Diagnosis or Procedure
  1. ; Output IEN file 80 or 80.1 of Active Codes only
  1. N LEXS S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
  1. S LEXS=$$SYS^ICDEX(LEXC,LEXVDT),LEXC=$$STATCHK^ICDEX(LEXC,LEXVDT,$G(LEXS))
  1. Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
  1. Q +LEXC
  1. ;
  1. STATCHK(CODE,CDT,LEX,SAB) ; Check Status of a Code
  1. ;
  1. ; Input:
  1. ; CODE - Any Code (ICD/CPT/DSM etc) (Required)
  1. ; CDT - Date to screen against (Optional, default TODAY)
  1. ; LEX - Output Array, passed by reference (Optional)
  1. ; SAB - Source Abbreviation or pointer to 757.03 (Optional)
  1. ;
  1. ; Output:
  1. ;
  1. ; 2, 3 or 4 Piece String containing the code's status,
  1. ; the IEN, and if the status exist, the effective
  1. ; date, else -1 in lieu of the IEN.
  1. ;
  1. ; The following are possible outputs:
  1. ;
  1. ; 1 ^ IEN ^ Active Date ^ Initial Date Active Code
  1. ; 1 ^ IEN ^ Revision Date ^ Initial Date Revised Code
  1. ; 0 ^ IEN ^ Effective Date Inactive Code
  1. ; 0 ^ IEN Not Yet Active
  1. ; 0 ^ -1 Code not Found
  1. ;
  1. ; LEX passed by reference (optional)
  1. ;
  1. ; Code, Expression, Coding System, Major
  1. ; Concept Map and Semantic Map in array LEX
  1. ;
  1. ; LEX(0) = Code, a 2 Piece String containing:
  1. ;
  1. ; 1 - IEN in the CODES file #757.02
  1. ; 2 - the code (external)
  1. ;
  1. ; LEX(1) = Expression, a 2 Piece String containing:
  1. ;
  1. ; 1 - IEN in the EXPRESSION file #757.01
  1. ; 2 - the code expression (external)
  1. ;
  1. ; LEX(2) = Coding System, a 4 Piece String containing:
  1. ;
  1. ; 1 - IEN in the CODING SYSTEMS file #757.03
  1. ; 2 - Source Abbreviation (i.e., ICD or CPT)
  1. ; 3 - Source Nomenclature (i.e., ICD-9-CM or CPT-4)
  1. ; 4 - Source Full Name
  1. ;
  1. ; LEX(3) = Major Concept, a 3 Piece String containing:
  1. ;
  1. ; 1 - IEN in the MAJOR CONCEPT MAP file #757
  1. ; 2 - IEN in the EXPRESSIONS file #757.01
  1. ; 3 - The Major Concept expression, which may be
  1. ; different from the code's expression in LEX(1)
  1. ;
  1. ; LEX(4,#)= Semantics (multiple), a 5 Piece String:
  1. ;
  1. ; 1 - IEN in the SEMANTIC MAP file #757.1
  1. ; 2 - IEN in the SEMANTIC CLASS file #757.11
  1. ; 3 - IEN in the SEMANTIC TYPE file #757.12
  1. ; 4 - External Semantic Class
  1. ; 5 - External Semantic Type
  1. ;
  1. N LEXAE,LEXAP,LEXC,LEXDT,LEXE,LEXED,LEXEE,LEXI,LEXIE,LEXIP,LEXMR
  1. N LEXMRI,LEXN,LEXINIT,LEXO,LEXSAB,LEXSTAT,LEXTDT,X
  1. ;
  1. ; LEXC Code from input parameter
  1. ; LEXDT Date from input parameter
  1. ; LEXSAB Source from input parameter (patch 57)
  1. ; LEXAE Last Activation IEN for SAB
  1. ; LEXAP Last Activation Date for SAB
  1. ; LEXIE Last Inactivation IEN for SAB
  1. ; LEXIP Last Inactivation Date for SAB
  1. ; LEXED Earliest Date Possible for SAB
  1. ; LEXEE Earliest Date IEN for SAB
  1. ; LEXE Counter (for Earliest loop)
  1. ; LEXI Counter (for IEN loop)
  1. ; LEXMR Most Recent Date
  1. ; LEXMRI IEN for Most Recent Date for SAB
  1. ; LEXN Data Node
  1. ; LEXO Temporary Value for $O Loops
  1. ; LEXSTAT Status
  1. ; LEXTDT Input Date Offset
  1. ; X Output
  1. ; LEX Output Array (when passed)
  1. ;
  1. S LEXC=$G(CODE) I '$L(LEXC) S (LEX,X)="0^-1" D UPD Q X
  1. S LEXDT=$P($G(CDT),".",1),LEXDT=$S(+LEXDT>0:LEXDT,1:$$DT^XLFDT)
  1. S LEXSAB=$$SAB($G(SAB)),LEXTDT=LEXDT+.00001
  1. ; Find preceding active date/IEN for SAB LEXAP/LEXAE
  1. ; and earliest possible active date/IEN for SAB LEXED/LEXEE
  1. S (LEXED,LEXEE,LEXAE,LEXAP)="",LEXO=LEXTDT F S LEXO=$O(^LEX(757.02,"ACT",(LEXC_" "),3,LEXO),-1) D Q:+LEXO'>0
  1. . I '$L(LEXO)!(+LEXO'>0) D Q
  1. . . 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)
  1. . . . 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)
  1. . . . . Q:+LEXED>0&(+LEXEE>0) N LEXN S LEXN=$G(^LEX(757.02,+LEXI,0)) Q:+LEXSAB>0&($P(LEXN,"^",3)'=+LEXSAB)
  1. . . . . S:'$L(LEXED) LEXED=LEXE S:'$L(LEXEE) LEXEE=LEXI
  1. . N LEXI S LEXI=" " F S LEXI=$O(^LEX(757.02,"ACT",(LEXC_" "),3,LEXO,LEXI),-1) Q:+LEXI'>0 D
  1. . . N LEXN S LEXN=$G(^LEX(757.02,+LEXI,0)) Q:+LEXSAB>0&($P(LEXN,"^",3)'=+LEXSAB)
  1. . . S:'$L(LEXAP) LEXAP=LEXO S:'$L(LEXAE) LEXAE=LEXI
  1. ; Find preceding inactive date/IEN for SAB LEXIP/LEXIE
  1. 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
  1. . N LEXI S LEXI=" " F S LEXI=$O(^LEX(757.02,"ACT",LEXC_" ",2,LEXO,LEXI),-1) Q:+LEXI'>0 D
  1. . . N LEXN S LEXN=$G(^LEX(757.02,+LEXI,0)) Q:+LEXSAB>0&($P(LEXN,"^",3)'=+LEXSAB)
  1. . . S:'$L(LEXIP) LEXIP=LEXO S:'$L(LEXIE) LEXIE=LEXI
  1. ; Quit if input date is before earliest date
  1. I +LEXAP'>0,+LEXIP'>0,+LEXEE>0,+LEXED>0,LEXED?7N,LEXED>LEXDT S X="0^"_LEXEE D UPD Q X
  1. ; Quit if both active/inactive dates are zero
  1. I +LEXAP=0,+LEXIP=0 S (LEX,X)="0^-1" D UPD Q X
  1. ; Find the most recent date/IEN/Status LEXMR/LEXMRI/LEXSTAT
  1. S:LEXAP>LEXIP!(LEXAP=LEXIP) LEXMR=LEXAP,LEXMRI=LEXAE,LEXSTAT=1
  1. S:LEXAP<LEXIP LEXMR=LEXIP,LEXMRI=LEXIE,LEXSTAT=0
  1. ; Check for difficulties from date errors for SAB
  1. D ADJ
  1. S LEXINIT="" I LEXMR?7N,LEXSTAT>0 S LEXINIT=$$INIT(LEXC,LEXMR)
  1. ; Quit with status, code IEN and effective date
  1. S (LEX,X)=LEXSTAT_"^"_LEXMRI_"^"_LEXMR D UPD
  1. S:(LEXMR?7N)&(LEXSTAT>0)&(LEXINIT?7N)&(LEXMR'=LEXINIT) $P(LEX,"^",4)=LEXINIT,X=LEX
  1. Q X
  1. SAB(X) ; Resolve SAB
  1. 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
  1. Q ""
  1. ADJ ; Do we have adjacent dates for SAB
  1. N LEXND,LEXNI,LEXNS,LEXNO,LEXN S LEXND=$$FMADD^XLFDT($G(LEXMR),1)
  1. S LEXNO='LEXSTAT,LEXNS=2+LEXNO Q:LEXND'?7N
  1. S LEXNI=$O(^LEX(757.02,"ACT",(LEXC_" "),LEXNS,LEXND," "),-1)
  1. Q:+LEXNI'>0 S LEXN=$G(^LEX(757.02,+LEXMRI,0))
  1. I +($G(LEXSAB))>0&($P(LEXN,"^",3)=+($G(LEXSAB))) S LEXSTAT=LEXNO,LEXMR=LEXND,LEXMRI=LEXNI
  1. Q
  1. INIT(X,Y) ; Inital Activation Dates (revised codes only)
  1. N LEXA,LEXC,LEXI,LEXOFF,LEXMR S LEXC=$G(X),LEXMR=$P($G(Y),".",1),X="" Q:'$L($G(LEXC)) "" Q:$G(LEXMR)'?7N ""
  1. S:'$D(^LEX(757.02,"ACT",(LEXC_" "),1,LEXMR)) LEXMR=$O(^LEX(757.02,"ACT",(LEXC_" "),1,LEXMR),-1) Q:$G(LEXMR)'?7N ""
  1. S LEXA=(LEXMR-.001) S LEXOFF=$$FMADD^XLFDT(LEXMR,-1)
  1. F S LEXA=$O(^LEX(757.02,"ACT",(LEXC_" "),1,LEXA),-1) Q:LEXA'?7N D
  1. . S LEXI=$O(^LEX(757.02,"ACT",(LEXC_" "),0,LEXA))
  1. . I LEXI>LEXA,LEXI?7N,LEXI'<LEXOFF S X=LEXA
  1. S:'$L(X)&(LEXMR?7N) X=LEXMR
  1. Q X
  1. UPD ; Update Array
  1. N LEXI,LEXC,LEXN,LEXM,LEXE,LEXS,LEXC S LEXI=+($P($G(X),"^",2)) Q:+LEXI'>0
  1. S LEXN=$G(^LEX(757.02,+LEXI,0)),LEXE=+LEXN,LEXC=$P(LEXN,"^",2)
  1. S LEXS=+($P(LEXN,"^",3)),LEXM=+($P(LEXN,"^",4)),LEX(0)=+LEXI_"^"_LEXC
  1. S LEX(1)=LEXE_"^"_$P($G(^LEX(757.01,+LEXE,0)),"^",1)
  1. S LEX(2)=LEXS_"^"_$P($G(^LEX(757.03,+LEXS,0)),"^",1,3)
  1. S LEX(3)=LEXM_"^"_$P($G(^LEX(757,+LEXM,0)),"^",1)_"^"_$G(^LEX(757.01,+($P($G(^LEX(757,+LEXM,0)),"^",1)),0))
  1. S (LEXI,LEXS)=0 F S LEXS=$O(^LEX(757.1,"B",+LEXM,LEXS)) Q:+LEXS'>0 D
  1. . N LEXN,LEXC,LEXT,LEXCT,LEXTT S LEXN=$G(^LEX(757.1,+LEXS,0)),LEXC=$P(LEXN,"^",2),LEXT=$P(LEXN,"^",3)
  1. . S LEXCT=$P($G(^LEX(757.11,+LEXC,0)),"^",2),LEXTT=$P($G(^LEX(757.12,+LEXT,0)),"^",2)
  1. . I LEXC>0,LEXT>0,$L(LEXCT),$L(LEXTT) D
  1. . . S LEXI=LEXI+1,LEX(4,LEXI)=LEXS_"^"_LEXC_"^"_LEXT_"^"_LEXCT_"^"_LEXTT
  1. Q
  1. PI(X) ; Preferred IEN for code X
  1. N LEXE,LEXLA,LEXA,LEXS,LEXC,LEXP,LEXPF,LEXF,LEXI,LEXC,LEXFL
  1. S LEXC=$G(X) Q:'$L(LEXC) "" S (LEXP,LEXF,LEXI)=0,LEXPF(0)=LEXC
  1. F S LEXI=$O(^LEX(757.02,"CODE",(LEXC_" "),LEXI)) Q:+LEXI=0!(LEXP>0) D
  1. . S:+LEXF'>0 LEXF=LEXI S LEXFL=$S(+($P($G(^LEX(757.02,+LEXI,0)),"^",5))>0:1,1:0)
  1. . S LEXE=0,LEXLA="" F S LEXE=$O(^LEX(757.02,+LEXI,4,LEXE)) Q:+LEXE=0 D
  1. . . S LEXS=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",2) Q:+LEXS'>0
  1. . . S LEXA=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",1)
  1. . . S:+LEXA>+LEXLA LEXLA=+LEXA
  1. . S:+LEXLA>0 LEXPF(LEXFL,LEXLA,LEXI)=""
  1. S X="" I $D(LEXPF(1)) S X=$O(LEXPF(1," "),-1),X=$O(LEXPF(1,+X," "),-1)
  1. I '$D(LEXPF(1)),$D(LEXPF(0)) S X=$O(LEXPF(0," "),-1),X=$O(LEXPF(0,+X," "),-1)
  1. Q X