Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDEXC2

ICDEXC2.m

Go to the documentation of this file.
  1. ICDEXC2 ;SLC/KER - ICD Extractor - Code APIs (cont) ;04/21/2014
  1. ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
  1. ;
  1. ; Global Variables
  1. ; ^ICD0("BA") N/A
  1. ; ^ICD0("ABA") N/A
  1. ; ^ICD9("BA") N/A
  1. ; ^ICD9("ABA") N/A
  1. ; ^ICDS( N/A
  1. ;
  1. ; External References
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$GET1^DIQ ICR 2056
  1. ; $$UP^XLFSTR ICR 10104
  1. ;
  1. Q
  1. CODEFI(CODE) ; Return file where code is found (exact match)
  1. ;
  1. ; Input:
  1. ;
  1. ; CODE ICD code (required)
  1. ;
  1. ; Output:
  1. ;
  1. ; FILE File Number
  1. ; 80 = ICD Dx file
  1. ; 80.1 = ICD Oper/Proc file
  1. ; Null
  1. ;
  1. N ICDU,ICDO,ICDT S CODE=$G(CODE) Q:'$L(CODE) "" S ICDU=$$UP^XLFSTR(CODE)
  1. S ICDO=0 F ICDT=CODE,ICDU D Q:+ICDO>0
  1. . S:$O(^ICD9("BA",(ICDT_" "),0))>0&($O(^ICD0("BA",(ICDT_" "),0))'>0) ICDO=80
  1. . S:$O(^ICD0("BA",(ICDT_" "),0))>0&($O(^ICD9("BA",(ICDT_" "),0))'>0) ICDO=80.1
  1. . S:$O(^ICD9("BA",(ICDT_" "),0))>0 ICDO=80
  1. . S:$O(^ICD0("BA",(ICDT_" "),0))>0 ICDO=80.1
  1. Q $S(ICDO>0:ICDO,1:"")
  1. CODECS(CODE,FILE,CDT) ; Return coding system where code is found (exact match)
  1. ;
  1. ; Input:
  1. ;
  1. ; CODE ICD code/IEN (required)
  1. ; FILE File Number (required)
  1. ; 80 = ICD Dx file
  1. ; 80.1 = ICD Oper/Proc file
  1. ; CDT Date used to determine Coding
  1. ; System (optional, default TODAY)
  1. ;
  1. ; Output:
  1. ;
  1. ; SYS 2 piece ^ delimited string
  1. ; 1 Coding System
  1. ; 2 Coding Nomenclature
  1. ;
  1. ; 1 ^ ICD-9-CM
  1. ; 2 ^ ICD-9 Proc
  1. ; 30 ^ ICD-10-CM
  1. ; 31 ^ ICD-10-PCS
  1. ;
  1. ; or null if not found
  1. ;
  1. N ICDFI,ICDCS,ICDT,ICDID,ICD10,ICDU,ICDC S CODE=$TR($G(CODE)," ",""),ICDCS="",ICD10=+($$IMP^ICDEX(30)) Q:'$L(CODE) ""
  1. S ICDU=$$UP^XLFSTR(CODE),ICDFI=+($G(FILE)) S:"^80^80.1^"'[("^"_$G(ICDFI)_"^") ICDFI=+($$CODEFI(CODE))
  1. S ICDT=$G(CDT) S:ICDT'?7N ICDT=$$DT^XLFDT F ICDID=(CODE_" "),(ICDU_" ") D Q:$L(ICDCS)
  1. . I ICDFI=80 D Q:$L(ICDCS)
  1. . . I $O(^ICD9("ABA",1,ICDID,0))>0,$O(^ICD9("ABA",30,ICDID,0))'>0 S ICDCS="1^ICD-9-CM" Q
  1. . . I $O(^ICD9("ABA",30,ICDID,0))>0,$O(^ICD9("ABA",1,ICDID,0))'>0 S ICDCS="30^ICD-10-CM" Q
  1. . . I $O(^ICD9("ABA",30,ICDID,0))>0,$O(^ICD9("ABA",1,ICDID,0))>0,ICDT<ICD10 S ICDCS="1^ICD-9-CM" Q
  1. . . I $O(^ICD9("ABA",30,ICDID,0))>0,$O(^ICD9("ABA",1,ICDID,0))>0,ICDT'<ICD10 S ICDCS="30^ICD-10-CM" Q
  1. . . Q S:ICDT<ICD10 ICDCS="1^ICD-9-CM" S:ICDT'<ICD10 ICDCS="30^ICD-10-CM"
  1. . I ICDFI=80.1 D Q:$L(ICDCS)
  1. . . I $O(^ICD0("ABA",2,ICDID,0))>0,$O(^ICD0("ABA",31,ICDID,0))'>0 S ICDCS="2^ICD-9 Proc" Q
  1. . . I $O(^ICD0("ABA",31,ICDID,0))>0,$O(^ICD0("ABA",2,ICDID,0))'>0 S ICDCS="31^ICD-10-PCS" Q
  1. . . I $O(^ICD0("ABA",31,ICDID,0))>0,$O(^ICD0("ABA",2,ICDID,0))>0,ICDT<ICD10 S ICDCS="2^ICD-9 Proc" Q
  1. . . I $O(^ICD0("ABA",31,ICDID,0))>0,$O(^ICD0("ABA",2,ICDID,0))>0,ICDT'<ICD10 S ICDCS="31^ICD-10-PCS" Q
  1. . . Q S:ICDT<ICD10 ICDCS="2^ICD-9 Proc" S:ICDT'<ICD10 ICDCS="31^ICD-10-PCS"
  1. Q:$L(ICDCS) ICDCS
  1. Q ""
  1. CSI(FILE,IEN) ; Coding System for file and IEN
  1. ;
  1. ; Input:
  1. ;
  1. ; FILE File Number (required)
  1. ; IEN IEN in file 80/80.1 (required)
  1. ;
  1. ; Output:
  1. ;
  1. ; $$CSI Coding System (pointer to file 80.4)
  1. ; or null if not found
  1. ;
  1. N ICDI,ICDRT,ICDCS S ICDRT=$$ROOT^ICDEX(+($G(FILE))) Q:'$L(ICDRT) ""
  1. S ICDI=+($G(IEN)) Q:+ICDI'>0 "" S ICDCS=+($P($G(@(ICDRT_+ICDI_",1)")),"^",1)) Q:+ICDCS'>0 ""
  1. Q ICDCS
  1. VMDC(IEN,CDT,FMT) ; Versioned Major Diagnostic Category
  1. ;
  1. ; Input:
  1. ;
  1. ; IEN IEN in file 80 (required)
  1. ; CDT Date to use to Extract MDC (default TODAY)
  1. ; FMT Output Format
  1. ; 0 = MDC only (default)
  1. ; 1 = MDC ^ Effective Date
  1. ;
  1. ; Output:
  1. ;
  1. ; MDC Major Diagnostic Category
  1. ;
  1. N MDC,DRGFY,ICDY,ICDD,ICDM,ICDOUT Q:+($G(IEN))'>0 "" S FMT=+($G(FMT)) S:FMT'=1 FMT=0
  1. S ICDY=$P($G(^ICD9(IEN,1)),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
  1. S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
  1. S (MDC,DRGFY)="" S DRGFY=$O(^ICD9(+($G(IEN)),4,"B",(CDT+.001)),-1),MDC=$O(^ICD9(+($G(IEN)),4,"B",+DRGFY,MDC))
  1. 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)
  1. Q ICDOUT
  1. VSEX(FILE,IEN,CDT,FMT) ; Versioned Sex
  1. ;
  1. ; Input:
  1. ;
  1. ; FILE File
  1. ; 80 ICD Diagnosis file
  1. ; 80.1 ICD Operation/Procedure file
  1. ; IEN IEN (required)
  1. ; CDT Date to use to Extract Sex (default TODAY)
  1. ; FMT Output Format
  1. ; 0 = Sex only (default)
  1. ; 1 = Sex ^ Effective Date
  1. ;
  1. ; Output:
  1. ;
  1. ; SEX Sex
  1. ; M Male
  1. ; F Female
  1. ; Null
  1. ;
  1. N ICDI,ICDR,ICDN,ICDD,ICDE,ICDS,ICDY,ICDOUT S ICDI=+($G(IEN)) Q:+ICDI'>0 ""
  1. S FMT=+($G(FMT)) S:FMT'=1 FMT=0 S ICDR=$$ROOT^ICDEX($G(FILE)) Q:'$L(ICDR) ""
  1. S ICDN=$S(ICDR="^ICD9(":5,ICDR="^ICD0(":3,1:"") Q:+ICDN'>0 ""
  1. S ICDY=$P($G(@(ICDR_+ICDI_",1)")),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
  1. S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
  1. S ICDE=$O(@(ICDR_ICDI_","_ICDN_",""B"","_(CDT+.001)_")"),-1) Q:ICDE'?7N ""
  1. S ICDS=$O(@(ICDR_ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0 ""
  1. S ICDS=$G(@(ICDR_ICDI_","_ICDN_","_ICDS_",0)"))
  1. Q:'$L(ICDS) ""
  1. S ICDD=$P(ICDS,"^",1),ICDS=$P(ICDS,"^",2) Q:"^M^F^"'[("^"_ICDS_"^") ""
  1. S ICDOUT=ICDS S:FMT>0 ICDOUT=ICDOUT_"^"_ICDD
  1. Q ICDOUT
  1. SAI(FILE,IEN,CDT) ; Status/Activation/Inactivation
  1. ;
  1. ; Input:
  1. ;
  1. ; FILE File
  1. ; 80 ICD Diagnosis file
  1. ; 80.1 ICD Operation/Procedure file
  1. ; IEN IEN or code (required)
  1. ; CDT Date to use to Extract Status (default TODAY)
  1. ;
  1. ; Output:
  1. ;
  1. ; 5 piece "^" delimited string
  1. ;
  1. ; 1 Status
  1. ; 2 Activation Date
  1. ; 3 Inactivation Date
  1. ; 4 IEN
  1. ; 5 Code
  1. ; 6 Short Text
  1. ;
  1. ; If the status is active, the short
  1. ; text will be the most recent.
  1. ;
  1. ; If the status is inactive, the short
  1. ; text will be the text in use on the
  1. ; date it was inactivated.
  1. ;
  1. ; Null if no status for date.
  1. ;
  1. N ICDI,ICDCD,ICDR,ICDN,ICDE,ICDS,ICDY,EFF,ACT,STA,INA,NAM S ICDI=$G(IEN) Q:'$L(ICDI)
  1. S ICDR=$$ROOT^ICDEX($G(FILE)) Q:'$L(ICDR) ""
  1. S ICDCD=$$CODEC^ICDEX(FILE,ICDI)
  1. I '$D(@(ICDR_ICDI_",1)")) D
  1. . N ICDE S ICDE=0 F S ICDE=$O(^ICDS(ICDE)) Q:+ICDE'>0 D
  1. . . N ICDT S ICDT=$O(@(ICDR_"""ABA"","_+ICDE_","""_(ICDI_" ")_""",0)")) Q:ICDT'>0
  1. . . S:ICDT?1N.N&(ICDI'?1N.N) ICDI=ICDT
  1. S ICDY=$P($G(@(ICDR_+ICDI_",1)")),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
  1. S CDT=$S($G(CDT)="":$$DT^XLFDT,1:CDT) Q:CDT'?7N ""
  1. S ICDE=$O(@(ICDR_ICDI_",66,""B"","_(CDT+.001)_")"),-1) Q:ICDE'?7N ""
  1. S ICDS=$O(@(ICDR_ICDI_",66,""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0 ""
  1. S ICDS=$G(@(ICDR_ICDI_",66,"_ICDS_",0)")) Q:'$L(ICDS) ""
  1. S (ACT,INA,NAM)="" S EFF=$P(ICDS,"^",1),STA=$P(ICDS,"^",2)
  1. S:STA>0 ACT=EFF S:STA'>0 INA=EFF
  1. I STA'>0,INA?7N D
  1. . S ICDE=$O(@(ICDR_ICDI_",66,""B"","_INA_")"),-1) Q:ICDE'?7N
  1. . S ICDS=$O(@(ICDR_ICDI_",66,""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0
  1. . S ICDS=$G(@(ICDR_ICDI_",66,"_ICDS_",0)")) Q:'$L(ICDS)
  1. . S:$P(ICDS,"^",2)>0&($P(ICDS,"^",1)?7N) ACT=$P(ICDS,"^",1)
  1. I ACT?7N D
  1. . S ICDE=$O(@(ICDR_ICDI_",67,""B"","_(9999999+.001)_")"),-1) Q:ICDE'?7N
  1. . S ICDS=$O(@(ICDR_ICDI_",67,""B"","_ICDE_","" "")"),-1) Q:+ICDS'>0
  1. . S ICDS=$G(@(ICDR_ICDI_",67,"_ICDS_",0)")) Q:'$L(ICDS)
  1. . S:$L($P(ICDS,"^",2))>0 NAM=$P(ICDS,"^",2)
  1. S ICDS=+($G(STA)) S:$G(ACT)?7N $P(ICDS,"^",2)=$G(ACT)
  1. S:$G(INA)?7N $P(ICDS,"^",3)=$G(INA)
  1. S:ICDI?1N.N $P(ICDS,"^",4)=ICDI
  1. S:$L(ICDCD) $P(ICDS,"^",5)=ICDCD
  1. S:$L(NAM) $P(ICDS,"^",6)=NAM
  1. Q ICDS
  1. VAGEL(IEN,CDT,FMT) ; Versioned Age Low
  1. ;
  1. ; Input:
  1. ;
  1. ; IEN IEN in file 80 (required)
  1. ; CDT Date to use to Extract Age Low (default TODAY)
  1. ; FMT Output Format
  1. ; 0 = Age Low only (default)
  1. ; 1 = Age Low ^ Effective Date
  1. ;
  1. ; Output:
  1. ;
  1. ; AGEL Age Low
  1. ;
  1. N AGEL,DRGFY,ICDY,ICDOUT Q:+($G(IEN))'>0 "" S FMT=+($G(FMT)) S:FMT'=1 FMT=0
  1. S ICDY=$P($G(^ICD9(IEN,1)),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
  1. S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
  1. S (AGEL,DRGFY)="" S DRGFY=$O(^ICD9(+($G(IEN)),6,"B",(CDT+.001)),-1),AGEL=$O(^ICD9(+($G(IEN)),6,"B",+DRGFY,AGEL))
  1. 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)
  1. Q ICDOUT
  1. VAGEH(IEN,CDT,FMT) ; Versioned Age High
  1. ;
  1. ; Input:
  1. ;
  1. ; IEN IEN in file 80 (required)
  1. ; CDT Date to use to Extract Age High (default TODAY)
  1. ; FMT Output Format
  1. ; 0 = Age High only (default)
  1. ; 1 = Age High ^ Effective Date
  1. ;
  1. ; Output:
  1. ;
  1. ; AGEH Age High
  1. ;
  1. N AGEH,DRGFY,ICDY,ICDOUT Q:+($G(IEN))'>0 "" S FMT=+($G(FMT)) S:FMT'=1 FMT=0
  1. S ICDY=$P($G(^ICD9(IEN,1)),"^",1) Q:+ICDY'>0 "-1^Invalid Coding System"
  1. S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX($G(CDT),,ICDY)) Q:CDT'?7N ""
  1. S (AGEH,DRGFY)="" S DRGFY=$O(^ICD9(+($G(IEN)),7,"B",(CDT+.001)),-1),AGEH=$O(^ICD9(+($G(IEN)),7,"B",+DRGFY,AGEH))
  1. 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)
  1. Q ICDOUT
  1. VCC(IEN,CDT,FMT) ; Return versioned Complication/Comorbidity
  1. ;
  1. ; Input:
  1. ;
  1. ; IEN IEN in file 80 (required)
  1. ; CDT Date to use to Extract CC (default TODAY)
  1. ; FMT Output Format
  1. ; 0 = CC only (default)
  1. ; 1 = CC ^ Effective Date ^ External Value
  1. ;
  1. ; Output:
  1. ;
  1. ; $$VCC Complication/Comorbidity (FMT=0)
  1. ; Complication/Comorbidity^Effective Date (FMT=1)
  1. ;
  1. N ICDD,ICDI,ICDIC,ICDIC,ICDO,ICDE,ICDF S ICDF=+($G(FMT)),ICDI=+($G(IEN))
  1. S:ICDF'=1 ICDF=0 S ICDD=$O(^ICD9(ICDI,69,"B",CDT+.0001),-1) Q:'$L(ICDD) ""
  1. S ICDIC=$O(^ICD9(ICDI,69,"B",ICDD,""),-1) S ICDE=""
  1. S ICDO=$P(^ICD9(ICDI,69,ICDIC,0),U,2)
  1. S ICDD=$P(^ICD9(ICDI,69,ICDIC,0),U,1)
  1. S:ICDF>0&($L(ICDO)) ICDE=$$GET1^DIQ(80.0103,(ICDIC_","_ICDI_","),1)
  1. S:ICDF>0&($L(ICDO)) $P(ICDO,"^",2)=ICDD
  1. S:ICDF>0&($L(ICDO))&($L(ICDE)) $P(ICDO,"^",3)=ICDE
  1. Q ICDO
  1. VCCP(IEN,CDT,FMT) ; Return versioned CC Primary Flag
  1. ;
  1. ; Input:
  1. ;
  1. ; IEN IEN in file 80 (required)
  1. ; CDT Date to use to Extract CC Primary Flag (default TODAY)
  1. ; FMT Output Format
  1. ; 0 = CC Primary Flag only (default)
  1. ; 1 = CC Primary Flag ^ Effective Date ^ External Value
  1. ;
  1. ; Output:
  1. ;
  1. ; $$VCCP Complication/Comorbidity (FMT=0)
  1. ; Complication/Comorbidity^Effective Date (FMT=1)
  1. ;
  1. N ICDD,ICDI,ICDIC,ICDIC,ICDO,ICDE,ICDF S ICDF=+($G(FMT)),ICDI=+($G(IEN))
  1. S:ICDF'=1 ICDF=0 S ICDD=$O(^ICD9(ICDI,69,"B",CDT+.0001),-1) Q:'$L(ICDD) ""
  1. S ICDIC=$O(^ICD9(ICDI,69,"B",ICDD,""),-1) S ICDE=""
  1. S ICDO=$P(^ICD9(ICDI,69,ICDIC,0),U,3)
  1. S ICDD=$P(^ICD9(ICDI,69,ICDIC,0),U,1)
  1. S:ICDF>0&($L(ICDO)) ICDE=$$GET1^DIQ(80.0103,(ICDIC_","_ICDI_","),2)
  1. S:ICDF>0&($L(ICDO)) $P(ICDO,"^",2)=ICDD
  1. S:ICDF>0&($L(ICDO))&($L(ICDE)) $P(ICDO,"^",3)=ICDE
  1. Q ICDO