ICDEXS ;SLC/KER - ICD Extractor - Support ;04/19/2016
;;18.0;DRG Grouper;**57,1**;Oct 20, 2000;Build 1
; AICD*4.0*1 IHS/OIT/FBD&NKD - Optimizations: FILE, ROOT, SYS
;
; Global Variables
; ^ICD0( N/A
; ^ICD9( N/A
; ^ICDS( N/A
;
; External References
; $$GET1^DIQ ICR 2056
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
EFF(FILE,IEN,EDT) ; returns effective date and status for code/modifier
;
; Input:
;
; FILE File number 80/80.1 (required)
; IEN ICD IEN (required)
; EDT Date to check (FileMan format) (required)
;
; Output:
;
; A 3 piece "^" delimited string
;
; 1 Status
; 1 - Active
; 0 - Inactive
; 2 Inactivation Date
; 3 Activation Date
; -or-
; -1^error message
;
N EFF,EFFB,EFFDOS,EFFDT,EFFN,EFFST,EFILE,ICDY,ROOT,STR
I $G(IEN)=""!(IEN'?1N.N) Q "-1^No Code Selected"
S FILE=$$FILE($G(FILE)) Q:+FILE'>0 "-1^Invalid File"
S ROOT=$$ROOT(FILE)
Q:"^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^") "-1^Invalid Global"
Q:'$G(EDT) "-1^No Date Selected" S EDT=$P(EDT,".",1)
Q:EDT'?7N "-1^Invalid Date Selected"
S IEN=+($G(IEN)) Q:+IEN'>0 "-1^IEN Invalid" S EFILE=ROOT_IEN_",66,"
S ICDY=$P($G(@(ROOT_+IEN_",1)")),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
S EDT=$S($G(EDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX(EDT,,ICDY))+.001
S EFF=$O(@(EFILE_"""B"","_EDT_")"),-1) Q:'EFF "0^^"
S EFFN=$O(@(EFILE_"""B"","_EFF_",0)")),STR=$G(@(EFILE_EFFN_",0)")) Q:STR="" "0^^"
S EFFDT=$P(STR,"^"),EFFST=$P(STR,"^",2),EFFB=0,EFF=+EFF
F S EFF=$O(@(EFILE_"""B"","_EFF_")"),-1) Q:'EFF!EFFB D
. S EFFN=$O(@(EFILE_"""B"","_EFF_",0)")) I 'EFFN S EFFB=1 Q
. S EFFDOS=$G(@(EFILE_EFFN_",0)")) I 'EFFDOS S EFFB=1 Q
. S EFFB=(EFFST'=$P(EFFDOS,"^",2))
S EFFDOS=$P($G(EFFDOS),"^")
I EFFST S $P(STR,"^",3,4)=(EFFDOS)_"^"_EFFDT
E S $P(STR,"^",3,4)=EFFDT_"^"_(EFFDOS)
Q $P(STR,"^",2,4)
IA(FILE,IEN) ; Initial Activation Date
;
; Input:
;
; FILE Global Root/File Number (Required)
; IEN Internal Entry Number (Required)
;
; Output:
;
; $$IA Initial Activation Date OR -1 ^ Error Message
;
N ROOT,EFF,HIS,NOD,ACT,INA
S FILE=$$FILE($G(FILE)) Q:+FILE'>0 "-1^Invalid File" S ROOT=$$ROOT(FILE)
Q:"^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^") "-1^Invalid Global"
S IEN=$G(IEN) Q:+IEN'>0!('$D(@(ROOT_+IEN_")"))) "-1^Invalid Code"
S ACT="",EFF=""
F S EFF=$O(@(ROOT_+IEN_",66,""B"","""_EFF_""")")) Q:(EFF'?7N)!($L(ACT)) D Q:$L(ACT)
. S HIS=" " F S HIS=$O(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1) Q:+HIS'>0 D Q:$L(ACT)
. . N NOD,STA S NOD=$G(@(ROOT_+IEN_",66,"_+HIS_",0)"))
. . S STA=$P(NOD,"^",2) S:STA?1N&(+STA>0)&('$L(ACT)) ACT=EFF
S:'$L(ACT) ACT="-1^Initial activation date not found"
Q ACT
LA(FILE,IEN,CDT) ; Last Current Activation Date
;
; Input:
;
; FILE Global Root/File Number (Required)
; IEN Internal Entry Number (Required)
; CDT Date (default = TODAY) (Optional)
;
; Output:
;
; $$LA Last Current Activation Date OR -1 ^ Error Message
;
N ROOT,EFF,HIS,NOD,ACT,INA,ICDF
S FILE=$$FILE($G(FILE)) Q:+FILE'>0 "-1^Invalid File" S ROOT=$$ROOT(FILE)
Q:"^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^") "-1^Invalid Global"
S CDT=$G(CDT) S:CDT'?7N CDT=$$DT^XLFDT S IEN=$G(IEN)
Q:+IEN'>0!('$D(@(ROOT_+IEN_")"))) "-1^Invalid Code"
S ACT="",EFF=CDT+.000001
F S EFF=$O(@(ROOT_+IEN_",66,""B"","""_EFF_""")"),-1) Q:(EFF'?7N)!($L(ACT)) D Q:$L(ACT)
. S HIS=" " F S HIS=$O(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1) Q:+HIS'>0 D Q:$L(ACT)
. . N NOD,STA S NOD=$G(@(ROOT_+IEN_",66,"_+HIS_",0)"))
. . S STA=$P(NOD,"^",2) S:STA?1N&(+STA>0)&('$L(ACT)) ACT=EFF
S:'$L(ACT) ACT="-1^Not activated on or before "_$$FMTE^XLFDT($G(CDT),"5DZ")
Q ACT
LI(FILE,IEN,CDT) ; Last Current Inactivation Date
;
; Input:
;
; IEN Internal Entry Number (Required)
; FILE Global Root/File Number (Required)
; CDT Date (default = TODAY) (Optional)
;
; Output:
;
; $$LI Last Current Inactivation Date OR -1 ^ Error Message
;
N ROOT,EFF,HIS,NOD,ACT,INA
S FILE=$$FILE($G(FILE)) Q:+FILE'>0 "-12^Invalid File" S ROOT=$$ROOT(FILE)
Q:"^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^") "-1^Invalid Global"
S CDT=$G(CDT) S:CDT'?7N CDT=$$DT^XLFDT S IEN=$G(IEN)
Q:+IEN'>0!('$D(@(ROOT_+IEN_")"))) "-1^Invalid Code"
S INA="",EFF=CDT+.000001
F S EFF=$O(@(ROOT_+IEN_",66,""B"","""_EFF_""")"),-1) Q:'$L(EFF)!(EFF'?7N)!($L(INA)) D Q:$L(INA)
. S HIS=" " F S HIS=$O(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1) Q:+HIS'>0 D Q:$L(INA)
. . N NOD,STA S NOD=$G(@(ROOT_+IEN_",66,"_+HIS_",0)"))
. . S STA=$P(NOD,"^",2) S:STA?1N&(+STA'>0)&('$L(INA)) INA=EFF
S:'$L(INA) INA="-1^Not inactivated on or before "_$$FMTE^XLFDT($G(CDT),"5DZ")
Q INA
LS(FILE,IEN,CDT,FMT) ; Last Status
;
; Input:
;
; FILE Global Root/File Number (Required)
; IEN Internal Entry Number (Required)
; CDT Date (default = TODAY) (Optional)
; FMT Format
; 0 Last Status only (default)
; 1 Last Status ^ Effective Date
;
; Output:
;
; $$LS Last Status (1/0) OR -1 ^ Error Message
;
N ROOT,EFF,HIS,NOD,ACT,INA,LEF,STA
S FILE=$$FILE($G(FILE)) Q:+FILE'>0 "-12^Invalid File" S ROOT=$$ROOT(FILE)
Q:"^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^") "-1^Invalid Global"
S CDT=$G(CDT) S:CDT'?7N CDT=$$DT^XLFDT S IEN=$G(IEN)
Q:+IEN'>0!('$D(@(ROOT_+IEN_")"))) "-1^Invalid Code"
S INA="",EFF=CDT+.000001 S EFF=$O(@(ROOT_+IEN_",66,""B"","""_EFF_""")"),-1)
Q:'$L(EFF)!(EFF'?7N) "-1^No status on or before "_$$FMTE^XLFDT($G(CDT),"5DZ")
S HIS="~",HIS=$O(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1)
Q:+HIS'>0 "-1^No status on or before "_$$FMTE^XLFDT($G(CDT),"5DZ")
S NOD=$G(@(ROOT_+IEN_",66,"_+HIS_",0)")),STA=$P(NOD,"^",2),LEF=$P(NOD,"^",1)
Q:"^0^1^"'[("^"_STA_"^") "-1^No status on or before "_$$FMTE^XLFDT($G(CDT),"5DZ")
S:+($G(FMT))>0&($G(LEF)?7N) STA=STA_"^"_LEF
Q STA
;
NUM(CODE) ; Convert Code to a Numeric Value (opposite of $$COD)
;
; Input:
;
; CODE ICD CODE (required)
;
; Output:
;
; NUM Numerical representation of CODE
;
; or
;
; -1 on error
;
S CODE=$G(CODE) Q:'$L($G(CODE)) 0
N PSN,OUT,CHR,ERR S ERR=0,OUT="" F PSN=1:1:9 D
. S CHR=$E(CODE,PSN) S CHR=$S($L(CHR):$A(CHR),1:32),CHR=CHR-30
. S:CHR'>0 ERR=1 F Q:$L(CHR)>1 S CHR="0"_CHR
. S:$L(CHR)'=2 ERR=1 S OUT=OUT_CHR
Q:ERR -1 S:+OUT>0 OUT="1"_OUT
Q OUT
COD(NUM) ; Convert Numeric Value to a Code (opposite of $$NUM)
;
; Input:
;
; NUM Numerical representation of an ICD Code (required)
;
; Output:
;
; CODE ICD Code
;
; or
;
; null on error
;
Q:'$L(NUM) "" Q:$E(NUM,1)'=1 "" S NUM=$E(NUM,2,$L(NUM))
N PSN,OUT,CHR,ADD S OUT=""
F PSN=1:2 S CHR=$E(NUM,PSN,(PSN+1)) Q:'$L(CHR) D
. S CHR=+CHR+30 S ADD="" S:CHR'=32 ADD=$C(CHR) S:$L(ADD) OUT=OUT_ADD
Q OUT
IE(X) ; Internal or External
;
; Input:
;
; X ICD code or IEN
;
; Output:
;
; $$IE Set of Codes
;
; I X is in an internal format (IEN)
; E X is in an external format (Code)
;
; Null on error
;
N IN,OUT
S IN=$G(X) Q:'$L(X) ""
Q:IN?1N.N&('$D(^ICD9("BA",(IN_" "))))&('$D(^ICD0("BA",(IN_" ")))) "I"
Q:$D(^ICD9("BA",(IN_" ")))!($D(^ICD0("BA",(IN_" ")))) "E"
Q ""
FILE(X) ; File Number
;
; Input:
;
; X File/Identifier/Coding System/Code (required)
;
; Output:
;
; FILE File Number or -1 on error
;
N ICDX,ICDF S (ICDX,X)=$G(X) Q:'$L(X) -1 N ICDR
I X?1N.N Q:X?1N&(+X=0) 80.1 Q:X?1N&(+X=9) 80
;S ICDR=$$ROOT(X) Q:$D(^ICD9("BA",(X_" "))) 80 Q:$D(^ICD0("BA",(X_" "))) 80.1 ;IHS/OIT/FBD&NKD - ICDR LAST (OPT)
Q:$D(^ICD9("BA",(X_" "))) 80 Q:$D(^ICD0("BA",(X_" "))) 80.1
Q:X=80 80 Q:X=80.1 80.1 Q:X["ICD9" 80 Q:X["ICD0" 80.1 Q:X["DX"!(X["DIAG") 80 Q:X["PR"!(X["PROC")!(X["OP")!(X["PCS") 80.1
I ICDX?1N.N I ICDX'["." Q:$D(^ICD9("ABA",+ICDX)) 80 Q:$D(^ICD0("ABA",+ICDX)) 80.1
Q:$D(^ICD9("BA",(X_" "))) 80 Q:$D(^ICD0("BA",(X_" "))) 80.1
Q:$D(^ICD9("AVA",(X_" "))) 80 Q:$D(^ICD0("AVA",(X_" "))) 80.1
Q:$D(^ICD9("AEXC",(X_" "))) 80 Q:$D(^ICD0("AEXC",(X_" "))) 80.1
;Q:ICDR["ICD9" 80 Q:ICDR["ICD0" 80.1 ;IHS/OIT/FBD&NKD - ICDR LAST (OPT)
S ICDR=$$ROOT(X) Q:ICDR["ICD9" 80 Q:ICDR["ICD0" 80.1
Q -1
ROOT(X) ; Global Root
;
; Input:
;
; X File Number, File Name, Root, Identifier
; or Coding System (required)
;
; Output:
;
; ROOT Global Root for File or null
;
;N ICDR,ICDF S ICDR=$$RY($G(X)) Q:$L(ICDR) ICDR ;IHS/OIT/FBD&NKD - REORDER (OPT)
N ICDR,ICDF S (ICDR,X)=$G(X) Q:'$L(X) "" Q:"^ICD9(^ICD0(^"[("^"_$E(ICDR,2,$L(ICDR))_"^") "^"_$E(ICDR,2,$L(ICDR)) S ICDR=$$RF($G(X)) Q:$L(ICDR) ICDR
S ICDR=$$RY($G(X)) Q:$L(ICDR) ICDR
S ICDR=$$RC($G(X)) Q:$L(ICDR) ICDR S X=$$UP^XLFSTR($G(X))
;S ICDR=$$RF($G(X)) Q:$L(ICDR) ICDR ;IHS/OIT/FBD&NKD - REORDER (OPT)
S ICDR=$$RR($G(X)) Q:$L(ICDR) ICDR
S:X?1N.N ICDR=$$RS(+($G(X))) Q:$L(ICDR) ICDR
Q ""
RY(SYS) ; Global Root from System
N FILE,ROOT S SYS=$G(SYS) Q:SYS'?1N.N "" Q:SYS=80!(SYS=80.1) "" Q:'$D(^ICDS(+SYS)) ""
S FILE=$P($G(^ICDS(+SYS,0)),"^",3) Q:+FILE'>0 "" S ROOT=$$RF(FILE) Q:$L(ROOT) ROOT
Q ""
RF(FILE) ; Global Root from File
Q:$G(FILE)=80 "^ICD9(" Q:$G(FILE)=80.1 "^ICD0("
Q ""
RR(ID) ; Global Root from Root or Identifier
Q:ID["ICD9" "^ICD9(" Q:ID["ICD0" "^ICD0(" Q:ID="DX"!(ID["DIA") "^ICD9(" Q:ID="PR"!(ID["PRO")!(ID["OP") "^ICD0("
Q:ID="ICD"!(ID="10D") "^ICD9(" Q:ID="ICP"!(ID="10P") "^ICD0("
Q ""
RS(SYS) ; Global Root from Coding System
S SYS=$TR(SYS," ","") Q:$D(^ICD9("ABA",+SYS)) "^ICD9(" Q:$D(^ICD0("ABA",+SYS)) "^ICD0("
Q ""
RC(COD) ; Global Root from Code
Q:$D(^ICD9("BA",($G(COD)_" "))) "^ICD9(" Q:$D(^ICD0("BA",($G(COD)_" "))) "^ICD0("
Q:$D(^ICD9("AVA",(X_" "))) "^ICD9(" Q:$D(^ICD0("AVA",(X_" "))) "^ICD0("
Q:$D(^ICD9("AEXC",(X_" "))) "^ICD9(" Q:$D(^ICD0("AEXC",(X_" "))) "^ICD0("
Q ""
;
SYS(SYS,CDT,FMT) ; Resolve System (uses file 80.4)
;
; Input:
;
; SYS System/Source Abbreviation/System Identifier/Code
; CDT Date (optional)
; FMT Output Format (optional)
;
; I Internal (default)
; E External
; B Both Internal ^ External
;
; Output:
;
; $$SYS System (numeric or alpha)
;
; Internal External
; 1 ICD-9-CM
; 2 ICD-9 Proc
; 30 ICD-10-CM
; 31 ICD-10-PCS
;
; or
; -1 on error
;
N ICDC,ICDD,ICDF,ICDI,ICDO,ICDT,ICDU,ICDX,ICDT S ICDI=$G(SYS) Q:'$L(ICDI) -1
S ICDD=$P($G(CDT),".",1) S ICDF=$$UP^XLFSTR($G(FMT)) S:'$L(ICDF) ICDF="I"
S:"^E^B^"'[("^"_ICDF_"^") ICDF="I" S ICDU=$$UP^XLFSTR(ICDI)
I ICDI?1N.N,+ICDI=ICDI Q:$D(^ICDS(+ICDI)) $S(ICDF["B":(+ICDI_"^"_$$SNAM(+ICDI)),ICDF["E":$$SNAM(+ICDI),1:+ICDI) ;IHS/OIT/FBD&NKD - REORDER (OPT)
S ICDO=$$SC(ICDI) Q:+ICDO>0 $S(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
;I ICDI?1N.N Q:$D(^ICDS(+ICDI)) $S(ICDF["B":(+ICDI_"^"_$$SNAM(+ICDI)),ICDF["E":$$SNAM(+ICDI),1:+ICDI) ;IHS/OIT/FBD&NKD - REORDER (OPT)
S ICDO=$$SS(ICDI) Q:+ICDO>0 $S(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
S ICDO=$$SM(ICDI,ICDD) Q:+ICDO>0 $S(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
S ICDO=$$SP(ICDI) Q:+ICDO>0 $S(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
Q -1
SS(X) ; System from Coding System file 80.4
N ICDC,ICDI,ICDO,ICDU S ICDI=$G(X) Q:'$L(ICDI) "" S ICDU=$$UP^XLFSTR(ICDI)
S ICDO="",ICDC="AZ" F S ICDC=$O(^ICDS(ICDC)) Q:'$L(ICDC) D Q:+ICDO>0
. Q:ICDC="F" N ICDT S ICDT=$O(^ICDS(ICDC,ICDI,0))
. S:+ICDT'>0 ICDT=$O(^ICDS(ICDC,ICDU,0)) S:+ICDT>0 ICDO=ICDT
Q ICDO
SM(X,CDT) ; System from a Mnemonic
N ICDD,ICDX,ICDO,ICDU S ICDU=$$UP^XLFSTR($G(X)) Q:'$L(ICDU) "" S ICDD=$G(CDT) S:ICDD'?7N ICDD=$$DT^XLFDT
S ICDX=$P($G(^ICDS(30,0)),"^",4),ICDO=""
I (ICDU["DIAG"!(ICDU["ICD9")!(ICDU="80")!(ICDU="DX")) I ICDD?7N,ICDX?7N S ICDO=$S(ICDD<ICDX:1,1:30)
I (ICDU["PROC"!(ICDU["OPER")!(ICDU["ICD0")!(ICDU["ICP9")!(ICDU="80.1")!(ICDU="PR")) I ICDD?7N,ICDX?7N S ICDO=$S(ICDD<ICDX:2,1:31)
Q ICDO
SP(X) ; System from Pattern Match
N ICDT,ICDI,ICDO S ICDO="",ICDT=$$UP^XLFSTR($G(X)) Q:'$L(ICDT) ""
F Q:ICDT'["ICD" S ICDT=$P(ICDT,"ICD",1)_$P(ICDT,"ICD",2)
Q:'$L(ICDT) "" S ICDI="" F S ICDI=$O(^ICDS("B",ICDI)) Q:'$L(ICDI) D Q:+ICDO>0
. S:ICDT["9"&(ICDT["D")&(ICDT'["P")&(ICDI["9")&(ICDI["CM") ICDO=$O(^ICDS("B",ICDI,0)) Q:ICDO>0
. S:ICDT["9"&((ICDT["P")!(ICDT["O"))&(ICDI["9")&(ICDI["P") ICDO=$O(^ICDS("B",ICDI,0)) Q:ICDO>0
. S:ICDT["10"&(ICDT["D")&(ICDT'["P")&(ICDI["10")&(ICDI["CM") ICDO=$O(^ICDS("B",ICDI,0)) Q:ICDO>0
. S:ICDT["10"&((ICDT["P")!(ICDT["O"))&(ICDI["10")&(ICDI["P") ICDO=$O(^ICDS("B",ICDI,0)) Q:ICDO>0
Q ICDO
SC(X) ; System from Code
N ICDI,ICDC,ICDO,ICDR,ICDU S ICDI=$G(X) S ICDC=$TR(ICDI," ","") Q:'$L(ICDC) ""
S ICDU=$$UP^XLFSTR(ICDC) S ICDO="" F ICDR="^ICD9(","^ICD0(" D Q:+ICDO>0
. N TMP F TMP=ICDC,ICDU D Q:+ICDO>0
. . N ICDS,ICDV,ICDE S ICDS=0 F S ICDS=$O(@(ICDR_"""ABA"","_ICDS_")")) Q:+ICDS'>0 D Q:ICDO>0
. . . S:$D(@(ICDR_"""ABA"","_ICDS_","""_TMP_" "")")) ICDO=ICDS
. . Q:ICDO>0 S ICDV=$O(@(ICDR_"""AVA"","""_TMP_" "",0)"))
. . S:+ICDV>0 ICDO=$P($G(@(ICDR_+ICDV_",1)")),"^",1) Q:ICDO>0
. . S ICDE=$O(@(ICDR_"""AEXC"","""_TMP_" "",0)"))
. . S:+ICDE>0 ICDO=$P($G(@(ICDR_+ICDE_",1)")),"^",1) Q:ICDO>0
Q ICDO
SINFO(SYS,CDT) ; System Info (uses file 80.4)
;
; Input:
;
; SYS System/Source Abbreviation/System Identifier/Code
; CDT Date (optional)
;
; Output:
;
; $$SINFO System Info (numeric or alpha)
;
; Internal External
; 1 IEN to file 80.4
; 2 Coding System
; 3 Coding System Nomenclature
; 4 Coding system Abbreviation
; 5 File where the Coding System is stored
; 6 Implementation Date
;
; or
; -1 on error
;
N ICDD,ICDS,ICDN,ICDT
S ICDD=$S($G(CDT)'?7N:$$DT^XLFDT,1:$G(CDT))
S ICDS=$$SYS($G(SYS),ICDD,"I")
Q:+ICDS'>0 "-1^Coding System Unknown"
S ICDN=$G(^ICDS(+ICDS,0)) Q:'$L(ICDN) "-1^Coding System not found"
S ICDT=$S($P(ICDN,"^",3)=80:"Diagnosis",$P(ICDN,"^",3)=80.1:"Procedure",1:"")
S SYS=ICDS_"^"_ICDN S:$L(ICDT) SYS=SYS_"^"_ICDT
Q SYS
SNAM(SYS) ; System Name
;
; Input:
;
; SYS Numeric System Identifier (field 1.1)
;
; Output:
;
; $$SYS Character System Name
;
; or -1 on error
;
S SYS=+($G(SYS)) S SYS=$P($G(^ICDS(+SYS,0)),"^",1)
Q $S($L(SYS):SYS,1:-1)
SAB(X,Y) ; Source Abbreviation
;
; Input:
;
; X Source Abbreviation or Identifier
; Y Date used to determine SAB
;
; Output:
;
; $$SAB 3 Character System Identifier
;
N SYS,CDT,TY,VR,OUT,TMP,ICD10 S SYS=$G(X),CDT=$G(Y)
S:CDT'?7N CDT=$$DT^XLFDT S ICD10=+($$IMP^ICDEX(30))
S TMP=$$SYS(SYS,CDT) S:+TMP>0&($D(^ICDS(+TMP,0))) SYS=TMP
Q:+SYS=1 "ICD" Q:+SYS=2 "ICP" Q:+SYS=30 "10D" Q:+SYS=31 "10P"
Q:SYS="DIAG" $S(CDT'<ICD10:"10D",1:"ICD")
Q:SYS["ICD9" $S(CDT'<ICD10:"10D",1:"ICD")
Q:SYS="PROC" $S(CDT'<ICD10:"10P",1:"ICP")
Q:SYS["ICD0" $S(CDT'<ICD10:"10P",1:"ICP")
Q:"^ICD^ICP^10D^10P^"[("^"_SYS_"^") SYS
Q ""
EXC(FILE,IEN) ; Exclude From lookup
;
; Input:
;
; FILE File number 80 or 80.1
; IEN Internal Entry Number
;
; Output:
;
; $$EXC Boolean value 1 = Yes 0 = No
;
N ICDF,ICDI,ICDR S ICDF=+($G(FILE)),ICDI=+($G(IEN)) Q:"^80^80.1^"'[("^"_ICDF_"^") 0
S ICDR=$$ROOT(ICDF) Q:"^ICD9(^ICD0(^"'[("^"_$E(ICDR,2,$L(ICDR))_"^") 0 Q:'$D(@(ICDR_+ICDI_",0)")) 0
Q $S(+($$GET1^DIQ(ICDF,(+ICDI_","),1.8))'>0:0,1:1)
ICDEXS ;SLC/KER - ICD Extractor - Support ;04/19/2016
+1 ;;18.0;DRG Grouper;**57,1**;Oct 20, 2000;Build 1
+2 ; AICD*4.0*1 IHS/OIT/FBD&NKD - Optimizations: FILE, ROOT, SYS
+3 ;
+4 ; Global Variables
+5 ; ^ICD0( N/A
+6 ; ^ICD9( N/A
+7 ; ^ICDS( N/A
+8 ;
+9 ; External References
+10 ; $$GET1^DIQ ICR 2056
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$FMTE^XLFDT ICR 10103
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
EFF(FILE,IEN,EDT) ; returns effective date and status for code/modifier
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File number 80/80.1 (required)
+5 ; IEN ICD IEN (required)
+6 ; EDT Date to check (FileMan format) (required)
+7 ;
+8 ; Output:
+9 ;
+10 ; A 3 piece "^" delimited string
+11 ;
+12 ; 1 Status
+13 ; 1 - Active
+14 ; 0 - Inactive
+15 ; 2 Inactivation Date
+16 ; 3 Activation Date
+17 ; -or-
+18 ; -1^error message
+19 ;
+20 NEW EFF,EFFB,EFFDOS,EFFDT,EFFN,EFFST,EFILE,ICDY,ROOT,STR
+21 IF $GET(IEN)=""!(IEN'?1N.N)
QUIT "-1^No Code Selected"
+22 SET FILE=$$FILE($GET(FILE))
IF +FILE'>0
QUIT "-1^Invalid File"
+23 SET ROOT=$$ROOT(FILE)
+24 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
QUIT "-1^Invalid Global"
+25 IF '$GET(EDT)
QUIT "-1^No Date Selected"
SET EDT=$PIECE(EDT,".",1)
+26 IF EDT'?7N
QUIT "-1^Invalid Date Selected"
+27 SET IEN=+($GET(IEN))
IF +IEN'>0
QUIT "-1^IEN Invalid"
SET EFILE=ROOT_IEN_",66,"
+28 SET ICDY=$PIECE($GET(@(ROOT_+IEN_",1)")),"^",1)
IF +ICDY'>0
QUIT "-1^Invalid Coding System"
+29 SET EDT=$SELECT($GET(EDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX(EDT,,ICDY))+.001
+30 SET EFF=$ORDER(@(EFILE_"""B"","_EDT_")"),-1)
IF 'EFF
QUIT "0^^"
+31 SET EFFN=$ORDER(@(EFILE_"""B"","_EFF_",0)"))
SET STR=$GET(@(EFILE_EFFN_",0)"))
IF STR=""
QUIT "0^^"
+32 SET EFFDT=$PIECE(STR,"^")
SET EFFST=$PIECE(STR,"^",2)
SET EFFB=0
SET EFF=+EFF
+33 FOR
SET EFF=$ORDER(@(EFILE_"""B"","_EFF_")"),-1)
IF 'EFF!EFFB
QUIT
Begin DoDot:1
+34 SET EFFN=$ORDER(@(EFILE_"""B"","_EFF_",0)"))
IF 'EFFN
SET EFFB=1
QUIT
+35 SET EFFDOS=$GET(@(EFILE_EFFN_",0)"))
IF 'EFFDOS
SET EFFB=1
QUIT
+36 SET EFFB=(EFFST'=$PIECE(EFFDOS,"^",2))
End DoDot:1
+37 SET EFFDOS=$PIECE($GET(EFFDOS),"^")
+38 IF EFFST
SET $PIECE(STR,"^",3,4)=(EFFDOS)_"^"_EFFDT
+39 IF '$TEST
SET $PIECE(STR,"^",3,4)=EFFDT_"^"_(EFFDOS)
+40 QUIT $PIECE(STR,"^",2,4)
IA(FILE,IEN) ; Initial Activation Date
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE Global Root/File Number (Required)
+5 ; IEN Internal Entry Number (Required)
+6 ;
+7 ; Output:
+8 ;
+9 ; $$IA Initial Activation Date OR -1 ^ Error Message
+10 ;
+11 NEW ROOT,EFF,HIS,NOD,ACT,INA
+12 SET FILE=$$FILE($GET(FILE))
IF +FILE'>0
QUIT "-1^Invalid File"
SET ROOT=$$ROOT(FILE)
+13 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
QUIT "-1^Invalid Global"
+14 SET IEN=$GET(IEN)
IF +IEN'>0!('$DATA(@(ROOT_+IEN_")")))
QUIT "-1^Invalid Code"
+15 SET ACT=""
SET EFF=""
+16 FOR
SET EFF=$ORDER(@(ROOT_+IEN_",66,""B"","""_EFF_""")"))
IF (EFF'?7N)!($LENGTH(ACT))
QUIT
Begin DoDot:1
+17 SET HIS=" "
FOR
SET HIS=$ORDER(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1)
IF +HIS'>0
QUIT
Begin DoDot:2
+18 NEW NOD,STA
SET NOD=$GET(@(ROOT_+IEN_",66,"_+HIS_",0)"))
+19 SET STA=$PIECE(NOD,"^",2)
IF STA?1N&(+STA>0)&('$LENGTH(ACT))
SET ACT=EFF
End DoDot:2
IF $LENGTH(ACT)
QUIT
End DoDot:1
IF $LENGTH(ACT)
QUIT
+20 IF '$LENGTH(ACT)
SET ACT="-1^Initial activation date not found"
+21 QUIT ACT
LA(FILE,IEN,CDT) ; Last Current Activation Date
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE Global Root/File Number (Required)
+5 ; IEN Internal Entry Number (Required)
+6 ; CDT Date (default = TODAY) (Optional)
+7 ;
+8 ; Output:
+9 ;
+10 ; $$LA Last Current Activation Date OR -1 ^ Error Message
+11 ;
+12 NEW ROOT,EFF,HIS,NOD,ACT,INA,ICDF
+13 SET FILE=$$FILE($GET(FILE))
IF +FILE'>0
QUIT "-1^Invalid File"
SET ROOT=$$ROOT(FILE)
+14 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
QUIT "-1^Invalid Global"
+15 SET CDT=$GET(CDT)
IF CDT'?7N
SET CDT=$$DT^XLFDT
SET IEN=$GET(IEN)
+16 IF +IEN'>0!('$DATA(@(ROOT_+IEN_")")))
QUIT "-1^Invalid Code"
+17 SET ACT=""
SET EFF=CDT+.000001
+18 FOR
SET EFF=$ORDER(@(ROOT_+IEN_",66,""B"","""_EFF_""")"),-1)
IF (EFF'?7N)!($LENGTH(ACT))
QUIT
Begin DoDot:1
+19 SET HIS=" "
FOR
SET HIS=$ORDER(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1)
IF +HIS'>0
QUIT
Begin DoDot:2
+20 NEW NOD,STA
SET NOD=$GET(@(ROOT_+IEN_",66,"_+HIS_",0)"))
+21 SET STA=$PIECE(NOD,"^",2)
IF STA?1N&(+STA>0)&('$LENGTH(ACT))
SET ACT=EFF
End DoDot:2
IF $LENGTH(ACT)
QUIT
End DoDot:1
IF $LENGTH(ACT)
QUIT
+22 IF '$LENGTH(ACT)
SET ACT="-1^Not activated on or before "_$$FMTE^XLFDT($GET(CDT),"5DZ")
+23 QUIT ACT
LI(FILE,IEN,CDT) ; Last Current Inactivation Date
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number (Required)
+5 ; FILE Global Root/File Number (Required)
+6 ; CDT Date (default = TODAY) (Optional)
+7 ;
+8 ; Output:
+9 ;
+10 ; $$LI Last Current Inactivation Date OR -1 ^ Error Message
+11 ;
+12 NEW ROOT,EFF,HIS,NOD,ACT,INA
+13 SET FILE=$$FILE($GET(FILE))
IF +FILE'>0
QUIT "-12^Invalid File"
SET ROOT=$$ROOT(FILE)
+14 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
QUIT "-1^Invalid Global"
+15 SET CDT=$GET(CDT)
IF CDT'?7N
SET CDT=$$DT^XLFDT
SET IEN=$GET(IEN)
+16 IF +IEN'>0!('$DATA(@(ROOT_+IEN_")")))
QUIT "-1^Invalid Code"
+17 SET INA=""
SET EFF=CDT+.000001
+18 FOR
SET EFF=$ORDER(@(ROOT_+IEN_",66,""B"","""_EFF_""")"),-1)
IF '$LENGTH(EFF)!(EFF'?7N)!($LENGTH(INA))
QUIT
Begin DoDot:1
+19 SET HIS=" "
FOR
SET HIS=$ORDER(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1)
IF +HIS'>0
QUIT
Begin DoDot:2
+20 NEW NOD,STA
SET NOD=$GET(@(ROOT_+IEN_",66,"_+HIS_",0)"))
+21 SET STA=$PIECE(NOD,"^",2)
IF STA?1N&(+STA'>0)&('$LENGTH(INA))
SET INA=EFF
End DoDot:2
IF $LENGTH(INA)
QUIT
End DoDot:1
IF $LENGTH(INA)
QUIT
+22 IF '$LENGTH(INA)
SET INA="-1^Not inactivated on or before "_$$FMTE^XLFDT($GET(CDT),"5DZ")
+23 QUIT INA
LS(FILE,IEN,CDT,FMT) ; Last Status
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE Global Root/File Number (Required)
+5 ; IEN Internal Entry Number (Required)
+6 ; CDT Date (default = TODAY) (Optional)
+7 ; FMT Format
+8 ; 0 Last Status only (default)
+9 ; 1 Last Status ^ Effective Date
+10 ;
+11 ; Output:
+12 ;
+13 ; $$LS Last Status (1/0) OR -1 ^ Error Message
+14 ;
+15 NEW ROOT,EFF,HIS,NOD,ACT,INA,LEF,STA
+16 SET FILE=$$FILE($GET(FILE))
IF +FILE'>0
QUIT "-12^Invalid File"
SET ROOT=$$ROOT(FILE)
+17 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
QUIT "-1^Invalid Global"
+18 SET CDT=$GET(CDT)
IF CDT'?7N
SET CDT=$$DT^XLFDT
SET IEN=$GET(IEN)
+19 IF +IEN'>0!('$DATA(@(ROOT_+IEN_")")))
QUIT "-1^Invalid Code"
+20 SET INA=""
SET EFF=CDT+.000001
SET EFF=$ORDER(@(ROOT_+IEN_",66,""B"","""_EFF_""")"),-1)
+21 IF '$LENGTH(EFF)!(EFF'?7N)
QUIT "-1^No status on or before "_$$FMTE^XLFDT($GET(CDT),"5DZ")
+22 SET HIS="~"
SET HIS=$ORDER(@(ROOT_+IEN_",66,""B"","_EFF_","""_HIS_""")"),-1)
+23 IF +HIS'>0
QUIT "-1^No status on or before "_$$FMTE^XLFDT($GET(CDT),"5DZ")
+24 SET NOD=$GET(@(ROOT_+IEN_",66,"_+HIS_",0)"))
SET STA=$PIECE(NOD,"^",2)
SET LEF=$PIECE(NOD,"^",1)
+25 IF "^0^1^"'[("^"_STA_"^")
QUIT "-1^No status on or before "_$$FMTE^XLFDT($GET(CDT),"5DZ")
+26 IF +($GET(FMT))>0&($GET(LEF)?7N)
SET STA=STA_"^"_LEF
+27 QUIT STA
+28 ;
NUM(CODE) ; Convert Code to a Numeric Value (opposite of $$COD)
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD CODE (required)
+5 ;
+6 ; Output:
+7 ;
+8 ; NUM Numerical representation of CODE
+9 ;
+10 ; or
+11 ;
+12 ; -1 on error
+13 ;
+14 SET CODE=$GET(CODE)
IF '$LENGTH($GET(CODE))
QUIT 0
+15 NEW PSN,OUT,CHR,ERR
SET ERR=0
SET OUT=""
FOR PSN=1:1:9
Begin DoDot:1
+16 SET CHR=$EXTRACT(CODE,PSN)
SET CHR=$SELECT($LENGTH(CHR):$ASCII(CHR),1:32)
SET CHR=CHR-30
+17 IF CHR'>0
SET ERR=1
FOR
IF $LENGTH(CHR)>1
QUIT
SET CHR="0"_CHR
+18 IF $LENGTH(CHR)'=2
SET ERR=1
SET OUT=OUT_CHR
End DoDot:1
+19 IF ERR
QUIT -1
IF +OUT>0
SET OUT="1"_OUT
+20 QUIT OUT
COD(NUM) ; Convert Numeric Value to a Code (opposite of $$NUM)
+1 ;
+2 ; Input:
+3 ;
+4 ; NUM Numerical representation of an ICD Code (required)
+5 ;
+6 ; Output:
+7 ;
+8 ; CODE ICD Code
+9 ;
+10 ; or
+11 ;
+12 ; null on error
+13 ;
+14 IF '$LENGTH(NUM)
QUIT ""
IF $EXTRACT(NUM,1)'=1
QUIT ""
SET NUM=$EXTRACT(NUM,2,$LENGTH(NUM))
+15 NEW PSN,OUT,CHR,ADD
SET OUT=""
+16 FOR PSN=1:2
SET CHR=$EXTRACT(NUM,PSN,(PSN+1))
IF '$LENGTH(CHR)
QUIT
Begin DoDot:1
+17 SET CHR=+CHR+30
SET ADD=""
IF CHR'=32
SET ADD=$CHAR(CHR)
IF $LENGTH(ADD)
SET OUT=OUT_ADD
End DoDot:1
+18 QUIT OUT
IE(X) ; Internal or External
+1 ;
+2 ; Input:
+3 ;
+4 ; X ICD code or IEN
+5 ;
+6 ; Output:
+7 ;
+8 ; $$IE Set of Codes
+9 ;
+10 ; I X is in an internal format (IEN)
+11 ; E X is in an external format (Code)
+12 ;
+13 ; Null on error
+14 ;
+15 NEW IN,OUT
+16 SET IN=$GET(X)
IF '$LENGTH(X)
QUIT ""
+17 IF IN?1N.N&('$DATA(^ICD9("BA",(IN_" "))))&('$DATA(^ICD0("BA",(IN_" "))))
QUIT "I"
+18 IF $DATA(^ICD9("BA",(IN_" ")))!($DATA(^ICD0("BA",(IN_" "))))
QUIT "E"
+19 QUIT ""
FILE(X) ; File Number
+1 ;
+2 ; Input:
+3 ;
+4 ; X File/Identifier/Coding System/Code (required)
+5 ;
+6 ; Output:
+7 ;
+8 ; FILE File Number or -1 on error
+9 ;
+10 NEW ICDX,ICDF
SET (ICDX,X)=$GET(X)
IF '$LENGTH(X)
QUIT -1
NEW ICDR
+11 IF X?1N.N
IF X?1N&(+X=0)
QUIT 80.1
IF X?1N&(+X=9)
QUIT 80
+12 ;S ICDR=$$ROOT(X) Q:$D(^ICD9("BA",(X_" "))) 80 Q:$D(^ICD0("BA",(X_" "))) 80.1 ;IHS/OIT/FBD&NKD - ICDR LAST (OPT)
+13 IF $DATA(^ICD9("BA",(X_" ")))
QUIT 80
IF $DATA(^ICD0("BA",(X_" ")))
QUIT 80.1
+14 IF X=80
QUIT 80
IF X=80.1
QUIT 80.1
IF X["ICD9"
QUIT 80
IF X["ICD0"
QUIT 80.1
IF X["DX"!(X["DIAG")
QUIT 80
IF X["PR"!(X["PROC")!(X["OP")!(X["PCS")
QUIT 80.1
+15 IF ICDX?1N.N
IF ICDX'["."
IF $DATA(^ICD9("ABA",+ICDX))
QUIT 80
IF $DATA(^ICD0("ABA",+ICDX))
QUIT 80.1
+16 IF $DATA(^ICD9("BA",(X_" ")))
QUIT 80
IF $DATA(^ICD0("BA",(X_" ")))
QUIT 80.1
+17 IF $DATA(^ICD9("AVA",(X_" ")))
QUIT 80
IF $DATA(^ICD0("AVA",(X_" ")))
QUIT 80.1
+18 IF $DATA(^ICD9("AEXC",(X_" ")))
QUIT 80
IF $DATA(^ICD0("AEXC",(X_" ")))
QUIT 80.1
+19 ;Q:ICDR["ICD9" 80 Q:ICDR["ICD0" 80.1 ;IHS/OIT/FBD&NKD - ICDR LAST (OPT)
+20 SET ICDR=$$ROOT(X)
IF ICDR["ICD9"
QUIT 80
IF ICDR["ICD0"
QUIT 80.1
+21 QUIT -1
ROOT(X) ; Global Root
+1 ;
+2 ; Input:
+3 ;
+4 ; X File Number, File Name, Root, Identifier
+5 ; or Coding System (required)
+6 ;
+7 ; Output:
+8 ;
+9 ; ROOT Global Root for File or null
+10 ;
+11 ;N ICDR,ICDF S ICDR=$$RY($G(X)) Q:$L(ICDR) ICDR ;IHS/OIT/FBD&NKD - REORDER (OPT)
+12 NEW ICDR,ICDF
SET (ICDR,X)=$GET(X)
IF '$LENGTH(X)
QUIT ""
IF "^ICD9(^ICD0(^"[("^"_$EXTRACT(ICDR,2,$LENGTH(ICDR))_"^")
QUIT "^"_$EXTRACT(ICDR,2,$LENGTH(ICDR))
SET ICDR=$$RF($GET(X))
IF $LENGTH(ICDR)
QUIT ICDR
+13 SET ICDR=$$RY($GET(X))
IF $LENGTH(ICDR)
QUIT ICDR
+14 SET ICDR=$$RC($GET(X))
IF $LENGTH(ICDR)
QUIT ICDR
SET X=$$UP^XLFSTR($GET(X))
+15 ;S ICDR=$$RF($G(X)) Q:$L(ICDR) ICDR ;IHS/OIT/FBD&NKD - REORDER (OPT)
+16 SET ICDR=$$RR($GET(X))
IF $LENGTH(ICDR)
QUIT ICDR
+17 IF X?1N.N
SET ICDR=$$RS(+($GET(X)))
IF $LENGTH(ICDR)
QUIT ICDR
+18 QUIT ""
RY(SYS) ; Global Root from System
+1 NEW FILE,ROOT
SET SYS=$GET(SYS)
IF SYS'?1N.N
QUIT ""
IF SYS=80!(SYS=80.1)
QUIT ""
IF '$DATA(^ICDS(+SYS))
QUIT ""
+2 SET FILE=$PIECE($GET(^ICDS(+SYS,0)),"^",3)
IF +FILE'>0
QUIT ""
SET ROOT=$$RF(FILE)
IF $LENGTH(ROOT)
QUIT ROOT
+3 QUIT ""
RF(FILE) ; Global Root from File
+1 IF $GET(FILE)=80
QUIT "^ICD9("
IF $GET(FILE)=80.1
QUIT "^ICD0("
+2 QUIT ""
RR(ID) ; Global Root from Root or Identifier
+1 IF ID["ICD9"
QUIT "^ICD9("
IF ID["ICD0"
QUIT "^ICD0("
IF ID="DX"!(ID["DIA")
QUIT "^ICD9("
IF ID="PR"!(ID["PRO")!(ID["OP")
QUIT "^ICD0("
+2 IF ID="ICD"!(ID="10D")
QUIT "^ICD9("
IF ID="ICP"!(ID="10P")
QUIT "^ICD0("
+3 QUIT ""
RS(SYS) ; Global Root from Coding System
+1 SET SYS=$TRANSLATE(SYS," ","")
IF $DATA(^ICD9("ABA",+SYS))
QUIT "^ICD9("
IF $DATA(^ICD0("ABA",+SYS))
QUIT "^ICD0("
+2 QUIT ""
RC(COD) ; Global Root from Code
+1 IF $DATA(^ICD9("BA",($GET(COD)_" ")))
QUIT "^ICD9("
IF $DATA(^ICD0("BA",($GET(COD)_" ")))
QUIT "^ICD0("
+2 IF $DATA(^ICD9("AVA",(X_" ")))
QUIT "^ICD9("
IF $DATA(^ICD0("AVA",(X_" ")))
QUIT "^ICD0("
+3 IF $DATA(^ICD9("AEXC",(X_" ")))
QUIT "^ICD9("
IF $DATA(^ICD0("AEXC",(X_" ")))
QUIT "^ICD0("
+4 QUIT ""
+5 ;
SYS(SYS,CDT,FMT) ; Resolve System (uses file 80.4)
+1 ;
+2 ; Input:
+3 ;
+4 ; SYS System/Source Abbreviation/System Identifier/Code
+5 ; CDT Date (optional)
+6 ; FMT Output Format (optional)
+7 ;
+8 ; I Internal (default)
+9 ; E External
+10 ; B Both Internal ^ External
+11 ;
+12 ; Output:
+13 ;
+14 ; $$SYS System (numeric or alpha)
+15 ;
+16 ; Internal External
+17 ; 1 ICD-9-CM
+18 ; 2 ICD-9 Proc
+19 ; 30 ICD-10-CM
+20 ; 31 ICD-10-PCS
+21 ;
+22 ; or
+23 ; -1 on error
+24 ;
+25 NEW ICDC,ICDD,ICDF,ICDI,ICDO,ICDT,ICDU,ICDX,ICDT
SET ICDI=$GET(SYS)
IF '$LENGTH(ICDI)
QUIT -1
+26 SET ICDD=$PIECE($GET(CDT),".",1)
SET ICDF=$$UP^XLFSTR($GET(FMT))
IF '$LENGTH(ICDF)
SET ICDF="I"
+27 IF "^E^B^"'[("^"_ICDF_"^")
SET ICDF="I"
SET ICDU=$$UP^XLFSTR(ICDI)
+28 ;IHS/OIT/FBD&NKD - REORDER (OPT)
IF ICDI?1N.N
IF +ICDI=ICDI
IF $DATA(^ICDS(+ICDI))
QUIT $SELECT(ICDF["B":(+ICDI_"^"_$$SNAM(+ICDI)),ICDF["E":$$SNAM(+ICDI),1:+ICDI)
+29 SET ICDO=$$SC(ICDI)
IF +ICDO>0
QUIT $SELECT(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
+30 ;I ICDI?1N.N Q:$D(^ICDS(+ICDI)) $S(ICDF["B":(+ICDI_"^"_$$SNAM(+ICDI)),ICDF["E":$$SNAM(+ICDI),1:+ICDI) ;IHS/OIT/FBD&NKD - REORDER (OPT)
+31 SET ICDO=$$SS(ICDI)
IF +ICDO>0
QUIT $SELECT(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
+32 SET ICDO=$$SM(ICDI,ICDD)
IF +ICDO>0
QUIT $SELECT(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
+33 SET ICDO=$$SP(ICDI)
IF +ICDO>0
QUIT $SELECT(ICDF["B":(+ICDO_"^"_$$SNAM(+ICDO)),ICDF["E":$$SNAM(+ICDO),1:+ICDO)
+34 QUIT -1
SS(X) ; System from Coding System file 80.4
+1 NEW ICDC,ICDI,ICDO,ICDU
SET ICDI=$GET(X)
IF '$LENGTH(ICDI)
QUIT ""
SET ICDU=$$UP^XLFSTR(ICDI)
+2 SET ICDO=""
SET ICDC="AZ"
FOR
SET ICDC=$ORDER(^ICDS(ICDC))
IF '$LENGTH(ICDC)
QUIT
Begin DoDot:1
+3 IF ICDC="F"
QUIT
NEW ICDT
SET ICDT=$ORDER(^ICDS(ICDC,ICDI,0))
+4 IF +ICDT'>0
SET ICDT=$ORDER(^ICDS(ICDC,ICDU,0))
IF +ICDT>0
SET ICDO=ICDT
End DoDot:1
IF +ICDO>0
QUIT
+5 QUIT ICDO
SM(X,CDT) ; System from a Mnemonic
+1 NEW ICDD,ICDX,ICDO,ICDU
SET ICDU=$$UP^XLFSTR($GET(X))
IF '$LENGTH(ICDU)
QUIT ""
SET ICDD=$GET(CDT)
IF ICDD'?7N
SET ICDD=$$DT^XLFDT
+2 SET ICDX=$PIECE($GET(^ICDS(30,0)),"^",4)
SET ICDO=""
+3 IF (ICDU["DIAG"!(ICDU["ICD9")!(ICDU="80")!(ICDU="DX"))
IF ICDD?7N
IF ICDX?7N
SET ICDO=$SELECT(ICDD<ICDX:1,1:30)
+4 IF (ICDU["PROC"!(ICDU["OPER")!(ICDU["ICD0")!(ICDU["ICP9")!(ICDU="80.1")!(ICDU="PR"))
IF ICDD?7N
IF ICDX?7N
SET ICDO=$SELECT(ICDD<ICDX:2,1:31)
+5 QUIT ICDO
SP(X) ; System from Pattern Match
+1 NEW ICDT,ICDI,ICDO
SET ICDO=""
SET ICDT=$$UP^XLFSTR($GET(X))
IF '$LENGTH(ICDT)
QUIT ""
+2 FOR
IF ICDT'["ICD"
QUIT
SET ICDT=$PIECE(ICDT,"ICD",1)_$PIECE(ICDT,"ICD",2)
+3 IF '$LENGTH(ICDT)
QUIT ""
SET ICDI=""
FOR
SET ICDI=$ORDER(^ICDS("B",ICDI))
IF '$LENGTH(ICDI)
QUIT
Begin DoDot:1
+4 IF ICDT["9"&(ICDT["D")&(ICDT'["P")&(ICDI["9")&(ICDI["CM")
SET ICDO=$ORDER(^ICDS("B",ICDI,0))
IF ICDO>0
QUIT
+5 IF ICDT["9"&((ICDT["P")!(ICDT["O"))&(ICDI["9")&(ICDI["P")
SET ICDO=$ORDER(^ICDS("B",ICDI,0))
IF ICDO>0
QUIT
+6 IF ICDT["10"&(ICDT["D")&(ICDT'["P")&(ICDI["10")&(ICDI["CM")
SET ICDO=$ORDER(^ICDS("B",ICDI,0))
IF ICDO>0
QUIT
+7 IF ICDT["10"&((ICDT["P")!(ICDT["O"))&(ICDI["10")&(ICDI["P")
SET ICDO=$ORDER(^ICDS("B",ICDI,0))
IF ICDO>0
QUIT
End DoDot:1
IF +ICDO>0
QUIT
+8 QUIT ICDO
SC(X) ; System from Code
+1 NEW ICDI,ICDC,ICDO,ICDR,ICDU
SET ICDI=$GET(X)
SET ICDC=$TRANSLATE(ICDI," ","")
IF '$LENGTH(ICDC)
QUIT ""
+2 SET ICDU=$$UP^XLFSTR(ICDC)
SET ICDO=""
FOR ICDR="^ICD9(","^ICD0("
Begin DoDot:1
+3 NEW TMP
FOR TMP=ICDC,ICDU
Begin DoDot:2
+4 NEW ICDS,ICDV,ICDE
SET ICDS=0
FOR
SET ICDS=$ORDER(@(ICDR_"""ABA"","_ICDS_")"))
IF +ICDS'>0
QUIT
Begin DoDot:3
+5 IF $DATA(@(ICDR_"""ABA"","_ICDS_","""_TMP_" "")"))
SET ICDO=ICDS
End DoDot:3
IF ICDO>0
QUIT
+6 IF ICDO>0
QUIT
SET ICDV=$ORDER(@(ICDR_"""AVA"","""_TMP_" "",0)"))
+7 IF +ICDV>0
SET ICDO=$PIECE($GET(@(ICDR_+ICDV_",1)")),"^",1)
IF ICDO>0
QUIT
+8 SET ICDE=$ORDER(@(ICDR_"""AEXC"","""_TMP_" "",0)"))
+9 IF +ICDE>0
SET ICDO=$PIECE($GET(@(ICDR_+ICDE_",1)")),"^",1)
IF ICDO>0
QUIT
End DoDot:2
IF +ICDO>0
QUIT
End DoDot:1
IF +ICDO>0
QUIT
+10 QUIT ICDO
SINFO(SYS,CDT) ; System Info (uses file 80.4)
+1 ;
+2 ; Input:
+3 ;
+4 ; SYS System/Source Abbreviation/System Identifier/Code
+5 ; CDT Date (optional)
+6 ;
+7 ; Output:
+8 ;
+9 ; $$SINFO System Info (numeric or alpha)
+10 ;
+11 ; Internal External
+12 ; 1 IEN to file 80.4
+13 ; 2 Coding System
+14 ; 3 Coding System Nomenclature
+15 ; 4 Coding system Abbreviation
+16 ; 5 File where the Coding System is stored
+17 ; 6 Implementation Date
+18 ;
+19 ; or
+20 ; -1 on error
+21 ;
+22 NEW ICDD,ICDS,ICDN,ICDT
+23 SET ICDD=$SELECT($GET(CDT)'?7N:$$DT^XLFDT,1:$GET(CDT))
+24 SET ICDS=$$SYS($GET(SYS),ICDD,"I")
+25 IF +ICDS'>0
QUIT "-1^Coding System Unknown"
+26 SET ICDN=$GET(^ICDS(+ICDS,0))
IF '$LENGTH(ICDN)
QUIT "-1^Coding System not found"
+27 SET ICDT=$SELECT($PIECE(ICDN,"^",3)=80:"Diagnosis",$PIECE(ICDN,"^",3)=80.1:"Procedure",1:"")
+28 SET SYS=ICDS_"^"_ICDN
IF $LENGTH(ICDT)
SET SYS=SYS_"^"_ICDT
+29 QUIT SYS
SNAM(SYS) ; System Name
+1 ;
+2 ; Input:
+3 ;
+4 ; SYS Numeric System Identifier (field 1.1)
+5 ;
+6 ; Output:
+7 ;
+8 ; $$SYS Character System Name
+9 ;
+10 ; or -1 on error
+11 ;
+12 SET SYS=+($GET(SYS))
SET SYS=$PIECE($GET(^ICDS(+SYS,0)),"^",1)
+13 QUIT $SELECT($LENGTH(SYS):SYS,1:-1)
SAB(X,Y) ; Source Abbreviation
+1 ;
+2 ; Input:
+3 ;
+4 ; X Source Abbreviation or Identifier
+5 ; Y Date used to determine SAB
+6 ;
+7 ; Output:
+8 ;
+9 ; $$SAB 3 Character System Identifier
+10 ;
+11 NEW SYS,CDT,TY,VR,OUT,TMP,ICD10
SET SYS=$GET(X)
SET CDT=$GET(Y)
+12 IF CDT'?7N
SET CDT=$$DT^XLFDT
SET ICD10=+($$IMP^ICDEX(30))
+13 SET TMP=$$SYS(SYS,CDT)
IF +TMP>0&($DATA(^ICDS(+TMP,0)))
SET SYS=TMP
+14 IF +SYS=1
QUIT "ICD"
IF +SYS=2
QUIT "ICP"
IF +SYS=30
QUIT "10D"
IF +SYS=31
QUIT "10P"
+15 IF SYS="DIAG"
QUIT $SELECT(CDT'<ICD10:"10D",1:"ICD")
+16 IF SYS["ICD9"
QUIT $SELECT(CDT'<ICD10:"10D",1:"ICD")
+17 IF SYS="PROC"
QUIT $SELECT(CDT'<ICD10:"10P",1:"ICP")
+18 IF SYS["ICD0"
QUIT $SELECT(CDT'<ICD10:"10P",1:"ICP")
+19 IF "^ICD^ICP^10D^10P^"[("^"_SYS_"^")
QUIT SYS
+20 QUIT ""
EXC(FILE,IEN) ; Exclude From lookup
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File number 80 or 80.1
+5 ; IEN Internal Entry Number
+6 ;
+7 ; Output:
+8 ;
+9 ; $$EXC Boolean value 1 = Yes 0 = No
+10 ;
+11 NEW ICDF,ICDI,ICDR
SET ICDF=+($GET(FILE))
SET ICDI=+($GET(IEN))
IF "^80^80.1^"'[("^"_ICDF_"^")
QUIT 0
+12 SET ICDR=$$ROOT(ICDF)
IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ICDR,2,$LENGTH(ICDR))_"^")
QUIT 0
IF '$DATA(@(ICDR_+ICDI_",0)"))
QUIT 0
+13 QUIT $SELECT(+($$GET1^DIQ(ICDF,(+ICDI_","),1.8))'>0:0,1:1)
