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

LEXU4.m

Go to the documentation of this file.
  1. LEXU4 ;ISL/KER - Miscellaneous Lexicon Utilities ;12/19/2014
  1. ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
  1. ;
  1. ;
  1. ; Global Variables
  1. ; ^ICPT("BA"
  1. ;
  1. ; External References
  1. ; $$CODEABA^ICDEX ICR 5747
  1. ; $$ICDDX^ICDEX ICR 5747
  1. ; $$ICDOP^ICDEX ICR 5747
  1. ; $$ROOT^ICDEX ICR 5747
  1. ; $$CPT^ICPTCOD ICR 1995
  1. ; $$FMDIFF^XLFDT ICR 10103
  1. ; $$DT^XLFDT ICR 10103
  1. ;
  1. HIST(CODE,SYS,ARY) ; Get Activation History for a Code
  1. ;
  1. ; Input:
  1. ;
  1. ; CODE ICD Code (required)
  1. ; SYS Coding System
  1. ; .ARY Array, passed by Reference (required)
  1. ;
  1. ; Output:
  1. ;
  1. ; $$HIST Number of Histories Found
  1. ; or
  1. ; -1 ^ error message
  1. ;
  1. ; ARY(0) = Number of Activation History
  1. ; ARY(0,0) = Code ^ Source Abbreviation ^ Source Nomenclature
  1. ; ARY(<date>,<status>) = Comment
  1. ;
  1. N LEXA,LEXC,LEXE,LEXI,LEXN,LEXNOM,LEXP,LEXS,LEXSAB,LEXSI,LEXSO,LEXSRC,LEXTD,X
  1. S LEXSO=$G(CODE) K ARY Q:'$L(LEXSO) "-1^Code missing"
  1. Q:'$D(^LEX(757.02,"ACT",(LEXSO_" "))) "-1^Invalid code missing"
  1. S LEXSAB=$G(SYS),LEXSRC=+($$CSYS^LEXU(LEXSAB))
  1. S:LEXSRC'>0 LEXSRC=$$SYSC(LEXSO) Q:+LEXSRC'>0 "-1^Invalid source"
  1. S LEXNOM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2)
  1. S (LEXSI,LEXSAB)=$$CSYS^LEXU(+LEXSRC)
  1. S LEXSI=$P(LEXSI,"^",3,4)
  1. S LEXSAB=$P(LEXSAB,"^",2) Q:$L(LEXSAB)'=3 "-1^Invalid source"
  1. S LEXTD=$$DT^XLFDT F LEXI=0,1 D
  1. . N LEXE S LEXE=0
  1. . F S LEXE=$O(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE)) Q:+LEXE'>0 D
  1. . . N LEXS S LEXS=0
  1. . . F S LEXS=$O(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE,LEXS)) Q:+LEXS'>0 D
  1. . . . N LEXN,LEXC S LEXN=$G(^LEX(757.02,LEXS,0))
  1. . . . S LEXC=+($P(LEXN,"^",3)) Q:+LEXC'=LEXSRC
  1. . . . S:'$D(ARY(LEXE,LEXI)) ARY(0)=+($G(ARY(0)))+1
  1. . . . S ARY(LEXE,LEXI)=""
  1. S LEXA=0,LEXE=0 F S LEXE=$O(ARY(LEXE)) Q:+LEXE'>0 D
  1. . S LEXS="" F S LEXS=$O(ARY(LEXE,LEXS)) Q:'$L(LEXS) D
  1. . . S:+LEXS>0 LEXA=1 K:+LEXA'>0 ARY(LEXE,LEXS)
  1. S LEXA=0,LEXE=0 F S LEXE=$O(ARY(LEXE)) Q:+LEXE'>0 D
  1. . S LEXS="" F S LEXS=$O(ARY(LEXE,LEXS)) Q:'$L(LEXS) D
  1. . . S:+LEXS>0 LEXA=LEXA+1
  1. . . I +LEXS>0,LEXA=1 S ARY(LEXE,LEXS)="Activated" Q
  1. . . I +LEXS'>0 S ARY(LEXE,LEXS)="Inactivated" Q
  1. . . I +LEXS>0 D
  1. . . . S ARY(LEXE,LEXS)="Re-activated"
  1. . . . I $D(ARY(LEXE,0)) D Q
  1. . . . . S ARY(LEXE,LEXS)="Revised" K ARY(LEXE,0)
  1. . . . S LEXP=$O(ARY(LEXE),-1) I +LEXP>0 D
  1. . . . . I $O(ARY(LEXE," "),-1)'>0 S ARY(LEXE,LEXS)="Re-Used" K ARY(LEXE,0)
  1. K ARY(0) S LEXN=0,LEXC="" F S LEXC=$O(ARY(LEXC)) Q:'$L(LEXC) D
  1. . S LEXI="" F S LEXI=$O(ARY(LEXC,LEXI)) Q:'$L(LEXI) D
  1. . . I LEXI?1N,LEXC?7N,LEXC>LEXTD,$L($G(ARY(LEXC,LEXI))) D
  1. . . . S ARY(LEXC,LEXI)=$G(ARY(LEXC,LEXI))_" (Pending)"
  1. . . S LEXN=LEXN+1
  1. S X=+($G(LEXN)) S:LEXN>0 ARY(0)=+($G(LEXN)) S:X'>0 X="-1^No History Found"
  1. S:LEXN>0&($L(LEXSI))&($L(LEXSO)) ARY(0,0)=LEXSO_"^"_LEXSI
  1. Q X
  1. PERIOD(CODE,SYS,ARY) ; Get Activation/Inactivation Periods for a Code
  1. ;
  1. ; Input:
  1. ;
  1. ; CODE ICD Code (required)
  1. ; SYS Coding System
  1. ; .ARY Array, passed by Reference (required)
  1. ;
  1. ; Output:
  1. ;
  1. ; $$PERIOD Multiple piece "^" delimited string
  1. ;
  1. ; 1 Number of Activation Periods found
  1. ; 2 Coding System (interal)
  1. ; 3 Source Abbreviation
  1. ; 4 Coding System Nomenclature
  1. ; 5 Coding System Name
  1. ;
  1. ; or
  1. ;
  1. ; -1^ Message (no period or error message)
  1. ;
  1. ; ARY(0) Same as $$PERIOD (above)
  1. ;
  1. ; ARY(Activation Date) = 4 piece "^" delimited string
  1. ;
  1. ; 1 Inactivation Date
  1. ; (conditional)
  1. ;
  1. ; 2 Pointer to Expression file 757.01
  1. ; for the code in piece #2 above
  1. ; (required)
  1. ;
  1. ; 3 Variable Pointer IEN;Root of a
  1. ; national file (see below) Include
  1. ; when the code exist in an national
  1. ; file (conditional)
  1. ;
  1. ; CPT/HCPCS Procedure code IEN;ICPT(
  1. ; ICD Diagnosis code IEN;ICD9(
  1. ; ICD Procedure code IEN;ICD0(
  1. ;
  1. ; 4 Short Description from the SDO file
  1. ; (CPT or ICD)
  1. ;
  1. ; ARY(Activation Date,0) = Lexicon Expression
  1. ;
  1. ; Functions like PERIOD^ICDAPIU, except it can include
  1. ; any coding system in the Lexicon, not just ICD.
  1. ;
  1. N LEXACT,LEXC,LEXD,LEXDT,LEXEF,LEXEXI,LEXEXP,LEXI,LEXIDT,LEXIEN
  1. N LEXINA,LEXND,LEXPDT,LEXPER,LEXSD,LEXSO,LEXSY,LEXSYS,LEXVP
  1. S LEXSO=$G(CODE) Q:'$L(LEXSO) "-1^Missing Code"
  1. Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) "-1^Invalid Code"
  1. S (LEXSD,LEXSYS)=$$CSYS^LEXU(SYS),LEXSYS=+LEXSYS
  1. Q:+LEXSYS'>0 "-1^Missing/Invalid Coding System"
  1. Q:'$D(^LEX(757.03,+LEXSYS,0)) "-1^Invalid Coding System"
  1. Q:+($$CODSAB^LEXU2(LEXSO,LEXSYS))'>0 "-1^Invalid source for code"
  1. K ARY,LEXACT,LEXINA
  1. S LEXDT="" F S LEXDT=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT)) Q:'$L(LEXDT) D
  1. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXDT,LEXIEN)) Q:+LEXIEN'>0 D
  1. . . N LEXND,LEXSY,LEXEXI S LEXND=$G(^LEX(757.02,+LEXIEN,0)),LEXSY=$P(LEXND,"^",3),LEXEXI=+LEXND
  1. . . Q:LEXSY'=LEXSYS S LEXACT(LEXDT)=LEXEXI
  1. S LEXDT="" F S LEXDT=$O(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT)) Q:'$L(LEXDT) D
  1. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXDT,LEXIEN)) Q:+LEXIEN'>0 D
  1. . . N LEXND,LEXSY,LEXEXI S LEXND=$G(^LEX(757.02,+LEXIEN,0)),LEXSY=$P(LEXND,"^",3),LEXEXI=+LEXND
  1. . . Q:LEXSY'=LEXSYS S LEXINA(LEXDT)=LEXEXI
  1. S LEXDT="" F S LEXDT=$O(LEXACT(LEXDT)) Q:'$L(LEXDT) D
  1. . I $D(LEXINA(LEXDT)) D
  1. . . N LEXEXI,LEXPDT
  1. . . S LEXEXI=$G(LEXACT(LEXDT)),LEXPDT=$O(LEXACT(LEXDT),-1)
  1. . . S:LEXPDT?7N&(LEXEXI>0) LEXACT(LEXPDT)=LEXEXI
  1. . . K LEXACT(LEXDT),LEXINA(LEXDT)
  1. S LEXDT="" F S LEXDT=$O(LEXACT(LEXDT)) Q:'$L(LEXDT) D
  1. . N LEXIDT,LEXEXI,LEXEXP,LEXEF,LEXVP
  1. . ; Inactive Date
  1. . S LEXIDT=$O(LEXINA(LEXDT))
  1. . ; Lexicon Expression
  1. . S LEXEXI=$G(LEXACT(LEXDT))
  1. . S:LEXIDT?7N LEXEXI=$G(LEXINA(LEXIDT))
  1. . S LEXEXP="" S:+LEXEXI>0 LEXEXP=$G(^LEX(757.01,+LEXEXI,0))
  1. . ; Kill
  1. . K:LEXIDT?7N LEXINA(LEXIDT)
  1. . ; Effective Date
  1. . S LEXEF=$$DT^XLFDT S:LEXIDT?7N LEXEF=LEXIDT
  1. . ; Variable Pointer
  1. . S LEXVP=$$VP(LEXSO,LEXSYS,LEXEF)
  1. . ; Set array
  1. . S:LEXIDT'?7N LEXIDT=""
  1. . S LEXPER(LEXDT)=LEXIDT_"^"_LEXEXI_"^"_LEXVP
  1. . S:$L(LEXEXP) LEXPER(LEXDT,0)=LEXEXP
  1. K ARY M ARY=LEXPER
  1. S (LEXEF,LEXC)=0 F S LEXEF=$O(ARY(LEXEF)) Q:LEXEF'?7N S LEXC=LEXC+1
  1. S:+LEXC>0 ARY(0)=LEXC S:+LEXC'>0 ARY(0)="-1^No activation periods found for code"
  1. S:LEXSYS>0&($L($P($G(LEXSD),"^",3,5)))&(LEXC>0) ARY(0)=LEXC_U_LEXSYS_U_$P($G(LEXSD),"^",3,5)
  1. Q $G(ARY(0))
  1. VP(CODE,SYS,EFF) ; Variable Pointer ^ Description
  1. N LEXDES,LEXEF,LEXI,LEXR,LEXSO,LEXSYS,LEXVP
  1. S LEXSO=$G(CODE),LEXSYS=+($G(SYS))
  1. Q:'$L(LEXSO) "" Q:"^1^2^3^4^30^31^"'[("^"_LEXSYS_"^") ""
  1. S (LEXVP,LEXDES)="" S LEXEF=$G(EFF) S:LEXEF'?7N LEXEF=$$DT^XLFDT
  1. I LEXSYS=1!(LEXSYS=30) D
  1. . N LEXI,LEXR S LEXI=+($$CODEABA^ICDEX(LEXSO,80,LEXSYS)) Q:+LEXI'>0
  1. . S LEXR=$TR($$ROOT^ICDEX(80),"^","") Q:'$L(LEXR)
  1. . S LEXVP=LEXI_";"_LEXR
  1. . S LEXDES=$P($$ICDDX^ICDEX(LEXSO,(LEXEF+.001),LEXSYS,"E"),U,4)
  1. I LEXSYS=2!(LEXSYS=31) D
  1. . N LEXI,LEXR S LEXI=+($$CODEABA^ICDEX(LEXSO,80.1,LEXSYS)) Q:+LEXI'>0
  1. . S LEXR=$TR($$ROOT^ICDEX(80.1),"^","") Q:'$L(LEXR) S LEXVP=LEXI_";"_LEXR
  1. . S LEXDES=$P($$ICDOP^ICDEX(LEXSO,(LEXEF+.001),LEXSYS,"E"),U,5)
  1. I LEXSYS=3!(LEXSYS=4) D
  1. . N LEXI,LEXR S LEXI=$O(^ICPT("BA",(LEXSO_" "),0)) Q:+LEXI'>0
  1. . S LEXR="ICPT(",LEXVP=LEXI_";"_LEXR
  1. . S LEXDES=$P($$CPT^ICPTCOD(LEXSO,(LEXEF+.001)),U,3)
  1. Q:$L(LEXVP)&($L(LEXDES)) (LEXVP_"^"_LEXDES)
  1. Q ""
  1. REUSE(X,SYS) ; Is a code "re-used"
  1. ;
  1. ; Input
  1. ;
  1. ; X Code
  1. ; SYS Coding System
  1. ;
  1. ; Output
  1. ;
  1. ; $$REUSE 2 Piece "^" delimited string
  1. ; 1 Boolean flag
  1. ; 1 if the code was reused
  1. ; 0 if the code has not been reused
  1. ; 2 If reused, the date it was reused
  1. ;
  1. N LEXA,LEXAC,LEXEF,LEXH,LEXHARY,LEXI,LEXRU,LEXSO,LEXSRC,LEXSYS,LEXTD,LEXREU,LEXRD
  1. S (LEXA,LEXI)=0,LEXTD=$G(DT) S:LEXTD'?7N LEXTD=$$DT^XLFDT S LEXSO=$G(X),LEXSYS=$G(SYS)
  1. S LEXSRC=+($$CSYS^LEXU(LEXSYS)),LEXH=$$ACT($G(LEXSO),$G(LEXSYS),.LEXHARY) K LEXHARY(0,0),LEXHARY(0)
  1. S LEXREU=0,(LEXRD,LEXD)=" " F S LEXD=$O(LEXHARY(LEXD),-1) Q:'$L(LEXD) D Q:LEXREU>0
  1. . N LEXS,LEXE,LEXPD,LEXPS,LEXPE,LEXDIF
  1. . S LEXS=$O(LEXHARY(+LEXD," "),-1),LEXE=$G(LEXHARY(+LEXD,+LEXS))
  1. . S LEXPD=$O(LEXHARY(LEXD),-1),LEXPS=$O(LEXHARY(+LEXPD," "),-1)
  1. . S LEXPE=$G(LEXHARY(+LEXPD,+LEXPS))
  1. . Q:LEXS'?1N Q:LEXD'?7N Q:LEXPS'?1N Q:LEXPD'?7N
  1. . S LEXDIF=$$FMDIFF^XLFDT(LEXD,LEXPD,1) Q:LEXDIF'>10
  1. . I LEXS=1,LEXPS=0,LEXD'=LEXPD,LEXE'=LEXPE S LEXREU=1,LEXRD=LEXD
  1. S X=LEXREU S:+X>0&(LEXRD?7N) $P(X,"^",2)=LEXRD
  1. Q X
  1. REVISE(X,SYS) ; Is a code "revised"
  1. ;
  1. ; Input
  1. ;
  1. ; X Code
  1. ; SYS Coding System
  1. ;
  1. ; $$REVISE 2 Piece "^" delimited string
  1. ; 1 Boolean flag
  1. ; 1 if the code was reused
  1. ; 0 if the code has not been reused
  1. ; 2 If reused, the date it was reused
  1. ;
  1. N LEXA,LEXAC,LEXEF,LEXH,LEXHARY,LEXI,LEXRU,LEXSO,LEXSRC,LEXSYS,LEXTD,LEXREV,LEXRD
  1. S (LEXA,LEXI)=0,LEXTD=$G(DT) S:LEXTD'?7N LEXTD=$$DT^XLFDT S LEXSO=$G(X),LEXSYS=$G(SYS)
  1. S LEXSRC=+($$CSYS^LEXU(LEXSYS)),LEXH=$$ACT($G(LEXSO),$G(LEXSYS),.LEXHARY) K LEXHARY(0,0),LEXHARY(0)
  1. S LEXREV=0,(LEXRD,LEXD)=" " F S LEXD=$O(LEXHARY(LEXD),-1) Q:'$L(LEXD) D Q:LEXREV>0
  1. . N LEXS,LEXE,LEXPD,LEXPS,LEXPE,LEXDIF
  1. . S LEXS=$O(LEXHARY(+LEXD," "),-1),LEXE=$G(LEXHARY(+LEXD,+LEXS))
  1. . S LEXPD=$O(LEXHARY(LEXD),-1),LEXPS=$O(LEXHARY(+LEXPD," "),-1)
  1. . S LEXPE=$G(LEXHARY(+LEXPD,+LEXPS))
  1. . Q:LEXS'?1N Q:LEXD'?7N Q:LEXPS'?1N Q:LEXPD'?7N
  1. . I LEXPS=LEXS,LEXPD'=LEXD,LEXPE'=LEXE S LEXREV=1,LEXRD=LEXD
  1. S X=LEXREV S:+X>0&(LEXRD?7N) $P(X,"^",2)=LEXRD
  1. Q X
  1. LAST(X,SYS,CDT) ; Last Activation ^ Inactivation
  1. ;
  1. ; Input
  1. ;
  1. ; X Code
  1. ; SYS Coding System
  1. ; CDT Versioning Date
  1. ;
  1. ; $$LAST 2 Piece "^" delimited string
  1. ; 1 Last Activation Date
  1. ; 2 Last Inactivation Date
  1. ;
  1. ; or -1 on error/no dates found
  1. ;
  1. N LEXARY,LEXDT,LEXLA,LEXLI,LEXO,LEXSO,LEXT,LEXTD S LEXTD=$$DT^XLFDT,LEXDT=$G(CDT) S:LEXDT'?7N LEXDT=LEXTD
  1. S LEXSO=$G(X) S X=$$PERIOD^LEXU4($G(LEXSO),$G(SYS),.LEXARY) Q:+($G(LEXARY(0)))'>0 -1
  1. S (LEXLA,LEXLI)="",LEXO=0 F S LEXO=$O(LEXARY(LEXO)) Q:+LEXO'>0 D
  1. . N LEXT S LEXT=$P($G(LEXARY(LEXO)),"^",1)
  1. . I LEXO?7N,LEXO'>LEXDT S LEXLA=LEXO
  1. . I LEXT?7N,LEXT'>LEXDT S:+LEXT>+LEXLI LEXLI=LEXT
  1. Q:+LEXLA'>0 -1 S X=LEXLA S:LEXLI>0 X=X_"^"_LEXLI
  1. Q X
  1. ACT(CODE,SYS,ARY) ; Get Activations
  1. N LEXA,LEXC,LEXE,LEXI,LEXN,LEXNOM,LEXP,LEXS,LEXSAB,LEXSI,LEXSO,LEXSRC,LEXTD,X S X=0
  1. S LEXSO=$G(CODE) K ARY Q:'$L(LEXSO) "-1^Code missing"
  1. Q:'$D(^LEX(757.02,"ACT",(LEXSO_" "))) "-1^Invalid code missing"
  1. S LEXSAB=$G(SYS),LEXSRC=+($$CSYS^LEXU(LEXSAB))
  1. S:LEXSRC'>0 LEXSRC=$$SYSC(LEXSO) Q:+LEXSRC'>0 "-1^Invalid source"
  1. S LEXNOM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2)
  1. S (LEXSI,LEXSAB)=$$CSYS^LEXU(+LEXSRC)
  1. S LEXSI=$P(LEXSI,"^",3,4)
  1. S LEXSAB=$P(LEXSAB,"^",2) Q:$L(LEXSAB)'=3 "-1^Invalid source"
  1. S LEXTD=$$DT^XLFDT F LEXI=0,1 D
  1. . N LEXE,LEXSTA S LEXE=0,LEXSTA=LEXI
  1. . F S LEXE=$O(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE)) Q:+LEXE'>0 D
  1. . . N LEXS S LEXS=0
  1. . . F S LEXS=$O(^LEX(757.02,"ACT",(LEXSO_" "),LEXI,LEXE,LEXS)) Q:+LEXS'>0 D
  1. . . . N LEXN,LEXC S LEXN=$G(^LEX(757.02,LEXS,0))
  1. . . . S LEXC=+($P(LEXN,"^",3)) Q:+LEXC'=LEXSRC
  1. . . . S:'$D(ARY(LEXE,LEXSTA)) ARY(0)=+($G(ARY(0)))+1
  1. . . . S ARY(LEXE,LEXSTA)=+LEXN
  1. S LEXA=0,LEXE=0 F S LEXE=$O(ARY(LEXE)) Q:+LEXE'>0 D
  1. . S LEXS="" F S LEXS=$O(ARY(LEXE,LEXS)) Q:'$L(LEXS) D
  1. . . K:+LEXS>0 ARY(LEXE,0)
  1. S LEXE=0 F S LEXE=$O(ARY(LEXE)) Q:+LEXE'>0 D
  1. . N LEXS S LEXS="" F S LEXS=$O(ARY(LEXE,LEXS)) Q:'$L(LEXS) S X=X+1
  1. Q X
  1. PFI(FRAG,CDT,ARY) ; Get Procedure Fragment Info
  1. ;
  1. ; Input
  1. ;
  1. ; FRAG ICD-10-PCS Code Fragment
  1. ; CDT Versioning date (busines rules apply)
  1. ; .ARY Local Array passed by reference
  1. ;
  1. ; Output
  1. ;
  1. ; $$PFI 1 if successful
  1. ; -1 ^ Error Message if unsuccessful
  1. ; ARY
  1. ;
  1. ; ARY(0) 5 piece "^" delimited strig
  1. ; 1 Unique Id
  1. ; 2 Code Fragment
  1. ; 3 Date Entered
  1. ; 4 Source
  1. ; 5 Details
  1. ;
  1. ; ARY(1) 4 piece "^" delimited string
  1. ; 1 Effective Date
  1. ; 2 Status
  1. ; 3 Effective Date External
  1. ; 4 Status External
  1. ;
  1. ; ARY(2) Name/Title
  1. ; ARY(3) Description
  1. ; ARY(4) Explanation
  1. ; ARY(5,0) # of synonyms included
  1. ; ARY(5,n) included synonyms
  1. ;
  1. N LEXF,LEXI,LEXE,LEXC,LEXD,LEXN,X S LEXF=$G(FRAG) K ARY
  1. S LEXI=$$IMPDATE^LEXU(31) S LEXD=$G(CDT) S:'$L(LEXD) LEXD=$$DT^XLFDT
  1. S:LEXD?7N&(LEXI?7N)&(LEXD<LEXI) LEXD=LEXI
  1. Q:'$D(^LEX(757.033,"AFRAG",31,(LEXF_" "))) "-1^Invalid procedure code fragment"
  1. S LEXE=$O(^LEX(757.033,"AFRAG",31,(LEXF_" "),(LEXD+.001)),-1)
  1. Q:LEXE'?7N "-1^Fragment not active"
  1. S LEXN=$O(^LEX(757.033,"AFRAG",31,(LEXF_" "),+LEXE," "),-1)
  1. Q:+LEXN'>0 "-1^Fragment not found"
  1. K ARY S X=$$FIN^LEX10PR(LEXN,LEXD,.ARY)
  1. Q X
  1. SYSC(X) ; System from Code (must be unique)
  1. ;
  1. ; Input:
  1. ;
  1. ; X Classification Code (required)
  1. ;
  1. ; Output:
  1. ;
  1. ; $$SYSC Pointer to CODING SYSTEMS file 757.03
  1. ;
  1. ; or
  1. ;
  1. ; -1 ^ error message
  1. ;
  1. N LEXS,LEXSIEN,LEXSO S LEXSO=$G(X) Q:'$L(LEXSO) "-1^Code missing"
  1. Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) "-1^Invalid code missing"
  1. K LEXS S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
  1. . S LEXS(+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",3)))=""
  1. I $O(LEXS(0))>0,$O(LEXS(0))=$O(LEXS(" "),-1) S X=$O(LEXS(0)) Q X
  1. Q "-1^Unable to resolve coding system"
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
  1. F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X