LEXU4 ;ISL/KER - Miscellaneous Lexicon Utilities ;12/19/2014
;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
;
;
; 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
; $$FMDIFF^XLFDT ICR 10103
; $$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,LEXC,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"
Q:+($$CODSAB^LEXU2(LEXSO,LEXSYS))'>0 "-1^Invalid source for code"
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 ""
REUSE(X,SYS) ; Is a code "re-used"
;
; Input
;
; X Code
; SYS Coding System
;
; Output
;
; $$REUSE 2 Piece "^" delimited string
; 1 Boolean flag
; 1 if the code was reused
; 0 if the code has not been reused
; 2 If reused, the date it was reused
;
N LEXA,LEXAC,LEXEF,LEXH,LEXHARY,LEXI,LEXRU,LEXSO,LEXSRC,LEXSYS,LEXTD,LEXREU,LEXRD
S (LEXA,LEXI)=0,LEXTD=$G(DT) S:LEXTD'?7N LEXTD=$$DT^XLFDT S LEXSO=$G(X),LEXSYS=$G(SYS)
S LEXSRC=+($$CSYS^LEXU(LEXSYS)),LEXH=$$ACT($G(LEXSO),$G(LEXSYS),.LEXHARY) K LEXHARY(0,0),LEXHARY(0)
S LEXREU=0,(LEXRD,LEXD)=" " F S LEXD=$O(LEXHARY(LEXD),-1) Q:'$L(LEXD) D Q:LEXREU>0
. N LEXS,LEXE,LEXPD,LEXPS,LEXPE,LEXDIF
. S LEXS=$O(LEXHARY(+LEXD," "),-1),LEXE=$G(LEXHARY(+LEXD,+LEXS))
. S LEXPD=$O(LEXHARY(LEXD),-1),LEXPS=$O(LEXHARY(+LEXPD," "),-1)
. S LEXPE=$G(LEXHARY(+LEXPD,+LEXPS))
. Q:LEXS'?1N Q:LEXD'?7N Q:LEXPS'?1N Q:LEXPD'?7N
. S LEXDIF=$$FMDIFF^XLFDT(LEXD,LEXPD,1) Q:LEXDIF'>10
. I LEXS=1,LEXPS=0,LEXD'=LEXPD,LEXE'=LEXPE S LEXREU=1,LEXRD=LEXD
S X=LEXREU S:+X>0&(LEXRD?7N) $P(X,"^",2)=LEXRD
Q X
REVISE(X,SYS) ; Is a code "revised"
;
; Input
;
; X Code
; SYS Coding System
;
; $$REVISE 2 Piece "^" delimited string
; 1 Boolean flag
; 1 if the code was reused
; 0 if the code has not been reused
; 2 If reused, the date it was reused
;
N LEXA,LEXAC,LEXEF,LEXH,LEXHARY,LEXI,LEXRU,LEXSO,LEXSRC,LEXSYS,LEXTD,LEXREV,LEXRD
S (LEXA,LEXI)=0,LEXTD=$G(DT) S:LEXTD'?7N LEXTD=$$DT^XLFDT S LEXSO=$G(X),LEXSYS=$G(SYS)
S LEXSRC=+($$CSYS^LEXU(LEXSYS)),LEXH=$$ACT($G(LEXSO),$G(LEXSYS),.LEXHARY) K LEXHARY(0,0),LEXHARY(0)
S LEXREV=0,(LEXRD,LEXD)=" " F S LEXD=$O(LEXHARY(LEXD),-1) Q:'$L(LEXD) D Q:LEXREV>0
. N LEXS,LEXE,LEXPD,LEXPS,LEXPE,LEXDIF
. S LEXS=$O(LEXHARY(+LEXD," "),-1),LEXE=$G(LEXHARY(+LEXD,+LEXS))
. S LEXPD=$O(LEXHARY(LEXD),-1),LEXPS=$O(LEXHARY(+LEXPD," "),-1)
. S LEXPE=$G(LEXHARY(+LEXPD,+LEXPS))
. Q:LEXS'?1N Q:LEXD'?7N Q:LEXPS'?1N Q:LEXPD'?7N
. I LEXPS=LEXS,LEXPD'=LEXD,LEXPE'=LEXE S LEXREV=1,LEXRD=LEXD
S X=LEXREV S:+X>0&(LEXRD?7N) $P(X,"^",2)=LEXRD
Q X
LAST(X,SYS,CDT) ; Last Activation ^ Inactivation
;
; Input
;
; X Code
; SYS Coding System
; CDT Versioning Date
;
; $$LAST 2 Piece "^" delimited string
; 1 Last Activation Date
; 2 Last Inactivation Date
;
; or -1 on error/no dates found
;
N LEXARY,LEXDT,LEXLA,LEXLI,LEXO,LEXSO,LEXT,LEXTD S LEXTD=$$DT^XLFDT,LEXDT=$G(CDT) S:LEXDT'?7N LEXDT=LEXTD
S LEXSO=$G(X) S X=$$PERIOD^LEXU4($G(LEXSO),$G(SYS),.LEXARY) Q:+($G(LEXARY(0)))'>0 -1
S (LEXLA,LEXLI)="",LEXO=0 F S LEXO=$O(LEXARY(LEXO)) Q:+LEXO'>0 D
. N LEXT S LEXT=$P($G(LEXARY(LEXO)),"^",1)
. I LEXO?7N,LEXO'>LEXDT S LEXLA=LEXO
. I LEXT?7N,LEXT'>LEXDT S:+LEXT>+LEXLI LEXLI=LEXT
Q:+LEXLA'>0 -1 S X=LEXLA S:LEXLI>0 X=X_"^"_LEXLI
Q X
ACT(CODE,SYS,ARY) ; Get Activations
N LEXA,LEXC,LEXE,LEXI,LEXN,LEXNOM,LEXP,LEXS,LEXSAB,LEXSI,LEXSO,LEXSRC,LEXTD,X S X=0
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,LEXSTA S LEXE=0,LEXSTA=LEXI
. 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,LEXSTA)) ARY(0)=+($G(ARY(0)))+1
. . . S ARY(LEXE,LEXSTA)=+LEXN
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
. . K:+LEXS>0 ARY(LEXE,0)
S LEXE=0 F S LEXE=$O(ARY(LEXE)) Q:+LEXE'>0 D
. N LEXS S LEXS="" F S LEXS=$O(ARY(LEXE,LEXS)) Q:'$L(LEXS) S X=X+1
Q X
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXU4 14682 printed Sep 23, 2025@19:45:45 Page 2
LEXU4 ;ISL/KER - Miscellaneous Lexicon Utilities ;12/19/2014
+1 ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
+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 ; $$FMDIFF^XLFDT ICR 10103
+14 ; $$DT^XLFDT ICR 10103
+15 ;
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,LEXC,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 if +($$CODSAB^LEXU2(LEXSO,LEXSYS))'>0
QUIT "-1^Invalid source for code"
+58 KILL ARY,LEXACT,LEXINA
+59 SET LEXDT=""
FOR
SET LEXDT=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT))
if '$LENGTH(LEXDT)
QUIT
Begin DoDot:1
+60 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+61 NEW LEXND,LEXSY,LEXEXI
SET LEXND=$GET(^LEX(757.02,+LEXIEN,0))
SET LEXSY=$PIECE(LEXND,"^",3)
SET LEXEXI=+LEXND
+62 if LEXSY'=LEXSYS
QUIT
SET LEXACT(LEXDT)=LEXEXI
End DoDot:2
End DoDot:1
+63 SET LEXDT=""
FOR
SET LEXDT=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT))
if '$LENGTH(LEXDT)
QUIT
Begin DoDot:1
+64 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+65 NEW LEXND,LEXSY,LEXEXI
SET LEXND=$GET(^LEX(757.02,+LEXIEN,0))
SET LEXSY=$PIECE(LEXND,"^",3)
SET LEXEXI=+LEXND
+66 if LEXSY'=LEXSYS
QUIT
SET LEXINA(LEXDT)=LEXEXI
End DoDot:2
End DoDot:1
+67 SET LEXDT=""
FOR
SET LEXDT=$ORDER(LEXACT(LEXDT))
if '$LENGTH(LEXDT)
QUIT
Begin DoDot:1
+68 IF $DATA(LEXINA(LEXDT))
Begin DoDot:2
+69 NEW LEXEXI,LEXPDT
+70 SET LEXEXI=$GET(LEXACT(LEXDT))
SET LEXPDT=$ORDER(LEXACT(LEXDT),-1)
+71 if LEXPDT?7N&(LEXEXI>0)
SET LEXACT(LEXPDT)=LEXEXI
+72 KILL LEXACT(LEXDT),LEXINA(LEXDT)
End DoDot:2
End DoDot:1
+73 SET LEXDT=""
FOR
SET LEXDT=$ORDER(LEXACT(LEXDT))
if '$LENGTH(LEXDT)
QUIT
Begin DoDot:1
+74 NEW LEXIDT,LEXEXI,LEXEXP,LEXEF,LEXVP
+75 ; Inactive Date
+76 SET LEXIDT=$ORDER(LEXINA(LEXDT))
+77 ; Lexicon Expression
+78 SET LEXEXI=$GET(LEXACT(LEXDT))
+79 if LEXIDT?7N
SET LEXEXI=$GET(LEXINA(LEXIDT))
+80 SET LEXEXP=""
if +LEXEXI>0
SET LEXEXP=$GET(^LEX(757.01,+LEXEXI,0))
+81 ; Kill
+82 if LEXIDT?7N
KILL LEXINA(LEXIDT)
+83 ; Effective Date
+84 SET LEXEF=$$DT^XLFDT
if LEXIDT?7N
SET LEXEF=LEXIDT
+85 ; Variable Pointer
+86 SET LEXVP=$$VP(LEXSO,LEXSYS,LEXEF)
+87 ; Set array
+88 if LEXIDT'?7N
SET LEXIDT=""
+89 SET LEXPER(LEXDT)=LEXIDT_"^"_LEXEXI_"^"_LEXVP
+90 if $LENGTH(LEXEXP)
SET LEXPER(LEXDT,0)=LEXEXP
End DoDot:1
+91 KILL ARY
MERGE ARY=LEXPER
+92 SET (LEXEF,LEXC)=0
FOR
SET LEXEF=$ORDER(ARY(LEXEF))
if LEXEF'?7N
QUIT
SET LEXC=LEXC+1
+93 if +LEXC>0
SET ARY(0)=LEXC
if +LEXC'>0
SET ARY(0)="-1^No activation periods found for code"
+94 if LEXSYS>0&($LENGTH($PIECE($GET(LEXSD),"^",3,5)))&(LEXC>0)
SET ARY(0)=LEXC_U_LEXSYS_U_$PIECE($GET(LEXSD),"^",3,5)
+95 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 ""
REUSE(X,SYS) ; Is a code "re-used"
+1 ;
+2 ; Input
+3 ;
+4 ; X Code
+5 ; SYS Coding System
+6 ;
+7 ; Output
+8 ;
+9 ; $$REUSE 2 Piece "^" delimited string
+10 ; 1 Boolean flag
+11 ; 1 if the code was reused
+12 ; 0 if the code has not been reused
+13 ; 2 If reused, the date it was reused
+14 ;
+15 NEW LEXA,LEXAC,LEXEF,LEXH,LEXHARY,LEXI,LEXRU,LEXSO,LEXSRC,LEXSYS,LEXTD,LEXREU,LEXRD
+16 SET (LEXA,LEXI)=0
SET LEXTD=$GET(DT)
if LEXTD'?7N
SET LEXTD=$$DT^XLFDT
SET LEXSO=$GET(X)
SET LEXSYS=$GET(SYS)
+17 SET LEXSRC=+($$CSYS^LEXU(LEXSYS))
SET LEXH=$$ACT($GET(LEXSO),$GET(LEXSYS),.LEXHARY)
KILL LEXHARY(0,0),LEXHARY(0)
+18 SET LEXREU=0
SET (LEXRD,LEXD)=" "
FOR
SET LEXD=$ORDER(LEXHARY(LEXD),-1)
if '$LENGTH(LEXD)
QUIT
Begin DoDot:1
+19 NEW LEXS,LEXE,LEXPD,LEXPS,LEXPE,LEXDIF
+20 SET LEXS=$ORDER(LEXHARY(+LEXD," "),-1)
SET LEXE=$GET(LEXHARY(+LEXD,+LEXS))
+21 SET LEXPD=$ORDER(LEXHARY(LEXD),-1)
SET LEXPS=$ORDER(LEXHARY(+LEXPD," "),-1)
+22 SET LEXPE=$GET(LEXHARY(+LEXPD,+LEXPS))
+23 if LEXS'?1N
QUIT
if LEXD'?7N
QUIT
if LEXPS'?1N
QUIT
if LEXPD'?7N
QUIT
+24 SET LEXDIF=$$FMDIFF^XLFDT(LEXD,LEXPD,1)
if LEXDIF'>10
QUIT
+25 IF LEXS=1
IF LEXPS=0
IF LEXD'=LEXPD
IF LEXE'=LEXPE
SET LEXREU=1
SET LEXRD=LEXD
End DoDot:1
if LEXREU>0
QUIT
+26 SET X=LEXREU
if +X>0&(LEXRD?7N)
SET $PIECE(X,"^",2)=LEXRD
+27 QUIT X
REVISE(X,SYS) ; Is a code "revised"
+1 ;
+2 ; Input
+3 ;
+4 ; X Code
+5 ; SYS Coding System
+6 ;
+7 ; $$REVISE 2 Piece "^" delimited string
+8 ; 1 Boolean flag
+9 ; 1 if the code was reused
+10 ; 0 if the code has not been reused
+11 ; 2 If reused, the date it was reused
+12 ;
+13 NEW LEXA,LEXAC,LEXEF,LEXH,LEXHARY,LEXI,LEXRU,LEXSO,LEXSRC,LEXSYS,LEXTD,LEXREV,LEXRD
+14 SET (LEXA,LEXI)=0
SET LEXTD=$GET(DT)
if LEXTD'?7N
SET LEXTD=$$DT^XLFDT
SET LEXSO=$GET(X)
SET LEXSYS=$GET(SYS)
+15 SET LEXSRC=+($$CSYS^LEXU(LEXSYS))
SET LEXH=$$ACT($GET(LEXSO),$GET(LEXSYS),.LEXHARY)
KILL LEXHARY(0,0),LEXHARY(0)
+16 SET LEXREV=0
SET (LEXRD,LEXD)=" "
FOR
SET LEXD=$ORDER(LEXHARY(LEXD),-1)
if '$LENGTH(LEXD)
QUIT
Begin DoDot:1
+17 NEW LEXS,LEXE,LEXPD,LEXPS,LEXPE,LEXDIF
+18 SET LEXS=$ORDER(LEXHARY(+LEXD," "),-1)
SET LEXE=$GET(LEXHARY(+LEXD,+LEXS))
+19 SET LEXPD=$ORDER(LEXHARY(LEXD),-1)
SET LEXPS=$ORDER(LEXHARY(+LEXPD," "),-1)
+20 SET LEXPE=$GET(LEXHARY(+LEXPD,+LEXPS))
+21 if LEXS'?1N
QUIT
if LEXD'?7N
QUIT
if LEXPS'?1N
QUIT
if LEXPD'?7N
QUIT
+22 IF LEXPS=LEXS
IF LEXPD'=LEXD
IF LEXPE'=LEXE
SET LEXREV=1
SET LEXRD=LEXD
End DoDot:1
if LEXREV>0
QUIT
+23 SET X=LEXREV
if +X>0&(LEXRD?7N)
SET $PIECE(X,"^",2)=LEXRD
+24 QUIT X
LAST(X,SYS,CDT) ; Last Activation ^ Inactivation
+1 ;
+2 ; Input
+3 ;
+4 ; X Code
+5 ; SYS Coding System
+6 ; CDT Versioning Date
+7 ;
+8 ; $$LAST 2 Piece "^" delimited string
+9 ; 1 Last Activation Date
+10 ; 2 Last Inactivation Date
+11 ;
+12 ; or -1 on error/no dates found
+13 ;
+14 NEW LEXARY,LEXDT,LEXLA,LEXLI,LEXO,LEXSO,LEXT,LEXTD
SET LEXTD=$$DT^XLFDT
SET LEXDT=$GET(CDT)
if LEXDT'?7N
SET LEXDT=LEXTD
+15 SET LEXSO=$GET(X)
SET X=$$PERIOD^LEXU4($GET(LEXSO),$GET(SYS),.LEXARY)
if +($GET(LEXARY(0)))'>0
QUIT -1
+16 SET (LEXLA,LEXLI)=""
SET LEXO=0
FOR
SET LEXO=$ORDER(LEXARY(LEXO))
if +LEXO'>0
QUIT
Begin DoDot:1
+17 NEW LEXT
SET LEXT=$PIECE($GET(LEXARY(LEXO)),"^",1)
+18 IF LEXO?7N
IF LEXO'>LEXDT
SET LEXLA=LEXO
+19 IF LEXT?7N
IF LEXT'>LEXDT
if +LEXT>+LEXLI
SET LEXLI=LEXT
End DoDot:1
+20 if +LEXLA'>0
QUIT -1
SET X=LEXLA
if LEXLI>0
SET X=X_"^"_LEXLI
+21 QUIT X
ACT(CODE,SYS,ARY) ; Get Activations
+1 NEW LEXA,LEXC,LEXE,LEXI,LEXN,LEXNOM,LEXP,LEXS,LEXSAB,LEXSI,LEXSO,LEXSRC,LEXTD,X
SET X=0
+2 SET LEXSO=$GET(CODE)
KILL ARY
if '$LENGTH(LEXSO)
QUIT "-1^Code missing"
+3 if '$DATA(^LEX(757.02,"ACT",(LEXSO_" ")))
QUIT "-1^Invalid code missing"
+4 SET LEXSAB=$GET(SYS)
SET LEXSRC=+($$CSYS^LEXU(LEXSAB))
+5 if LEXSRC'>0
SET LEXSRC=$$SYSC(LEXSO)
if +LEXSRC'>0
QUIT "-1^Invalid source"
+6 SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",2)
+7 SET (LEXSI,LEXSAB)=$$CSYS^LEXU(+LEXSRC)
+8 SET LEXSI=$PIECE(LEXSI,"^",3,4)
+9 SET LEXSAB=$PIECE(LEXSAB,"^",2)
if $LENGTH(LEXSAB)'=3
QUIT "-1^Invalid source"
+10 SET LEXTD=$$DT^XLFDT
FOR LEXI=0,1
Begin DoDot:1
+11 NEW LEXE,LEXSTA
SET LEXE=0
SET LEXSTA=LEXI
+12 FOR
SET LEXE=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE))
if +LEXE'>0
QUIT
Begin DoDot:2
+13 NEW LEXS
SET LEXS=0
+14 FOR
SET LEXS=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE,LEXS))
if +LEXS'>0
QUIT
Begin DoDot:3
+15 NEW LEXN,LEXC
SET LEXN=$GET(^LEX(757.02,LEXS,0))
+16 SET LEXC=+($PIECE(LEXN,"^",3))
if +LEXC'=LEXSRC
QUIT
+17 if '$DATA(ARY(LEXE,LEXSTA))
SET ARY(0)=+($GET(ARY(0)))+1
+18 SET ARY(LEXE,LEXSTA)=+LEXN
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET LEXA=0
SET LEXE=0
FOR
SET LEXE=$ORDER(ARY(LEXE))
if +LEXE'>0
QUIT
Begin DoDot:1
+20 SET LEXS=""
FOR
SET LEXS=$ORDER(ARY(LEXE,LEXS))
if '$LENGTH(LEXS)
QUIT
Begin DoDot:2
+21 if +LEXS>0
KILL ARY(LEXE,0)
End DoDot:2
End DoDot:1
+22 SET LEXE=0
FOR
SET LEXE=$ORDER(ARY(LEXE))
if +LEXE'>0
QUIT
Begin DoDot:1
+23 NEW LEXS
SET LEXS=""
FOR
SET LEXS=$ORDER(ARY(LEXE,LEXS))
if '$LENGTH(LEXS)
QUIT
SET X=X+1
End DoDot:1
+24 QUIT X
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
