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
