- ICDEXS2 ;SLC/KER - ICD Extractor - Support ;04/21/2014
- ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
- ;
- 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 ""
- ICDEXS2 ;SLC/KER - ICD Extractor - Support ;04/21/2014
- +1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
- +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 ""
