ICDEXC2 ;SLC/KER - ICD Extractor - Code APIs (cont) ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
;
; Global Variables
; ^ICD0("BA") N/A
; ^ICD0("ABA") N/A
; ^ICD9("BA") N/A
; ^ICD9("ABA") N/A
; ^ICDS( N/A
;
; External References
; $$DT^XLFDT ICR 10103
; $$GET1^DIQ ICR 2056
; $$UP^XLFSTR ICR 10104
;
Q
CODEFI(CODE) ; Return file where code is found (exact match)
;
; Input:
;
; CODE ICD code (required)
;
; Output:
;
; FILE File Number
; 80 = ICD Dx file
; 80.1 = ICD Oper/Proc file
; Null
;
N ICDU,ICDO,ICDT S CODE=$G(CODE) Q:'$L(CODE) "" S ICDU=$$UP^XLFSTR(CODE)
S ICDO=0 F ICDT=CODE,ICDU D Q:+ICDO>0
. S:$O(^ICD9("BA",(ICDT_" "),0))>0&($O(^ICD0("BA",(ICDT_" "),0))'>0) ICDO=80
. S:$O(^ICD0("BA",(ICDT_" "),0))>0&($O(^ICD9("BA",(ICDT_" "),0))'>0) ICDO=80.1
. S:$O(^ICD9("BA",(ICDT_" "),0))>0 ICDO=80
. S:$O(^ICD0("BA",(ICDT_" "),0))>0 ICDO=80.1
Q $S(ICDO>0:ICDO,1:"")
CODECS(CODE,FILE,CDT) ; Return coding system where code is found (exact match)
;
; Input:
;
; CODE ICD code/IEN (required)
; FILE File Number (required)
; 80 = ICD Dx file
; 80.1 = ICD Oper/Proc file
; CDT Date used to determine Coding
; System (optional, default TODAY)
;
; Output:
;
; SYS 2 piece ^ delimited string
; 1 Coding System
; 2 Coding Nomenclature
;
; 1 ^ ICD-9-CM
; 2 ^ ICD-9 Proc
; 30 ^ ICD-10-CM
; 31 ^ ICD-10-PCS
;
; or null if not found
;
N ICDFI,ICDCS,ICDT,ICDID,ICD10,ICDU,ICDC S CODE=$TR($G(CODE)," ",""),ICDCS="",ICD10=+($$IMP^ICDEX(30)) Q:'$L(CODE) ""
S ICDU=$$UP^XLFSTR(CODE),ICDFI=+($G(FILE)) S:"^80^80.1^"'[("^"_$G(ICDFI)_"^") ICDFI=+($$CODEFI(CODE))
S ICDT=$G(CDT) S:ICDT'?7N ICDT=$$DT^XLFDT F ICDID=(CODE_" "),(ICDU_" ") D Q:$L(ICDCS)
. I ICDFI=80 D Q:$L(ICDCS)
. . I $O(^ICD9("ABA",1,ICDID,0))>0,$O(^ICD9("ABA",30,ICDID,0))'>0 S ICDCS="1^ICD-9-CM" Q
. . I $O(^ICD9("ABA",30,ICDID,0))>0,$O(^ICD9("ABA",1,ICDID,0))'>0 S ICDCS="30^ICD-10-CM" Q
. . I $O(^ICD9("ABA",30,ICDID,0))>0,$O(^ICD9("ABA",1,ICDID,0))>0,ICDT<ICD10 S ICDCS="1^ICD-9-CM" Q
. . I $O(^ICD9("ABA",30,ICDID,0))>0,$O(^ICD9("ABA",1,ICDID,0))>0,ICDT'<ICD10 S ICDCS="30^ICD-10-CM" Q
. . Q S:ICDT<ICD10 ICDCS="1^ICD-9-CM" S:ICDT'<ICD10 ICDCS="30^ICD-10-CM"
. I ICDFI=80.1 D Q:$L(ICDCS)
. . I $O(^ICD0("ABA",2,ICDID,0))>0,$O(^ICD0("ABA",31,ICDID,0))'>0 S ICDCS="2^ICD-9 Proc" Q
. . I $O(^ICD0("ABA",31,ICDID,0))>0,$O(^ICD0("ABA",2,ICDID,0))'>0 S ICDCS="31^ICD-10-PCS" Q
. . I $O(^ICD0("ABA",31,ICDID,0))>0,$O(^ICD0("ABA",2,ICDID,0))>0,ICDT<ICD10 S ICDCS="2^ICD-9 Proc" Q
. . I $O(^ICD0("ABA",31,ICDID,0))>0,$O(^ICD0("ABA",2,ICDID,0))>0,ICDT'<ICD10 S ICDCS="31^ICD-10-PCS" Q
. . Q S:ICDT<ICD10 ICDCS="2^ICD-9 Proc" S:ICDT'<ICD10 ICDCS="31^ICD-10-PCS"
Q:$L(ICDCS) ICDCS
Q ""
CSI(FILE,IEN) ; Coding System for file and IEN
;
; Input:
;
; FILE File Number (required)
; IEN IEN in file 80/80.1 (required)
;
; Output:
;
; $$CSI Coding System (pointer to file 80.4)
; or null if not found
;
N ICDI,ICDRT,ICDCS S ICDRT=$$ROOT^ICDEX(+($G(FILE))) Q:'$L(ICDRT) ""
S ICDI=+($G(IEN)) Q:+ICDI'>0 "" S ICDCS=+($P($G(@(ICDRT_+ICDI_",1)")),"^",1)) Q:+ICDCS'>0 ""
Q ICDCS
VMDC(IEN,CDT,FMT) ; Versioned Major Diagnostic Category
;
; Input:
;
; IEN IEN in file 80 (required)
; CDT Date to use to Extract MDC (default TODAY)
; FMT Output Format
; 0 = MDC only (default)
; 1 = MDC ^ Effective Date
;
; Output:
;
; MDC Major Diagnostic Category
;
N MDC,DRGFY,ICDY,ICDD,ICDM,ICDOUT Q:+($G(IEN))'>0 "" S FMT=+($G(FMT)) S:FMT'=1 FMT=0
S ICDY=$P($G(^ICD9(IEN,1)),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
S (MDC,DRGFY)="" S DRGFY=$O(^ICD9(+($G(IEN)),4,"B",(CDT+.001)),-1),MDC=$O(^ICD9(+($G(IEN)),4,"B",+DRGFY,MDC))
S ICDOUT=$P($G(^ICD9(+($G(IEN)),4,+MDC,0)),U,2) S:FMT>0 ICDOUT=ICDOUT_"^"_$P($G(^ICD9(+($G(IEN)),4,+MDC,0)),U,1)
Q ICDOUT
VSEX(FILE,IEN,CDT,FMT) ; Versioned Sex
;
; Input:
;
; FILE File
; 80 ICD Diagnosis file
; 80.1 ICD Operation/Procedure file
; IEN IEN (required)
; CDT Date to use to Extract Sex (default TODAY)
; FMT Output Format
; 0 = Sex only (default)
; 1 = Sex ^ Effective Date
;
; Output:
;
; SEX Sex
; M Male
; F Female
; Null
;
N ICDI,ICDR,ICDN,ICDD,ICDE,ICDS,ICDY,ICDOUT S ICDI=+($G(IEN)) Q:+ICDI'>0 ""
S FMT=+($G(FMT)) S:FMT'=1 FMT=0 S ICDR=$$ROOT^ICDEX($G(FILE)) Q:'$L(ICDR) ""
S ICDN=$S(ICDR="^ICD9(":5,ICDR="^ICD0(":3,1:"") Q:+ICDN'>0 ""
S ICDY=$P($G(@(ICDR_+ICDI_",1)")),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
S ICDE=$O(@(ICDR_ICDI_","_ICDN_",""B"","_(CDT+.001)_")"),-1) Q:ICDE'?7N ""
S ICDS=$O(@(ICDR_ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0 ""
S ICDS=$G(@(ICDR_ICDI_","_ICDN_","_ICDS_",0)"))
Q:'$L(ICDS) ""
S ICDD=$P(ICDS,"^",1),ICDS=$P(ICDS,"^",2) Q:"^M^F^"'[("^"_ICDS_"^") ""
S ICDOUT=ICDS S:FMT>0 ICDOUT=ICDOUT_"^"_ICDD
Q ICDOUT
SAI(FILE,IEN,CDT) ; Status/Activation/Inactivation
;
; Input:
;
; FILE File
; 80 ICD Diagnosis file
; 80.1 ICD Operation/Procedure file
; IEN IEN or code (required)
; CDT Date to use to Extract Status (default TODAY)
;
; Output:
;
; 5 piece "^" delimited string
;
; 1 Status
; 2 Activation Date
; 3 Inactivation Date
; 4 IEN
; 5 Code
; 6 Short Text
;
; If the status is active, the short
; text will be the most recent.
;
; If the status is inactive, the short
; text will be the text in use on the
; date it was inactivated.
;
; Null if no status for date.
;
N ICDI,ICDCD,ICDR,ICDN,ICDE,ICDS,ICDY,EFF,ACT,STA,INA,NAM S ICDI=$G(IEN) Q:'$L(ICDI)
S ICDR=$$ROOT^ICDEX($G(FILE)) Q:'$L(ICDR) ""
S ICDCD=$$CODEC^ICDEX(FILE,ICDI)
I '$D(@(ICDR_ICDI_",1)")) D
. N ICDE S ICDE=0 F S ICDE=$O(^ICDS(ICDE)) Q:+ICDE'>0 D
. . N ICDT S ICDT=$O(@(ICDR_"""ABA"","_+ICDE_","""_(ICDI_" ")_""",0)")) Q:ICDT'>0
. . S:ICDT?1N.N&(ICDI'?1N.N) ICDI=ICDT
S ICDY=$P($G(@(ICDR_+ICDI_",1)")),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:CDT) Q:CDT'?7N ""
S ICDE=$O(@(ICDR_ICDI_",66,""B"","_(CDT+.001)_")"),-1) Q:ICDE'?7N ""
S ICDS=$O(@(ICDR_ICDI_",66,""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0 ""
S ICDS=$G(@(ICDR_ICDI_",66,"_ICDS_",0)")) Q:'$L(ICDS) ""
S (ACT,INA,NAM)="" S EFF=$P(ICDS,"^",1),STA=$P(ICDS,"^",2)
S:STA>0 ACT=EFF S:STA'>0 INA=EFF
I STA'>0,INA?7N D
. S ICDE=$O(@(ICDR_ICDI_",66,""B"","_INA_")"),-1) Q:ICDE'?7N
. S ICDS=$O(@(ICDR_ICDI_",66,""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0
. S ICDS=$G(@(ICDR_ICDI_",66,"_ICDS_",0)")) Q:'$L(ICDS)
. S:$P(ICDS,"^",2)>0&($P(ICDS,"^",1)?7N) ACT=$P(ICDS,"^",1)
I ACT?7N D
. S ICDE=$O(@(ICDR_ICDI_",67,""B"","_(9999999+.001)_")"),-1) Q:ICDE'?7N
. S ICDS=$O(@(ICDR_ICDI_",67,""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0
. S ICDS=$G(@(ICDR_ICDI_",67,"_ICDS_",0)")) Q:'$L(ICDS)
. S:$L($P(ICDS,"^",2))>0 NAM=$P(ICDS,"^",2)
S ICDS=+($G(STA)) S:$G(ACT)?7N $P(ICDS,"^",2)=$G(ACT)
S:$G(INA)?7N $P(ICDS,"^",3)=$G(INA)
S:ICDI?1N.N $P(ICDS,"^",4)=ICDI
S:$L(ICDCD) $P(ICDS,"^",5)=ICDCD
S:$L(NAM) $P(ICDS,"^",6)=NAM
Q ICDS
VAGEL(IEN,CDT,FMT) ; Versioned Age Low
;
; Input:
;
; IEN IEN in file 80 (required)
; CDT Date to use to Extract Age Low (default TODAY)
; FMT Output Format
; 0 = Age Low only (default)
; 1 = Age Low ^ Effective Date
;
; Output:
;
; AGEL Age Low
;
N AGEL,DRGFY,ICDY,ICDOUT Q:+($G(IEN))'>0 "" S FMT=+($G(FMT)) S:FMT'=1 FMT=0
S ICDY=$P($G(^ICD9(IEN,1)),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
S (AGEL,DRGFY)="" S DRGFY=$O(^ICD9(+($G(IEN)),6,"B",(CDT+.001)),-1),AGEL=$O(^ICD9(+($G(IEN)),6,"B",+DRGFY,AGEL))
S ICDOUT=$P($G(^ICD9(+($G(IEN)),6,+AGEL,0)),U,2) S:FMT>0 ICDOUT=ICDOUT_"^"_$P($G(^ICD9(+($G(IEN)),6,+AGEL,0)),U,1)
Q ICDOUT
VAGEH(IEN,CDT,FMT) ; Versioned Age High
;
; Input:
;
; IEN IEN in file 80 (required)
; CDT Date to use to Extract Age High (default TODAY)
; FMT Output Format
; 0 = Age High only (default)
; 1 = Age High ^ Effective Date
;
; Output:
;
; AGEH Age High
;
N AGEH,DRGFY,ICDY,ICDOUT Q:+($G(IEN))'>0 "" S FMT=+($G(FMT)) S:FMT'=1 FMT=0
S ICDY=$P($G(^ICD9(IEN,1)),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
S (AGEH,DRGFY)="" S DRGFY=$O(^ICD9(+($G(IEN)),7,"B",(CDT+.001)),-1),AGEH=$O(^ICD9(+($G(IEN)),7,"B",+DRGFY,AGEH))
S ICDOUT=$P($G(^ICD9(+($G(IEN)),7,+AGEH,0)),U,2) S:FMT>0 ICDOUT=ICDOUT_"^"_$P($G(^ICD9(+($G(IEN)),7,+AGEH,0)),U,1)
Q ICDOUT
VCC(IEN,CDT,FMT) ; Return versioned Complication/Comorbidity
;
; Input:
;
; IEN IEN in file 80 (required)
; CDT Date to use to Extract CC (default TODAY)
; FMT Output Format
; 0 = CC only (default)
; 1 = CC ^ Effective Date ^ External Value
;
; Output:
;
; $$VCC Complication/Comorbidity (FMT=0)
; Complication/Comorbidity^Effective Date (FMT=1)
;
N ICDD,ICDI,ICDIC,ICDIC,ICDO,ICDE,ICDF S ICDF=+($G(FMT)),ICDI=+($G(IEN))
S:ICDF'=1 ICDF=0 S ICDD=$O(^ICD9(ICDI,69,"B",CDT+.0001),-1) Q:'$L(ICDD) ""
S ICDIC=$O(^ICD9(ICDI,69,"B",ICDD,""),-1) S ICDE=""
S ICDO=$P(^ICD9(ICDI,69,ICDIC,0),U,2)
S ICDD=$P(^ICD9(ICDI,69,ICDIC,0),U,1)
S:ICDF>0&($L(ICDO)) ICDE=$$GET1^DIQ(80.0103,(ICDIC_","_ICDI_","),1)
S:ICDF>0&($L(ICDO)) $P(ICDO,"^",2)=ICDD
S:ICDF>0&($L(ICDO))&($L(ICDE)) $P(ICDO,"^",3)=ICDE
Q ICDO
VCCP(IEN,CDT,FMT) ; Return versioned CC Primary Flag
;
; Input:
;
; IEN IEN in file 80 (required)
; CDT Date to use to Extract CC Primary Flag (default TODAY)
; FMT Output Format
; 0 = CC Primary Flag only (default)
; 1 = CC Primary Flag ^ Effective Date ^ External Value
;
; Output:
;
; $$VCCP Complication/Comorbidity (FMT=0)
; Complication/Comorbidity^Effective Date (FMT=1)
;
N ICDD,ICDI,ICDIC,ICDIC,ICDO,ICDE,ICDF S ICDF=+($G(FMT)),ICDI=+($G(IEN))
S:ICDF'=1 ICDF=0 S ICDD=$O(^ICD9(ICDI,69,"B",CDT+.0001),-1) Q:'$L(ICDD) ""
S ICDIC=$O(^ICD9(ICDI,69,"B",ICDD,""),-1) S ICDE=""
S ICDO=$P(^ICD9(ICDI,69,ICDIC,0),U,3)
S ICDD=$P(^ICD9(ICDI,69,ICDIC,0),U,1)
S:ICDF>0&($L(ICDO)) ICDE=$$GET1^DIQ(80.0103,(ICDIC_","_ICDI_","),2)
S:ICDF>0&($L(ICDO)) $P(ICDO,"^",2)=ICDD
S:ICDF>0&($L(ICDO))&($L(ICDE)) $P(ICDO,"^",3)=ICDE
Q ICDO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXC2 11367 printed Sep 23, 2025@19:26:35 Page 2
ICDEXC2 ;SLC/KER - ICD Extractor - Code APIs (cont) ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^ICD0("BA") N/A
+5 ; ^ICD0("ABA") N/A
+6 ; ^ICD9("BA") N/A
+7 ; ^ICD9("ABA") N/A
+8 ; ^ICDS( N/A
+9 ;
+10 ; External References
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$GET1^DIQ ICR 2056
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
+15 QUIT
CODEFI(CODE) ; Return file where code is found (exact match)
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD code (required)
+5 ;
+6 ; Output:
+7 ;
+8 ; FILE File Number
+9 ; 80 = ICD Dx file
+10 ; 80.1 = ICD Oper/Proc file
+11 ; Null
+12 ;
+13 NEW ICDU,ICDO,ICDT
SET CODE=$GET(CODE)
if '$LENGTH(CODE)
QUIT ""
SET ICDU=$$UP^XLFSTR(CODE)
+14 SET ICDO=0
FOR ICDT=CODE,ICDU
Begin DoDot:1
+15 if $ORDER(^ICD9("BA",(ICDT_" "),0))>0&($ORDER(^ICD0("BA",(ICDT_" "),0))'>0)
SET ICDO=80
+16 if $ORDER(^ICD0("BA",(ICDT_" "),0))>0&($ORDER(^ICD9("BA",(ICDT_" "),0))'>0)
SET ICDO=80.1
+17 if $ORDER(^ICD9("BA",(ICDT_" "),0))>0
SET ICDO=80
+18 if $ORDER(^ICD0("BA",(ICDT_" "),0))>0
SET ICDO=80.1
End DoDot:1
if +ICDO>0
QUIT
+19 QUIT $SELECT(ICDO>0:ICDO,1:"")
CODECS(CODE,FILE,CDT) ; Return coding system where code is found (exact match)
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD code/IEN (required)
+5 ; FILE File Number (required)
+6 ; 80 = ICD Dx file
+7 ; 80.1 = ICD Oper/Proc file
+8 ; CDT Date used to determine Coding
+9 ; System (optional, default TODAY)
+10 ;
+11 ; Output:
+12 ;
+13 ; SYS 2 piece ^ delimited string
+14 ; 1 Coding System
+15 ; 2 Coding Nomenclature
+16 ;
+17 ; 1 ^ ICD-9-CM
+18 ; 2 ^ ICD-9 Proc
+19 ; 30 ^ ICD-10-CM
+20 ; 31 ^ ICD-10-PCS
+21 ;
+22 ; or null if not found
+23 ;
+24 NEW ICDFI,ICDCS,ICDT,ICDID,ICD10,ICDU,ICDC
SET CODE=$TRANSLATE($GET(CODE)," ","")
SET ICDCS=""
SET ICD10=+($$IMP^ICDEX(30))
if '$LENGTH(CODE)
QUIT ""
+25 SET ICDU=$$UP^XLFSTR(CODE)
SET ICDFI=+($GET(FILE))
if "^80^80.1^"'[("^"_$GET(ICDFI)_"^")
SET ICDFI=+($$CODEFI(CODE))
+26 SET ICDT=$GET(CDT)
if ICDT'?7N
SET ICDT=$$DT^XLFDT
FOR ICDID=(CODE_" "),(ICDU_" ")
Begin DoDot:1
+27 IF ICDFI=80
Begin DoDot:2
+28 IF $ORDER(^ICD9("ABA",1,ICDID,0))>0
IF $ORDER(^ICD9("ABA",30,ICDID,0))'>0
SET ICDCS="1^ICD-9-CM"
QUIT
+29 IF $ORDER(^ICD9("ABA",30,ICDID,0))>0
IF $ORDER(^ICD9("ABA",1,ICDID,0))'>0
SET ICDCS="30^ICD-10-CM"
QUIT
+30 IF $ORDER(^ICD9("ABA",30,ICDID,0))>0
IF $ORDER(^ICD9("ABA",1,ICDID,0))>0
IF ICDT<ICD10
SET ICDCS="1^ICD-9-CM"
QUIT
+31 IF $ORDER(^ICD9("ABA",30,ICDID,0))>0
IF $ORDER(^ICD9("ABA",1,ICDID,0))>0
IF ICDT'<ICD10
SET ICDCS="30^ICD-10-CM"
QUIT
+32 QUIT
if ICDT<ICD10
SET ICDCS="1^ICD-9-CM"
if ICDT'<ICD10
SET ICDCS="30^ICD-10-CM"
End DoDot:2
if $LENGTH(ICDCS)
QUIT
+33 IF ICDFI=80.1
Begin DoDot:2
+34 IF $ORDER(^ICD0("ABA",2,ICDID,0))>0
IF $ORDER(^ICD0("ABA",31,ICDID,0))'>0
SET ICDCS="2^ICD-9 Proc"
QUIT
+35 IF $ORDER(^ICD0("ABA",31,ICDID,0))>0
IF $ORDER(^ICD0("ABA",2,ICDID,0))'>0
SET ICDCS="31^ICD-10-PCS"
QUIT
+36 IF $ORDER(^ICD0("ABA",31,ICDID,0))>0
IF $ORDER(^ICD0("ABA",2,ICDID,0))>0
IF ICDT<ICD10
SET ICDCS="2^ICD-9 Proc"
QUIT
+37 IF $ORDER(^ICD0("ABA",31,ICDID,0))>0
IF $ORDER(^ICD0("ABA",2,ICDID,0))>0
IF ICDT'<ICD10
SET ICDCS="31^ICD-10-PCS"
QUIT
+38 QUIT
if ICDT<ICD10
SET ICDCS="2^ICD-9 Proc"
if ICDT'<ICD10
SET ICDCS="31^ICD-10-PCS"
End DoDot:2
if $LENGTH(ICDCS)
QUIT
End DoDot:1
if $LENGTH(ICDCS)
QUIT
+39 if $LENGTH(ICDCS)
QUIT ICDCS
+40 QUIT ""
CSI(FILE,IEN) ; Coding System for file and IEN
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File Number (required)
+5 ; IEN IEN in file 80/80.1 (required)
+6 ;
+7 ; Output:
+8 ;
+9 ; $$CSI Coding System (pointer to file 80.4)
+10 ; or null if not found
+11 ;
+12 NEW ICDI,ICDRT,ICDCS
SET ICDRT=$$ROOT^ICDEX(+($GET(FILE)))
if '$LENGTH(ICDRT)
QUIT ""
+13 SET ICDI=+($GET(IEN))
if +ICDI'>0
QUIT ""
SET ICDCS=+($PIECE($GET(@(ICDRT_+ICDI_",1)")),"^",1))
if +ICDCS'>0
QUIT ""
+14 QUIT ICDCS
VMDC(IEN,CDT,FMT) ; Versioned Major Diagnostic Category
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN IEN in file 80 (required)
+5 ; CDT Date to use to Extract MDC (default TODAY)
+6 ; FMT Output Format
+7 ; 0 = MDC only (default)
+8 ; 1 = MDC ^ Effective Date
+9 ;
+10 ; Output:
+11 ;
+12 ; MDC Major Diagnostic Category
+13 ;
+14 NEW MDC,DRGFY,ICDY,ICDD,ICDM,ICDOUT
if +($GET(IEN))'>0
QUIT ""
SET FMT=+($GET(FMT))
if FMT'=1
SET FMT=0
+15 SET ICDY=$PIECE($GET(^ICD9(IEN,1)),"^",1)
if +ICDY'>0
QUIT "-1^Invalid Coding System"
+16 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($GET(CDT),,ICDY))
if CDT'?7N
QUIT ""
+17 SET (MDC,DRGFY)=""
SET DRGFY=$ORDER(^ICD9(+($GET(IEN)),4,"B",(CDT+.001)),-1)
SET MDC=$ORDER(^ICD9(+($GET(IEN)),4,"B",+DRGFY,MDC))
+18 SET ICDOUT=$PIECE($GET(^ICD9(+($GET(IEN)),4,+MDC,0)),U,2)
if FMT>0
SET ICDOUT=ICDOUT_"^"_$PIECE($GET(^ICD9(+($GET(IEN)),4,+MDC,0)),U,1)
+19 QUIT ICDOUT
VSEX(FILE,IEN,CDT,FMT) ; Versioned Sex
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File
+5 ; 80 ICD Diagnosis file
+6 ; 80.1 ICD Operation/Procedure file
+7 ; IEN IEN (required)
+8 ; CDT Date to use to Extract Sex (default TODAY)
+9 ; FMT Output Format
+10 ; 0 = Sex only (default)
+11 ; 1 = Sex ^ Effective Date
+12 ;
+13 ; Output:
+14 ;
+15 ; SEX Sex
+16 ; M Male
+17 ; F Female
+18 ; Null
+19 ;
+20 NEW ICDI,ICDR,ICDN,ICDD,ICDE,ICDS,ICDY,ICDOUT
SET ICDI=+($GET(IEN))
if +ICDI'>0
QUIT ""
+21 SET FMT=+($GET(FMT))
if FMT'=1
SET FMT=0
SET ICDR=$$ROOT^ICDEX($GET(FILE))
if '$LENGTH(ICDR)
QUIT ""
+22 SET ICDN=$SELECT(ICDR="^ICD9(":5,ICDR="^ICD0(":3,1:"")
if +ICDN'>0
QUIT ""
+23 SET ICDY=$PIECE($GET(@(ICDR_+ICDI_",1)")),"^",1)
if +ICDY'>0
QUIT "-1^Invalid Coding System"
+24 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($GET(CDT),,ICDY))
if CDT'?7N
QUIT ""
+25 SET ICDE=$ORDER(@(ICDR_ICDI_","_ICDN_",""B"","_(CDT+.001)_")"),-1)
if ICDE'?7N
QUIT ""
+26 SET ICDS=$ORDER(@(ICDR_ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1)
if +ICDS'>0
QUIT ""
+27 SET ICDS=$GET(@(ICDR_ICDI_","_ICDN_","_ICDS_",0)"))
+28 if '$LENGTH(ICDS)
QUIT ""
+29 SET ICDD=$PIECE(ICDS,"^",1)
SET ICDS=$PIECE(ICDS,"^",2)
if "^M^F^"'[("^"_ICDS_"^")
QUIT ""
+30 SET ICDOUT=ICDS
if FMT>0
SET ICDOUT=ICDOUT_"^"_ICDD
+31 QUIT ICDOUT
SAI(FILE,IEN,CDT) ; Status/Activation/Inactivation
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File
+5 ; 80 ICD Diagnosis file
+6 ; 80.1 ICD Operation/Procedure file
+7 ; IEN IEN or code (required)
+8 ; CDT Date to use to Extract Status (default TODAY)
+9 ;
+10 ; Output:
+11 ;
+12 ; 5 piece "^" delimited string
+13 ;
+14 ; 1 Status
+15 ; 2 Activation Date
+16 ; 3 Inactivation Date
+17 ; 4 IEN
+18 ; 5 Code
+19 ; 6 Short Text
+20 ;
+21 ; If the status is active, the short
+22 ; text will be the most recent.
+23 ;
+24 ; If the status is inactive, the short
+25 ; text will be the text in use on the
+26 ; date it was inactivated.
+27 ;
+28 ; Null if no status for date.
+29 ;
+30 NEW ICDI,ICDCD,ICDR,ICDN,ICDE,ICDS,ICDY,EFF,ACT,STA,INA,NAM
SET ICDI=$GET(IEN)
if '$LENGTH(ICDI)
QUIT
+31 SET ICDR=$$ROOT^ICDEX($GET(FILE))
if '$LENGTH(ICDR)
QUIT ""
+32 SET ICDCD=$$CODEC^ICDEX(FILE,ICDI)
+33 IF '$DATA(@(ICDR_ICDI_",1)"))
Begin DoDot:1
+34 NEW ICDE
SET ICDE=0
FOR
SET ICDE=$ORDER(^ICDS(ICDE))
if +ICDE'>0
QUIT
Begin DoDot:2
+35 NEW ICDT
SET ICDT=$ORDER(@(ICDR_"""ABA"","_+ICDE_","""_(ICDI_" ")_""",0)"))
if ICDT'>0
QUIT
+36 if ICDT?1N.N&(ICDI'?1N.N)
SET ICDI=ICDT
End DoDot:2
End DoDot:1
+37 SET ICDY=$PIECE($GET(@(ICDR_+ICDI_",1)")),"^",1)
if +ICDY'>0
QUIT "-1^Invalid Coding System"
+38 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:CDT)
if CDT'?7N
QUIT ""
+39 SET ICDE=$ORDER(@(ICDR_ICDI_",66,""B"","_(CDT+.001)_")"),-1)
if ICDE'?7N
QUIT ""
+40 SET ICDS=$ORDER(@(ICDR_ICDI_",66,""B"","_ICDE_","" "")"),-1)
if +ICDS'>0
QUIT ""
+41 SET ICDS=$GET(@(ICDR_ICDI_",66,"_ICDS_",0)"))
if '$LENGTH(ICDS)
QUIT ""
+42 SET (ACT,INA,NAM)=""
SET EFF=$PIECE(ICDS,"^",1)
SET STA=$PIECE(ICDS,"^",2)
+43 if STA>0
SET ACT=EFF
if STA'>0
SET INA=EFF
+44 IF STA'>0
IF INA?7N
Begin DoDot:1
+45 SET ICDE=$ORDER(@(ICDR_ICDI_",66,""B"","_INA_")"),-1)
if ICDE'?7N
QUIT
+46 SET ICDS=$ORDER(@(ICDR_ICDI_",66,""B"","_ICDE_","" "")"),-1)
if +ICDS'>0
QUIT
+47 SET ICDS=$GET(@(ICDR_ICDI_",66,"_ICDS_",0)"))
if '$LENGTH(ICDS)
QUIT
+48 if $PIECE(ICDS,"^",2)>0&($PIECE(ICDS,"^",1)?7N)
SET ACT=$PIECE(ICDS,"^",1)
End DoDot:1
+49 IF ACT?7N
Begin DoDot:1
+50 SET ICDE=$ORDER(@(ICDR_ICDI_",67,""B"","_(9999999+.001)_")"),-1)
if ICDE'?7N
QUIT
+51 SET ICDS=$ORDER(@(ICDR_ICDI_",67,""B"","_ICDE_","" "")"),-1)
if +ICDS'>0
QUIT
+52 SET ICDS=$GET(@(ICDR_ICDI_",67,"_ICDS_",0)"))
if '$LENGTH(ICDS)
QUIT
+53 if $LENGTH($PIECE(ICDS,"^",2))>0
SET NAM=$PIECE(ICDS,"^",2)
End DoDot:1
+54 SET ICDS=+($GET(STA))
if $GET(ACT)?7N
SET $PIECE(ICDS,"^",2)=$GET(ACT)
+55 if $GET(INA)?7N
SET $PIECE(ICDS,"^",3)=$GET(INA)
+56 if ICDI?1N.N
SET $PIECE(ICDS,"^",4)=ICDI
+57 if $LENGTH(ICDCD)
SET $PIECE(ICDS,"^",5)=ICDCD
+58 if $LENGTH(NAM)
SET $PIECE(ICDS,"^",6)=NAM
+59 QUIT ICDS
VAGEL(IEN,CDT,FMT) ; Versioned Age Low
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN IEN in file 80 (required)
+5 ; CDT Date to use to Extract Age Low (default TODAY)
+6 ; FMT Output Format
+7 ; 0 = Age Low only (default)
+8 ; 1 = Age Low ^ Effective Date
+9 ;
+10 ; Output:
+11 ;
+12 ; AGEL Age Low
+13 ;
+14 NEW AGEL,DRGFY,ICDY,ICDOUT
if +($GET(IEN))'>0
QUIT ""
SET FMT=+($GET(FMT))
if FMT'=1
SET FMT=0
+15 SET ICDY=$PIECE($GET(^ICD9(IEN,1)),"^",1)
if +ICDY'>0
QUIT "-1^Invalid Coding System"
+16 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($GET(CDT),,ICDY))
if CDT'?7N
QUIT ""
+17 SET (AGEL,DRGFY)=""
SET DRGFY=$ORDER(^ICD9(+($GET(IEN)),6,"B",(CDT+.001)),-1)
SET AGEL=$ORDER(^ICD9(+($GET(IEN)),6,"B",+DRGFY,AGEL))
+18 SET ICDOUT=$PIECE($GET(^ICD9(+($GET(IEN)),6,+AGEL,0)),U,2)
if FMT>0
SET ICDOUT=ICDOUT_"^"_$PIECE($GET(^ICD9(+($GET(IEN)),6,+AGEL,0)),U,1)
+19 QUIT ICDOUT
VAGEH(IEN,CDT,FMT) ; Versioned Age High
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN IEN in file 80 (required)
+5 ; CDT Date to use to Extract Age High (default TODAY)
+6 ; FMT Output Format
+7 ; 0 = Age High only (default)
+8 ; 1 = Age High ^ Effective Date
+9 ;
+10 ; Output:
+11 ;
+12 ; AGEH Age High
+13 ;
+14 NEW AGEH,DRGFY,ICDY,ICDOUT
if +($GET(IEN))'>0
QUIT ""
SET FMT=+($GET(FMT))
if FMT'=1
SET FMT=0
+15 SET ICDY=$PIECE($GET(^ICD9(IEN,1)),"^",1)
if +ICDY'>0
QUIT "-1^Invalid Coding System"
+16 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($GET(CDT),,ICDY))
if CDT'?7N
QUIT ""
+17 SET (AGEH,DRGFY)=""
SET DRGFY=$ORDER(^ICD9(+($GET(IEN)),7,"B",(CDT+.001)),-1)
SET AGEH=$ORDER(^ICD9(+($GET(IEN)),7,"B",+DRGFY,AGEH))
+18 SET ICDOUT=$PIECE($GET(^ICD9(+($GET(IEN)),7,+AGEH,0)),U,2)
if FMT>0
SET ICDOUT=ICDOUT_"^"_$PIECE($GET(^ICD9(+($GET(IEN)),7,+AGEH,0)),U,1)
+19 QUIT ICDOUT
VCC(IEN,CDT,FMT) ; Return versioned Complication/Comorbidity
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN IEN in file 80 (required)
+5 ; CDT Date to use to Extract CC (default TODAY)
+6 ; FMT Output Format
+7 ; 0 = CC only (default)
+8 ; 1 = CC ^ Effective Date ^ External Value
+9 ;
+10 ; Output:
+11 ;
+12 ; $$VCC Complication/Comorbidity (FMT=0)
+13 ; Complication/Comorbidity^Effective Date (FMT=1)
+14 ;
+15 NEW ICDD,ICDI,ICDIC,ICDIC,ICDO,ICDE,ICDF
SET ICDF=+($GET(FMT))
SET ICDI=+($GET(IEN))
+16 if ICDF'=1
SET ICDF=0
SET ICDD=$ORDER(^ICD9(ICDI,69,"B",CDT+.0001),-1)
if '$LENGTH(ICDD)
QUIT ""
+17 SET ICDIC=$ORDER(^ICD9(ICDI,69,"B",ICDD,""),-1)
SET ICDE=""
+18 SET ICDO=$PIECE(^ICD9(ICDI,69,ICDIC,0),U,2)
+19 SET ICDD=$PIECE(^ICD9(ICDI,69,ICDIC,0),U,1)
+20 if ICDF>0&($LENGTH(ICDO))
SET ICDE=$$GET1^DIQ(80.0103,(ICDIC_","_ICDI_","),1)
+21 if ICDF>0&($LENGTH(ICDO))
SET $PIECE(ICDO,"^",2)=ICDD
+22 if ICDF>0&($LENGTH(ICDO))&($LENGTH(ICDE))
SET $PIECE(ICDO,"^",3)=ICDE
+23 QUIT ICDO
VCCP(IEN,CDT,FMT) ; Return versioned CC Primary Flag
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN IEN in file 80 (required)
+5 ; CDT Date to use to Extract CC Primary Flag (default TODAY)
+6 ; FMT Output Format
+7 ; 0 = CC Primary Flag only (default)
+8 ; 1 = CC Primary Flag ^ Effective Date ^ External Value
+9 ;
+10 ; Output:
+11 ;
+12 ; $$VCCP Complication/Comorbidity (FMT=0)
+13 ; Complication/Comorbidity^Effective Date (FMT=1)
+14 ;
+15 NEW ICDD,ICDI,ICDIC,ICDIC,ICDO,ICDE,ICDF
SET ICDF=+($GET(FMT))
SET ICDI=+($GET(IEN))
+16 if ICDF'=1
SET ICDF=0
SET ICDD=$ORDER(^ICD9(ICDI,69,"B",CDT+.0001),-1)
if '$LENGTH(ICDD)
QUIT ""
+17 SET ICDIC=$ORDER(^ICD9(ICDI,69,"B",ICDD,""),-1)
SET ICDE=""
+18 SET ICDO=$PIECE(^ICD9(ICDI,69,ICDIC,0),U,3)
+19 SET ICDD=$PIECE(^ICD9(ICDI,69,ICDIC,0),U,1)
+20 if ICDF>0&($LENGTH(ICDO))
SET ICDE=$$GET1^DIQ(80.0103,(ICDIC_","_ICDI_","),2)
+21 if ICDF>0&($LENGTH(ICDO))
SET $PIECE(ICDO,"^",2)=ICDD
+22 if ICDF>0&($LENGTH(ICDO))&($LENGTH(ICDE))
SET $PIECE(ICDO,"^",3)=ICDE
+23 QUIT ICDO
