- 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 Feb 18, 2025@23:16:55 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