ICDEXS2 ;SLC/KER - ICD Extractor - Support ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
;
VER(SYS,REL) ; Coding System Version
;
; Input:
;
; SYS System (pointer to file 80.4)
; REL Relationship to System (optional)
;
; 0 N/A - Current Version (default)
; 1 Next Version
; -1 Previous Version
; Output:
;
; $$VER This is a 5 piece string containing:
;
; 1 Coding System (pointer to file 80.4)
; 2 Coding System Nomenclature
; 3 Coding System Abbreviation
; 4 File Number containing the Coding System
; 5 Date Coding System was Implemented
; or
; -1 on error
;
N ICDS,ICDR,ICDT,ICDO,ICDA,ICDF,ICDI,ICDD,ICDV,ICDC
S ICDO="",ICDS=+($G(SYS)),ICDR=+($G(REL)),ICDT=$G(^ICDS(+ICDS,0)),ICDC=$P(ICDT,"^",4)
I +ICDR=0,ICDS>0,$L(ICDT,"^")>3 S ICDO=ICDS_"^"_ICDT Q ICDO
S ICDF=$$FILE^ICDEX(ICDS) Q:+ICDF'>0 "-1^No future coding system found"
S ICDI=0 F S ICDI=$O(^ICDS("F",+ICDF,ICDI)) Q:+ICDI'>0 D
. S ICDT=$G(^ICDS(+ICDI,0)),ICDD=$P(ICDT,"^",4)
. S:ICDD?7N ICDA(ICDD)=ICDI
I +ICDR>0,ICDC?7N D Q ICDO
. N ICDN,ICDT,ICDD S ICDO="-1^No Next Coding System"
. S ICDN=$O(ICDA(ICDC)),ICDN=+($G(ICDA(+ICDN))) Q:+ICDN'>0
. S ICDT=$G(^ICDS(+ICDN,0)),ICDD=$P(ICDT,"^",4)
. I ICDN>0,$L(ICDT,"^")>3,ICDD?7N S ICDO=ICDN_"^"_ICDT
I +ICDR<0,ICDC?7N D Q ICDO
. N ICDN,ICDT,ICDD S ICDO="-1^No Previous Coding System"
. S ICDN=$O(ICDA(ICDC),-1),ICDN=+($G(ICDA(+ICDN))) Q:+ICDN'>0
. S ICDT=$G(^ICDS(+ICDN,0)),ICDD=$P(ICDT,"^",4)
. I ICDN>0,$L(ICDT,"^")>3,ICDD?7N S ICDO=ICDN_"^"_ICDT
Q "-1^No Coding System found"
HDR(X) ; Diagnosis/Procedure File Header Node
;
; Input:
;
; X File Number or Global Root
; 80 or ^ICD9(
; 80.1 or ^ICD0(
;
; Output:
;
; $$HDR Diagnosis/Procedure File Header Node
;
; Replaces ICR 2435 and 2436
;
N ICDF S ICDF=$G(X) S ICDF=$$FILE^ICDEX(ICDF)
Q:ICDF=80 $G(^ICD9(0)) Q:ICDF=80.1 $G(^ICD0(0))
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXS2 2184 printed Apr 09, 2024@20:57:36 Page 2
ICDEXS2 ;SLC/KER - ICD Extractor - Support ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
+2 ;
VER(SYS,REL) ; Coding System Version
+1 ;
+2 ; Input:
+3 ;
+4 ; SYS System (pointer to file 80.4)
+5 ; REL Relationship to System (optional)
+6 ;
+7 ; 0 N/A - Current Version (default)
+8 ; 1 Next Version
+9 ; -1 Previous Version
+10 ; Output:
+11 ;
+12 ; $$VER This is a 5 piece string containing:
+13 ;
+14 ; 1 Coding System (pointer to file 80.4)
+15 ; 2 Coding System Nomenclature
+16 ; 3 Coding System Abbreviation
+17 ; 4 File Number containing the Coding System
+18 ; 5 Date Coding System was Implemented
+19 ; or
+20 ; -1 on error
+21 ;
+22 NEW ICDS,ICDR,ICDT,ICDO,ICDA,ICDF,ICDI,ICDD,ICDV,ICDC
+23 SET ICDO=""
SET ICDS=+($GET(SYS))
SET ICDR=+($GET(REL))
SET ICDT=$GET(^ICDS(+ICDS,0))
SET ICDC=$PIECE(ICDT,"^",4)
+24 IF +ICDR=0
IF ICDS>0
IF $LENGTH(ICDT,"^")>3
SET ICDO=ICDS_"^"_ICDT
QUIT ICDO
+25 SET ICDF=$$FILE^ICDEX(ICDS)
if +ICDF'>0
QUIT "-1^No future coding system found"
+26 SET ICDI=0
FOR
SET ICDI=$ORDER(^ICDS("F",+ICDF,ICDI))
if +ICDI'>0
QUIT
Begin DoDot:1
+27 SET ICDT=$GET(^ICDS(+ICDI,0))
SET ICDD=$PIECE(ICDT,"^",4)
+28 if ICDD?7N
SET ICDA(ICDD)=ICDI
End DoDot:1
+29 IF +ICDR>0
IF ICDC?7N
Begin DoDot:1
+30 NEW ICDN,ICDT,ICDD
SET ICDO="-1^No Next Coding System"
+31 SET ICDN=$ORDER(ICDA(ICDC))
SET ICDN=+($GET(ICDA(+ICDN)))
if +ICDN'>0
QUIT
+32 SET ICDT=$GET(^ICDS(+ICDN,0))
SET ICDD=$PIECE(ICDT,"^",4)
+33 IF ICDN>0
IF $LENGTH(ICDT,"^")>3
IF ICDD?7N
SET ICDO=ICDN_"^"_ICDT
End DoDot:1
QUIT ICDO
+34 IF +ICDR<0
IF ICDC?7N
Begin DoDot:1
+35 NEW ICDN,ICDT,ICDD
SET ICDO="-1^No Previous Coding System"
+36 SET ICDN=$ORDER(ICDA(ICDC),-1)
SET ICDN=+($GET(ICDA(+ICDN)))
if +ICDN'>0
QUIT
+37 SET ICDT=$GET(^ICDS(+ICDN,0))
SET ICDD=$PIECE(ICDT,"^",4)
+38 IF ICDN>0
IF $LENGTH(ICDT,"^")>3
IF ICDD?7N
SET ICDO=ICDN_"^"_ICDT
End DoDot:1
QUIT ICDO
+39 QUIT "-1^No Coding System found"
HDR(X) ; Diagnosis/Procedure File Header Node
+1 ;
+2 ; Input:
+3 ;
+4 ; X File Number or Global Root
+5 ; 80 or ^ICD9(
+6 ; 80.1 or ^ICD0(
+7 ;
+8 ; Output:
+9 ;
+10 ; $$HDR Diagnosis/Procedure File Header Node
+11 ;
+12 ; Replaces ICR 2435 and 2436
+13 ;
+14 NEW ICDF
SET ICDF=$GET(X)
SET ICDF=$$FILE^ICDEX(ICDF)
+15 if ICDF=80
QUIT $GET(^ICD9(0))
if ICDF=80.1
QUIT $GET(^ICD0(0))
+16 QUIT ""
