- 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 Feb 18, 2025@23:35:56 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