- LEXU4 ;ISL/KER - Miscellaneous Lexicon Utilities ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- ;
- ;
- ; Global Variables
- ; ^ICPT("BA"
- ;
- ; External References
- ; $$CODEABA^ICDEX ICR 5747
- ; $$ICDDX^ICDEX ICR 5747
- ; $$ICDOP^ICDEX ICR 5747
- ; $$ROOT^ICDEX ICR 5747
- ; $$CPT^ICPTCOD ICR 1995
- ; $$DT^XLFDT ICR 10103
- ;
- HIST(CODE,SYS,ARY) ; Get Activation History for a Code
- ;
- ; Input:
- ;
- ; CODE ICD Code (required)
- ; SYS Coding System
- ; .ARY Array, passed by Reference (required)
- ;
- ; Output:
- ;
- ; $$HIST Number of Histories Found
- ; or
- ; -1 ^ error message
- ;
- ; ARY(0) = Number of Activation History
- ; ARY(0,0) = Code ^ Source Abbreviation ^ Source Nomenclature
- ; ARY(<date>,<status>) = Comment
- ;
- N LEXA,LEXC,LEXE,LEXI,LEXN,LEXNOM,LEXP,LEXS,LEXSAB,LEXSI,LEXSO,LEXSRC,LEXTD,X
- S LEXSO=$G(CODE) K ARY Q:'$L(LEXSO) "-1^Code missing"
- Q:'$D(^LEX(757.02,"ACT",(LEXSO_" "))) "-1^Invalid code missing"
- S LEXSAB=$G(SYS),LEXSRC=+($$CSYS^LEXU(LEXSAB))
- S:LEXSRC'>0 LEXSRC=$$SYSC(LEXSO) Q:+LEXSRC'>0 "-1^Invalid source"
- S LEXNOM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2)
- S (LEXSI,LEXSAB)=$$CSYS^LEXU(+LEXSRC)
- S LEXSI=$P(LEXSI,"^",3,4)
- S LEXSAB=$P(LEXSAB,"^",2) Q:$L(LEXSAB)'=3 "-1^Invalid source"
- S LEXTD=$$DT^XLFDT F LEXI=0,1 D
- . N LEXE S LEXE=0
- . F S LEXE=$O(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE)) Q:+LEXE'>0 D
- . . N LEXS S LEXS=0
- . . F S LEXS=$O(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE,LEXS)) Q:+LEXS'>0 D
- . . . N LEXN,LEXC S LEXN=$G(^LEX(757.02,LEXS,0))
- . . . S LEXC=+($P(LEXN,"^",3)) Q:+LEXC'=LEXSRC
- . . . S:'$D(ARY(LEXE,LEXI)) ARY(0)=+($G(ARY(0)))+1
- . . . S ARY(LEXE,LEXI)=""
- S LEXA=0,LEXE=0 F S LEXE=$O(ARY(LEXE)) Q:+LEXE'>0 D
- . S LEXS="" F S LEXS=$O(ARY(LEXE,LEXS)) Q:'$L(LEXS) D
- . . S:+LEXS>0 LEXA=1 K:+LEXA'>0 ARY(LEXE,LEXS)
- S LEXA=0,LEXE=0 F S LEXE=$O(ARY(LEXE)) Q:+LEXE'>0 D
- . S LEXS="" F S LEXS=$O(ARY(LEXE,LEXS)) Q:'$L(LEXS) D
- . . S:+LEXS>0 LEXA=LEXA+1
- . . I +LEXS>0,LEXA=1 S ARY(LEXE,LEXS)="Activated" Q
- . . I +LEXS'>0 S ARY(LEXE,LEXS)="Inactivated" Q
- . . I +LEXS>0 D
- . . . S ARY(LEXE,LEXS)="Re-activated"
- . . . I $D(ARY(LEXE,0)) D Q
- . . . . S ARY(LEXE,LEXS)="Revised" K ARY(LEXE,0)
- . . . S LEXP=$O(ARY(LEXE),-1) I +LEXP>0 D
- . . . . I $O(ARY(LEXE," "),-1)'>0 S ARY(LEXE,LEXS)="Re-Used" K ARY(LEXE,0)
- K ARY(0) S LEXN=0,LEXC="" F S LEXC=$O(ARY(LEXC)) Q:'$L(LEXC) D
- . S LEXI="" F S LEXI=$O(ARY(LEXC,LEXI)) Q:'$L(LEXI) D
- . . I LEXI?1N,LEXC?7N,LEXC>LEXTD,$L($G(ARY(LEXC,LEXI))) D
- . . . S ARY(LEXC,LEXI)=$G(ARY(LEXC,LEXI))_" (Pending)"
- . . S LEXN=LEXN+1
- S X=+($G(LEXN)) S:LEXN>0 ARY(0)=+($G(LEXN)) S:X'>0 X="-1^No History Found"
- S:LEXN>0&($L(LEXSI))&($L(LEXSO)) ARY(0,0)=LEXSO_"^"_LEXSI
- Q X
- PERIOD(CODE,SYS,ARY) ; Get Activation/Inactivation Periods for a Code
- ;
- ; Input:
- ;
- ; CODE ICD Code (required)
- ; SYS Coding System
- ; .ARY Array, passed by Reference (required)
- ;
- ; Output:
- ;
- ; $$PERIOD Multiple piece "^" delimited string
- ;
- ; 1 Number of Activation Periods found
- ; 2 Coding System (interal)
- ; 3 Source Abbreviation
- ; 4 Coding System Nomenclature
- ; 5 Coding System Name
- ;
- ; or
- ;
- ; -1^ Message (no period or error message)
- ;
- ; ARY(0) Same as $$PERIOD (above)
- ;
- ; ARY(Activation Date) = 4 piece "^" delimited string
- ;
- ; 1 Inactivation Date
- ; (conditional)
- ;
- ; 2 Pointer to Expression file 757.01
- ; for the code in piece #2 above
- ; (required)
- ;
- ; 3 Variable Pointer IEN;Root of a
- ; national file (see below) Include
- ; when the code exist in an national
- ; file (conditional)
- ;
- ; CPT/HCPCS Procedure code IEN;ICPT(
- ; ICD Diagnosis code IEN;ICD9(
- ; ICD Procedure code IEN;ICD0(
- ;
- ; 4 Short Description from the SDO file
- ; (CPT or ICD)
- ;
- ; ARY(Activation Date,0) = Lexicon Expression
- ;
- ; Functions like PERIOD^ICDAPIU, except it can include
- ; any coding system in the Lexicon, not just ICD.
- ;
- N LEXACT,LEXD,LEXDT,LEXEF,LEXEXI,LEXEXP,LEXI,LEXIDT,LEXIEN
- N LEXINA,LEXND,LEXPDT,LEXPER,LEXSD,LEXSO,LEXSY,LEXSYS,LEXVP
- S LEXSO=$G(CODE) Q:'$L(LEXSO) "-1^Missing Code"
- Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) "-1^Invalid Code"
- S (LEXSD,LEXSYS)=$$CSYS^LEXU(SYS),LEXSYS=+LEXSYS
- Q:+LEXSYS'>0 "-1^Missing/Invalid Coding System"
- Q:'$D(^LEX(757.03,+LEXSYS,0)) "-1^Invalid Coding System"
- K ARY,LEXACT,LEXINA
- S LEXDT="" F S LEXDT=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT)) Q:'$L(LEXDT) D
- . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT,LEXIEN)) Q:+LEXIEN'>0 D
- . . N LEXND,LEXSY,LEXEXI S LEXND=$G(^LEX(757.02,+LEXIEN,0)),LEXSY=$P(LEXND,"^",3),LEXEXI=+LEXND
- . . Q:LEXSY'=LEXSYS S LEXACT(LEXDT)=LEXEXI
- S LEXDT="" F S LEXDT=$O(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT)) Q:'$L(LEXDT) D
- . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT,LEXIEN)) Q:+LEXIEN'>0 D
- . . N LEXND,LEXSY,LEXEXI S LEXND=$G(^LEX(757.02,+LEXIEN,0)),LEXSY=$P(LEXND,"^",3),LEXEXI=+LEXND
- . . Q:LEXSY'=LEXSYS S LEXINA(LEXDT)=LEXEXI
- S LEXDT="" F S LEXDT=$O(LEXACT(LEXDT)) Q:'$L(LEXDT) D
- . I $D(LEXINA(LEXDT)) D
- . . N LEXEXI,LEXPDT
- . . S LEXEXI=$G(LEXACT(LEXDT)),LEXPDT=$O(LEXACT(LEXDT),-1)
- . . S:LEXPDT?7N&(LEXEXI>0) LEXACT(LEXPDT)=LEXEXI
- . . K LEXACT(LEXDT),LEXINA(LEXDT)
- S LEXDT="" F S LEXDT=$O(LEXACT(LEXDT)) Q:'$L(LEXDT) D
- . N LEXIDT,LEXEXI,LEXEXP,LEXEF,LEXVP
- . ; Inactive Date
- . S LEXIDT=$O(LEXINA(LEXDT))
- . ; Lexicon Expression
- . S LEXEXI=$G(LEXACT(LEXDT))
- . S:LEXIDT?7N LEXEXI=$G(LEXINA(LEXIDT))
- . S LEXEXP="" S:+LEXEXI>0 LEXEXP=$G(^LEX(757.01,+LEXEXI,0))
- . ; Kill
- . K:LEXIDT?7N LEXINA(LEXIDT)
- . ; Effective Date
- . S LEXEF=$$DT^XLFDT S:LEXIDT?7N LEXEF=LEXIDT
- . ; Variable Pointer
- . S LEXVP=$$VP(LEXSO,LEXSYS,LEXEF)
- . ; Set array
- . S:LEXIDT'?7N LEXIDT=""
- . S LEXPER(LEXDT)=LEXIDT_"^"_LEXEXI_"^"_LEXVP
- . S:$L(LEXEXP) LEXPER(LEXDT,0)=LEXEXP
- K ARY M ARY=LEXPER
- S (LEXEF,LEXC)=0 F S LEXEF=$O(ARY(LEXEF)) Q:LEXEF'?7N S LEXC=LEXC+1
- S:+LEXC>0 ARY(0)=LEXC S:+LEXC'>0 ARY(0)="-1^No activation periods found for code"
- S:LEXSYS>0&($L($P($G(LEXSD),"^",3,5)))&(LEXC>0) ARY(0)=LEXC_U_LEXSYS_U_$P($G(LEXSD),"^",3,5)
- Q $G(ARY(0))
- VP(CODE,SYS,EFF) ; Variable Pointer ^ Description
- N LEXDES,LEXEF,LEXI,LEXR,LEXSO,LEXSYS,LEXVP
- S LEXSO=$G(CODE),LEXSYS=+($G(SYS))
- Q:'$L(LEXSO) "" Q:"^1^2^3^4^30^31^"'[("^"_LEXSYS_"^") ""
- S (LEXVP,LEXDES)="" S LEXEF=$G(EFF) S:LEXEF'?7N LEXEF=$$DT^XLFDT
- I LEXSYS=1!(LEXSYS=30) D
- . N LEXI,LEXR S LEXI=+($$CODEABA^ICDEX(LEXSO,80,LEXSYS)) Q:+LEXI'>0
- . S LEXR=$TR($$ROOT^ICDEX(80),"^","") Q:'$L(LEXR)
- . S LEXVP=LEXI_";"_LEXR
- . S LEXDES=$P($$ICDDX^ICDEX(LEXSO,(LEXEF+.001),LEXSYS,"E"),U,4)
- I LEXSYS=2!(LEXSYS=31) D
- . N LEXI,LEXR S LEXI=+($$CODEABA^ICDEX(LEXSO,80.1,LEXSYS)) Q:+LEXI'>0
- . S LEXR=$TR($$ROOT^ICDEX(80.1),"^","") Q:'$L(LEXR) S LEXVP=LEXI_";"_LEXR
- . S LEXDES=$P($$ICDOP^ICDEX(LEXSO,(LEXEF+.001),LEXSYS,"E"),U,5)
- I LEXSYS=3!(LEXSYS=4) D
- . N LEXI,LEXR S LEXI=$O(^ICPT("BA",(LEXSO_" "),0)) Q:+LEXI'>0
- . S LEXR="ICPT(",LEXVP=LEXI_";"_LEXR
- . S LEXDES=$P($$CPT^ICPTCOD(LEXSO,(LEXEF+.001)),U,3)
- Q:$L(LEXVP)&($L(LEXDES)) (LEXVP_"^"_LEXDES)
- Q ""
- PFI(FRAG,CDT,ARY) ; Get Procedure Fragment Info
- ;
- ; Input
- ;
- ; FRAG ICD-10-PCS Code Fragment
- ; CDT Versioning date (busines rules apply)
- ; .ARY Local Array passed by reference
- ;
- ; Output
- ;
- ; $$PFI 1 if successful
- ; -1 ^ Error Message if unsuccessful
- ; ARY
- ;
- ; ARY(0) 5 piece "^" delimited strig
- ; 1 Unique Id
- ; 2 Code Fragment
- ; 3 Date Entered
- ; 4 Source
- ; 5 Details
- ;
- ; ARY(1) 4 piece "^" delimited string
- ; 1 Effective Date
- ; 2 Status
- ; 3 Effective Date External
- ; 4 Status External
- ;
- ; ARY(2) Name/Title
- ; ARY(3) Description
- ; ARY(4) Explanation
- ; ARY(5,0) # of synonyms included
- ; ARY(5,n) included synonyms
- ;
- N LEXF,LEXI,LEXE,LEXC,LEXD,LEXN,X S LEXF=$G(FRAG) K ARY
- S LEXI=$$IMPDATE^LEXU(31) S LEXD=$G(CDT) S:'$L(LEXD) LEXD=$$DT^XLFDT
- S:LEXD?7N&(LEXI?7N)&(LEXD<LEXI) LEXD=LEXI
- Q:'$D(^LEX(757.033,"AFRAG",31,(LEXF_" "))) "-1^Invalid procedure code fragment"
- S LEXE=$O(^LEX(757.033,"AFRAG",31,(LEXF_" "),(LEXD+.001)),-1)
- Q:LEXE'?7N "-1^Fragment not active"
- S LEXN=$O(^LEX(757.033,"AFRAG",31,(LEXF_" "),+LEXE," "),-1)
- Q:+LEXN'>0 "-1^Fragment not found"
- K ARY S X=$$FIN^LEX10PR(LEXN,LEXD,.ARY)
- Q X
- SYSC(X) ; System from Code (must be unique)
- ;
- ; Input:
- ;
- ; X Classification Code (required)
- ;
- ; Output:
- ;
- ; $$SYSC Pointer to CODING SYSTEMS file 757.03
- ;
- ; or
- ;
- ; -1 ^ error message
- ;
- N LEXS,LEXSIEN,LEXSO S LEXSO=$G(X) Q:'$L(LEXSO) "-1^Code missing"
- Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) "-1^Invalid code missing"
- K LEXS S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
- . S LEXS(+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",3)))=""
- I $O(LEXS(0))>0,$O(LEXS(0))=$O(LEXS(" "),-1) S X=$O(LEXS(0)) Q X
- Q "-1^Unable to resolve coding system"
- 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
- LEXU4 ;ISL/KER - Miscellaneous Lexicon Utilities ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- +2 ;
- +3 ;
- +4 ; Global Variables
- +5 ; ^ICPT("BA"
- +6 ;
- +7 ; External References
- +8 ; $$CODEABA^ICDEX ICR 5747
- +9 ; $$ICDDX^ICDEX ICR 5747
- +10 ; $$ICDOP^ICDEX ICR 5747
- +11 ; $$ROOT^ICDEX ICR 5747
- +12 ; $$CPT^ICPTCOD ICR 1995
- +13 ; $$DT^XLFDT ICR 10103
- +14 ;
- HIST(CODE,SYS,ARY) ; Get Activation History for a Code
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; CODE ICD Code (required)
- +5 ; SYS Coding System
- +6 ; .ARY Array, passed by Reference (required)
- +7 ;
- +8 ; Output:
- +9 ;
- +10 ; $$HIST Number of Histories Found
- +11 ; or
- +12 ; -1 ^ error message
- +13 ;
- +14 ; ARY(0) = Number of Activation History
- +15 ; ARY(0,0) = Code ^ Source Abbreviation ^ Source Nomenclature
- +16 ; ARY(<date>,<status>) = Comment
- +17 ;
- +18 NEW LEXA,LEXC,LEXE,LEXI,LEXN,LEXNOM,LEXP,LEXS,LEXSAB,LEXSI,LEXSO,LEXSRC,LEXTD,X
- +19 SET LEXSO=$GET(CODE)
- KILL ARY
- IF '$LENGTH(LEXSO)
- QUIT "-1^Code missing"
- +20 IF '$DATA(^LEX(757.02,"ACT",(LEXSO_" ")))
- QUIT "-1^Invalid code missing"
- +21 SET LEXSAB=$GET(SYS)
- SET LEXSRC=+($$CSYS^LEXU(LEXSAB))
- +22 IF LEXSRC'>0
- SET LEXSRC=$$SYSC(LEXSO)
- IF +LEXSRC'>0
- QUIT "-1^Invalid source"
- +23 SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",2)
- +24 SET (LEXSI,LEXSAB)=$$CSYS^LEXU(+LEXSRC)
- +25 SET LEXSI=$PIECE(LEXSI,"^",3,4)
- +26 SET LEXSAB=$PIECE(LEXSAB,"^",2)
- IF $LENGTH(LEXSAB)'=3
- QUIT "-1^Invalid source"
- +27 SET LEXTD=$$DT^XLFDT
- FOR LEXI=0,1
- Begin DoDot:1
- +28 NEW LEXE
- SET LEXE=0
- +29 FOR
- SET LEXE=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE))
- IF +LEXE'>0
- QUIT
- Begin DoDot:2
- +30 NEW LEXS
- SET LEXS=0
- +31 FOR
- SET LEXS=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE,LEXS))
- IF +LEXS'>0
- QUIT
- Begin DoDot:3
- +32 NEW LEXN,LEXC
- SET LEXN=$GET(^LEX(757.02,LEXS,0))
- +33 SET LEXC=+($PIECE(LEXN,"^",3))
- IF +LEXC'=LEXSRC
- QUIT
- +34 IF '$DATA(ARY(LEXE,LEXI))
- SET ARY(0)=+($GET(ARY(0)))+1
- +35 SET ARY(LEXE,LEXI)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +36 SET LEXA=0
- SET LEXE=0
- FOR
- SET LEXE=$ORDER(ARY(LEXE))
- IF +LEXE'>0
- QUIT
- Begin DoDot:1
- +37 SET LEXS=""
- FOR
- SET LEXS=$ORDER(ARY(LEXE,LEXS))
- IF '$LENGTH(LEXS)
- QUIT
- Begin DoDot:2
- +38 IF +LEXS>0
- SET LEXA=1
- IF +LEXA'>0
- KILL ARY(LEXE,LEXS)
- End DoDot:2
- End DoDot:1
- +39 SET LEXA=0
- SET LEXE=0
- FOR
- SET LEXE=$ORDER(ARY(LEXE))
- IF +LEXE'>0
- QUIT
- Begin DoDot:1
- +40 SET LEXS=""
- FOR
- SET LEXS=$ORDER(ARY(LEXE,LEXS))
- IF '$LENGTH(LEXS)
- QUIT
- Begin DoDot:2
- +41 IF +LEXS>0
- SET LEXA=LEXA+1
- +42 IF +LEXS>0
- IF LEXA=1
- SET ARY(LEXE,LEXS)="Activated"
- QUIT
- +43 IF +LEXS'>0
- SET ARY(LEXE,LEXS)="Inactivated"
- QUIT
- +44 IF +LEXS>0
- Begin DoDot:3
- +45 SET ARY(LEXE,LEXS)="Re-activated"
- +46 IF $DATA(ARY(LEXE,0))
- Begin DoDot:4
- +47 SET ARY(LEXE,LEXS)="Revised"
- KILL ARY(LEXE,0)
- End DoDot:4
- QUIT
- +48 SET LEXP=$ORDER(ARY(LEXE),-1)
- IF +LEXP>0
- Begin DoDot:4
- +49 IF $ORDER(ARY(LEXE," "),-1)'>0
- SET ARY(LEXE,LEXS)="Re-Used"
- KILL ARY(LEXE,0)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +50 KILL ARY(0)
- SET LEXN=0
- SET LEXC=""
- FOR
- SET LEXC=$ORDER(ARY(LEXC))
- IF '$LENGTH(LEXC)
- QUIT
- Begin DoDot:1
- +51 SET LEXI=""
- FOR
- SET LEXI=$ORDER(ARY(LEXC,LEXI))
- IF '$LENGTH(LEXI)
- QUIT
- Begin DoDot:2
- +52 IF LEXI?1N
- IF LEXC?7N
- IF LEXC>LEXTD
- IF $LENGTH($GET(ARY(LEXC,LEXI)))
- Begin DoDot:3
- +53 SET ARY(LEXC,LEXI)=$GET(ARY(LEXC,LEXI))_" (Pending)"
- End DoDot:3
- +54 SET LEXN=LEXN+1
- End DoDot:2
- End DoDot:1
- +55 SET X=+($GET(LEXN))
- IF LEXN>0
- SET ARY(0)=+($GET(LEXN))
- IF X'>0
- SET X="-1^No History Found"
- +56 IF LEXN>0&($LENGTH(LEXSI))&($LENGTH(LEXSO))
- SET ARY(0,0)=LEXSO_"^"_LEXSI
- +57 QUIT X
- PERIOD(CODE,SYS,ARY) ; Get Activation/Inactivation Periods for a Code
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; CODE ICD Code (required)
- +5 ; SYS Coding System
- +6 ; .ARY Array, passed by Reference (required)
- +7 ;
- +8 ; Output:
- +9 ;
- +10 ; $$PERIOD Multiple piece "^" delimited string
- +11 ;
- +12 ; 1 Number of Activation Periods found
- +13 ; 2 Coding System (interal)
- +14 ; 3 Source Abbreviation
- +15 ; 4 Coding System Nomenclature
- +16 ; 5 Coding System Name
- +17 ;
- +18 ; or
- +19 ;
- +20 ; -1^ Message (no period or error message)
- +21 ;
- +22 ; ARY(0) Same as $$PERIOD (above)
- +23 ;
- +24 ; ARY(Activation Date) = 4 piece "^" delimited string
- +25 ;
- +26 ; 1 Inactivation Date
- +27 ; (conditional)
- +28 ;
- +29 ; 2 Pointer to Expression file 757.01
- +30 ; for the code in piece #2 above
- +31 ; (required)
- +32 ;
- +33 ; 3 Variable Pointer IEN;Root of a
- +34 ; national file (see below) Include
- +35 ; when the code exist in an national
- +36 ; file (conditional)
- +37 ;
- +38 ; CPT/HCPCS Procedure code IEN;ICPT(
- +39 ; ICD Diagnosis code IEN;ICD9(
- +40 ; ICD Procedure code IEN;ICD0(
- +41 ;
- +42 ; 4 Short Description from the SDO file
- +43 ; (CPT or ICD)
- +44 ;
- +45 ; ARY(Activation Date,0) = Lexicon Expression
- +46 ;
- +47 ; Functions like PERIOD^ICDAPIU, except it can include
- +48 ; any coding system in the Lexicon, not just ICD.
- +49 ;
- +50 NEW LEXACT,LEXD,LEXDT,LEXEF,LEXEXI,LEXEXP,LEXI,LEXIDT,LEXIEN
- +51 NEW LEXINA,LEXND,LEXPDT,LEXPER,LEXSD,LEXSO,LEXSY,LEXSYS,LEXVP
- +52 SET LEXSO=$GET(CODE)
- IF '$LENGTH(LEXSO)
- QUIT "-1^Missing Code"
- +53 IF '$DATA(^LEX(757.02,"CODE",(LEXSO_" ")))
- QUIT "-1^Invalid Code"
- +54 SET (LEXSD,LEXSYS)=$$CSYS^LEXU(SYS)
- SET LEXSYS=+LEXSYS
- +55 IF +LEXSYS'>0
- QUIT "-1^Missing/Invalid Coding System"
- +56 IF '$DATA(^LEX(757.03,+LEXSYS,0))
- QUIT "-1^Invalid Coding System"
- +57 KILL ARY,LEXACT,LEXINA
- +58 SET LEXDT=""
- FOR
- SET LEXDT=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT))
- IF '$LENGTH(LEXDT)
- QUIT
- Begin DoDot:1
- +59 NEW LEXIEN
- SET LEXIEN=0
- FOR
- SET LEXIEN=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT,LEXIEN))
- IF +LEXIEN'>0
- QUIT
- Begin DoDot:2
- +60 NEW LEXND,LEXSY,LEXEXI
- SET LEXND=$GET(^LEX(757.02,+LEXIEN,0))
- SET LEXSY=$PIECE(LEXND,"^",3)
- SET LEXEXI=+LEXND
- +61 IF LEXSY'=LEXSYS
- QUIT
- SET LEXACT(LEXDT)=LEXEXI
- End DoDot:2
- End DoDot:1
- +62 SET LEXDT=""
- FOR
- SET LEXDT=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT))
- IF '$LENGTH(LEXDT)
- QUIT
- Begin DoDot:1
- +63 NEW LEXIEN
- SET LEXIEN=0
- FOR
- SET LEXIEN=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT,LEXIEN))
- IF +LEXIEN'>0
- QUIT
- Begin DoDot:2
- +64 NEW LEXND,LEXSY,LEXEXI
- SET LEXND=$GET(^LEX(757.02,+LEXIEN,0))
- SET LEXSY=$PIECE(LEXND,"^",3)
- SET LEXEXI=+LEXND
- +65 IF LEXSY'=LEXSYS
- QUIT
- SET LEXINA(LEXDT)=LEXEXI
- End DoDot:2
- End DoDot:1
- +66 SET LEXDT=""
- FOR
- SET LEXDT=$ORDER(LEXACT(LEXDT))
- IF '$LENGTH(LEXDT)
- QUIT
- Begin DoDot:1
- +67 IF $DATA(LEXINA(LEXDT))
- Begin DoDot:2
- +68 NEW LEXEXI,LEXPDT
- +69 SET LEXEXI=$GET(LEXACT(LEXDT))
- SET LEXPDT=$ORDER(LEXACT(LEXDT),-1)
- +70 IF LEXPDT?7N&(LEXEXI>0)
- SET LEXACT(LEXPDT)=LEXEXI
- +71 KILL LEXACT(LEXDT),LEXINA(LEXDT)
- End DoDot:2
- End DoDot:1
- +72 SET LEXDT=""
- FOR
- SET LEXDT=$ORDER(LEXACT(LEXDT))
- IF '$LENGTH(LEXDT)
- QUIT
- Begin DoDot:1
- +73 NEW LEXIDT,LEXEXI,LEXEXP,LEXEF,LEXVP
- +74 ; Inactive Date
- +75 SET LEXIDT=$ORDER(LEXINA(LEXDT))
- +76 ; Lexicon Expression
- +77 SET LEXEXI=$GET(LEXACT(LEXDT))
- +78 IF LEXIDT?7N
- SET LEXEXI=$GET(LEXINA(LEXIDT))
- +79 SET LEXEXP=""
- IF +LEXEXI>0
- SET LEXEXP=$GET(^LEX(757.01,+LEXEXI,0))
- +80 ; Kill
- +81 IF LEXIDT?7N
- KILL LEXINA(LEXIDT)
- +82 ; Effective Date
- +83 SET LEXEF=$$DT^XLFDT
- IF LEXIDT?7N
- SET LEXEF=LEXIDT
- +84 ; Variable Pointer
- +85 SET LEXVP=$$VP(LEXSO,LEXSYS,LEXEF)
- +86 ; Set array
- +87 IF LEXIDT'?7N
- SET LEXIDT=""
- +88 SET LEXPER(LEXDT)=LEXIDT_"^"_LEXEXI_"^"_LEXVP
- +89 IF $LENGTH(LEXEXP)
- SET LEXPER(LEXDT,0)=LEXEXP
- End DoDot:1
- +90 KILL ARY
- MERGE ARY=LEXPER
- +91 SET (LEXEF,LEXC)=0
- FOR
- SET LEXEF=$ORDER(ARY(LEXEF))
- IF LEXEF'?7N
- QUIT
- SET LEXC=LEXC+1
- +92 IF +LEXC>0
- SET ARY(0)=LEXC
- IF +LEXC'>0
- SET ARY(0)="-1^No activation periods found for code"
- +93 IF LEXSYS>0&($LENGTH($PIECE($GET(LEXSD),"^",3,5)))&(LEXC>0)
- SET ARY(0)=LEXC_U_LEXSYS_U_$PIECE($GET(LEXSD),"^",3,5)
- +94 QUIT $GET(ARY(0))
- VP(CODE,SYS,EFF) ; Variable Pointer ^ Description
- +1 NEW LEXDES,LEXEF,LEXI,LEXR,LEXSO,LEXSYS,LEXVP
- +2 SET LEXSO=$GET(CODE)
- SET LEXSYS=+($GET(SYS))
- +3 IF '$LENGTH(LEXSO)
- QUIT ""
- IF "^1^2^3^4^30^31^"'[("^"_LEXSYS_"^")
- QUIT ""
- +4 SET (LEXVP,LEXDES)=""
- SET LEXEF=$GET(EFF)
- IF LEXEF'?7N
- SET LEXEF=$$DT^XLFDT
- +5 IF LEXSYS=1!(LEXSYS=30)
- Begin DoDot:1
- +6 NEW LEXI,LEXR
- SET LEXI=+($$CODEABA^ICDEX(LEXSO,80,LEXSYS))
- IF +LEXI'>0
- QUIT
- +7 SET LEXR=$TRANSLATE($$ROOT^ICDEX(80),"^","")
- IF '$LENGTH(LEXR)
- QUIT
- +8 SET LEXVP=LEXI_";"_LEXR
- +9 SET LEXDES=$PIECE($$ICDDX^ICDEX(LEXSO,(LEXEF+.001),LEXSYS,"E"),U,4)
- End DoDot:1
- +10 IF LEXSYS=2!(LEXSYS=31)
- Begin DoDot:1
- +11 NEW LEXI,LEXR
- SET LEXI=+($$CODEABA^ICDEX(LEXSO,80.1,LEXSYS))
- IF +LEXI'>0
- QUIT
- +12 SET LEXR=$TRANSLATE($$ROOT^ICDEX(80.1),"^","")
- IF '$LENGTH(LEXR)
- QUIT
- SET LEXVP=LEXI_";"_LEXR
- +13 SET LEXDES=$PIECE($$ICDOP^ICDEX(LEXSO,(LEXEF+.001),LEXSYS,"E"),U,5)
- End DoDot:1
- +14 IF LEXSYS=3!(LEXSYS=4)
- Begin DoDot:1
- +15 NEW LEXI,LEXR
- SET LEXI=$ORDER(^ICPT("BA",(LEXSO_" "),0))
- IF +LEXI'>0
- QUIT
- +16 SET LEXR="ICPT("
- SET LEXVP=LEXI_";"_LEXR
- +17 SET LEXDES=$PIECE($$CPT^ICPTCOD(LEXSO,(LEXEF+.001)),U,3)
- End DoDot:1
- +18 IF $LENGTH(LEXVP)&($LENGTH(LEXDES))
- QUIT (LEXVP_"^"_LEXDES)
- +19 QUIT ""
- PFI(FRAG,CDT,ARY) ; Get Procedure Fragment Info
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; FRAG ICD-10-PCS Code Fragment
- +5 ; CDT Versioning date (busines rules apply)
- +6 ; .ARY Local Array passed by reference
- +7 ;
- +8 ; Output
- +9 ;
- +10 ; $$PFI 1 if successful
- +11 ; -1 ^ Error Message if unsuccessful
- +12 ; ARY
- +13 ;
- +14 ; ARY(0) 5 piece "^" delimited strig
- +15 ; 1 Unique Id
- +16 ; 2 Code Fragment
- +17 ; 3 Date Entered
- +18 ; 4 Source
- +19 ; 5 Details
- +20 ;
- +21 ; ARY(1) 4 piece "^" delimited string
- +22 ; 1 Effective Date
- +23 ; 2 Status
- +24 ; 3 Effective Date External
- +25 ; 4 Status External
- +26 ;
- +27 ; ARY(2) Name/Title
- +28 ; ARY(3) Description
- +29 ; ARY(4) Explanation
- +30 ; ARY(5,0) # of synonyms included
- +31 ; ARY(5,n) included synonyms
- +32 ;
- +33 NEW LEXF,LEXI,LEXE,LEXC,LEXD,LEXN,X
- SET LEXF=$GET(FRAG)
- KILL ARY
- +34 SET LEXI=$$IMPDATE^LEXU(31)
- SET LEXD=$GET(CDT)
- IF '$LENGTH(LEXD)
- SET LEXD=$$DT^XLFDT
- +35 IF LEXD?7N&(LEXI?7N)&(LEXD<LEXI)
- SET LEXD=LEXI
- +36 IF '$DATA(^LEX(757.033,"AFRAG",31,(LEXF_" ")))
- QUIT "-1^Invalid procedure code fragment"
- +37 SET LEXE=$ORDER(^LEX(757.033,"AFRAG",31,(LEXF_" "),(LEXD+.001)),-1)
- +38 IF LEXE'?7N
- QUIT "-1^Fragment not active"
- +39 SET LEXN=$ORDER(^LEX(757.033,"AFRAG",31,(LEXF_" "),+LEXE," "),-1)
- +40 IF +LEXN'>0
- QUIT "-1^Fragment not found"
- +41 KILL ARY
- SET X=$$FIN^LEX10PR(LEXN,LEXD,.ARY)
- +42 QUIT X
- SYSC(X) ; System from Code (must be unique)
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; X Classification Code (required)
- +5 ;
- +6 ; Output:
- +7 ;
- +8 ; $$SYSC Pointer to CODING SYSTEMS file 757.03
- +9 ;
- +10 ; or
- +11 ;
- +12 ; -1 ^ error message
- +13 ;
- +14 NEW LEXS,LEXSIEN,LEXSO
- SET LEXSO=$GET(X)
- IF '$LENGTH(LEXSO)
- QUIT "-1^Code missing"
- +15 IF '$DATA(^LEX(757.02,"CODE",(LEXSO_" ")))
- QUIT "-1^Invalid code missing"
- +16 KILL LEXS
- SET LEXSIEN=0
- FOR
- SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
- IF +LEXSIEN'>0
- QUIT
- Begin DoDot:1
- +17 SET LEXS(+($PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",3)))=""
- End DoDot:1
- +18 IF $ORDER(LEXS(0))>0
- IF $ORDER(LEXS(0))=$ORDER(LEXS(" "),-1)
- SET X=$ORDER(LEXS(0))
- QUIT X
- +19 QUIT "-1^Unable to resolve coding system"
- 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
