ICDEXA2 ;SLC/KER - ICD Extractor - APIs/Utilities (cont) ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
;
; Global Variables
; ^ICD0("AVA" N/A
; ^ICD9("AVA" N/A
;
; External References
; $$DT^XLFDT ICR 10103
;
Q
NEXT(CODE,SYS,CDT) ; Next ICD Code (active or inactive)
;
; Input:
;
; CODE ICD Code or Null for the first code
; SYS Coding System - see ^ICDS
;
; 1 = ICD-9-CM
; 2 = ICD-9-PCS
; 30 = ICD-10-CM
; 31 = ICD-10-PCS
;
; CDT Code Date to check
; If CDT is passed, then the code
; returned is the next active code
; based on date. If it is not
; passed then the next code is
; returned regardless of status.
;
; Output:
;
; The Next ICD Code, Null if none
;
N ICDB,ICDC,ICDG,ICDF,ICDD,ICDE,ICDI,ICDR,ICDS,ICDO,ICDN,ICDY
S ICDC=$TR($G(CODE)," ",""),ICDD=$G(CDT),ICDB=ICDD?7N
S ICDY=$$SYS^ICDEX(+($G(SYS)))
S:ICDY'>0&($L(ICDC)) ICDY=$$SYS^ICDEX(ICDC)
S ICDF=$$FILE^ICDEX(+ICDY)
Q:'$L(ICDC)&(ICDY'>0) "" S ICDS=0,ICDE=""
S:+ICDY>0 ICDS=+ICDY I $L(ICDC) D
. S:"^80^80.1^"'[("^"_ICDF_"^") ICDF=$$CODEFI^ICDEX(ICDC)
. S ICDE=$P($$CODECS^ICDEX(ICDC,ICDF),"^",1) S:ICDS>0 ICDE=ICDS
Q:+ICDY>0&(+($G(ICDE))>0)&(+ICDY'=+($G(ICDE))) ""
S:+ICDS'>0&(+($G(ICDE))>0) ICDS=+($G(ICDE))
Q:+ICDS'>0 "" S ICDR=$$ROOT^ICDEX(ICDS) Q:'$L(ICDR) ""
S ICDO=$$NUM^ICDEX(ICDC) Q:$L(ICDC)&(+ICDO'>0) ""
I 'ICDB S ICDC="" D Q $S(ICDC="":"",1:ICDC)
. S ICDN=$O(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")"))
. S ICDC=$S(+ICDN>0:$$COD^ICDEX(+ICDN),1:"")
I ICDB S ICDC="" D Q $S(ICDC="":"",1:ICDC)
. N ICDA S ICDA="" F S ICDO=$O(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")")) Q:+ICDO'>0 D Q:$L(ICDC)
. . N ICDI S ICDI=0 F S ICDI=$O(@(ICDR_"""AN"","_+ICDS_","_+ICDO_","_+ICDI_")")) Q:+ICDI'>0 D Q:$L(ICDC)
. . . N ICDE,ICDH S ICDE=$O(@(ICDR_+ICDI_",66,""B"","_(ICDD+.001)_")"),-1) Q:ICDE'?7N
. . . S ICDH=$O(@(ICDR_+ICDI_",66,""B"","_ICDE_","" "")"),-1) Q:+ICDH'>0
. . . S ICDA=$G(@(ICDR_+ICDI_",66,"_ICDH_",0)")),ICDA=+($P(ICDA,"^",2))
. . . S:+ICDA>0 ICDC=ICDO S ICDC=$S(+($G(ICDC))>0:$$COD^ICDEX(+ICDC),1:"")
Q $S(ICDC="":"",1:ICDC)
PREV(CODE,SYS,CDT) ; Previous ICD Code (active or inactive)
;
; Input:
;
; CODE ICD Code or Null for the last code
; SYS Coding System - see ^ICDS
;
; 1 = ICD-9-CM
; 2 = ICD-9-PCS
; 30 = ICD-10-CM
; 31 = ICD-10-PCS
;
; CDT Code Date to check
; If CDT is passed, then the code
; returned is the previous active
; code based on date. If it is
; not passed then the previous
; code is returned regardless of
; status.
;
; Output:
;
; The Previous ICD Code, Null if none
;
N ICDB,ICDC,ICDG,ICDF,ICDD,ICDE,ICDI,ICDR,ICDS,ICDO,ICDN,ICDY
S ICDC=$TR($G(CODE)," ",""),ICDD=$G(CDT),ICDB=ICDD?7N
S ICDY=$$SYS^ICDEX(+($G(SYS)))
S:ICDY'>0&($L(ICDC)) ICDY=$$SYS^ICDEX(ICDC)
S ICDF=$$FILE^ICDEX(+ICDY)
Q:'$L(ICDC)&(ICDY'>0) "" S ICDS=0,ICDE=""
S:+ICDY>0 ICDS=+ICDY I $L(ICDC) D
. S:"^80^80.1^"'[("^"_ICDF_"^") ICDF=$$CODEFI^ICDEX(ICDC)
. S ICDE=$P($$CODECS^ICDEX(ICDC,ICDF),"^",1) S:ICDS>0 ICDE=ICDS
Q:+ICDY>0&(+($G(ICDE))>0)&(+ICDY'=+($G(ICDE))) ""
S:+ICDS'>0&(+($G(ICDE))>0) ICDS=+($G(ICDE)) Q:+ICDS'>0 ""
S ICDR=$$ROOT^ICDEX(ICDS) Q:'$L(ICDR) ""
S ICDO=$$NUM^ICDEX(ICDC) Q:$L(ICDC)&(+ICDO'>0) ""
I 'ICDB D Q $S(ICDC="":"",1:ICDC)
. S:+ICDO'>0 ICDO=$O(@(ICDR_"""AN"","_+ICDS_","" "")"),-1)+1
. S ICDN=0,ICDC=""
. S ICDN=$O(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")"),-1)
. S ICDC=$S(+ICDN>0:$$COD^ICDEX(+ICDN),1:"")
I ICDB S ICDC="" D Q $S(ICDC="":"",1:ICDC)
. N ICDA S ICDA="" S:+ICDO'>0 ICDO=$O(@(ICDR_"""AN"","_+ICDS_","" "")"),-1)+1
. F S ICDO=$O(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")"),-1) Q:+ICDO'>0 D Q:$L(ICDC)
. . N ICDI S ICDI=0 F S ICDI=$O(@(ICDR_"""AN"","_+ICDS_","_+ICDO_","_+ICDI_")")) Q:+ICDI'>0 D Q:$L(ICDC)
. . . N ICDE,ICDH S ICDE=$O(@(ICDR_+ICDI_",66,""B"","_(ICDD+.001)_")"),-1) Q:ICDE'?7N
. . . S ICDH=$O(@(ICDR_+ICDI_",66,""B"","_ICDE_","" "")"),-1) Q:+ICDH'>0
. . . S ICDA=$G(@(ICDR_+ICDI_",66,"_ICDH_",0)")),ICDA=+($P(ICDA,"^",2))
. . . S:+ICDA>0 ICDC=ICDO S ICDC=$S(+($G(ICDC))>0:$$COD^ICDEX(+ICDC),1:"")
Q $S(ICDC="":"",1:ICDC)
HIST(CODE,ARY,SYS) ; Activation History
;
; Input:
;
; CODE ICD Code (required)
; .ARY Array, passed by Reference (required)
; SYS Coding System - see ^ICDS
;
; 1 = ICD-9-CM
; 2 = ICD-9-PCS
; 30 = ICD-10-CM
; 31 = ICD-10-PCS
;
; Output: Mirrors ARY(0) (or, -1 on error)
;
; ARY(0) = Number of Activation History Entries
; ARY(<date>) = status where: 1 is Active
; ARY("IEN") = <ien>
;
Q:$G(CODE)="" -1 K ARY
N ICDC,ICDF,ICDS,ICDE,ICDI,ICDA,ICDN,ICDD,ICDR,ICDF,ICDS,ICDY
S ICDC=$TR($G(CODE)," ","") Q:'$L(ICDC) -1 S ICDY=$$SYS^ICDEX($G(SYS))
S:+ICDY'>0 ICDY=$$SYS^ICDEX(ICDC)
S ICDS=0 S:+ICDY>0 ICDS=+ICDY
S ICDF=$$CODEFI^ICDEX(ICDC) Q:+ICDF'>0 -1
S ICDE=$P($$CODECS^ICDEX(ICDC,ICDF),"^",1) Q:+ICDE'>0 -1
S:+ICDS'>0&(+ICDE>0) ICDS=ICDE
Q:+ICDS>0&(ICDS'=+ICDE) -1
S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) -1
S ICDI=$$CODEABA^ICDEX(ICDC,ICDR,+ICDS) Q:+ICDI'>0 -1
S ICDE=$P($G(@(ICDR_ICDI_",1)")),"^",1) Q:+ICDS>0&(ICDS'=+ICDE) -1
S ARY("IEN")=ICDI,ICDA="" M ICDA=@(ICDR_ICDI_",66)")
K ICDA("B") S ARY(0)=+($P($G(ICDA(0)),"^",4))
S:+ARY(0)=0 ARY(0)=-1 K:ARY(0)=-1 ARY("IEN")
S (ICDI,ICDC)=0 F S ICDI=$O(ICDA(ICDI)) Q:+ICDI=0 D
. S ICDD=$P($G(ICDA(ICDI,0)),"^",1) Q:+ICDD=0
. S ICDF=$P($G(ICDA(ICDI,0)),"^",2) Q:'$L(ICDF)
. S ICDC=ICDC+1,ARY(0)=ICDC,ARY(ICDD)=ICDF
Q ARY(0)
PERIOD(CODE,ARY,SYS) ; Return Activation/Inactivation Period in ARY
;
; Input:
;
; CODE ICD Code (required)
; ARY Array, passed by Reference (required)
; SYS Coding System - see ^ICDS
;
; 1 = ICD-9-CM
; 2 = ICD-9-PCS
; 30 = ICD-10-CM
; 31 = ICD-10-PCS
;
; Output:
;
; $$PERIOD Number of activation periods found
;
; ARY(0) = IEN ^ Selectable ^ Error Message
;
; Where IEN = -1 if error
; Selectable = 0 for unselectable
; Error Message if applicable
;
; ARY(Activation Date) = Inactivation Date^Short Name
;
; Where the Short Name is versioned as follows:
;
; Period is active - Text for TODAY's date
; Period is inactive - Text for inactivation date
;
I $G(CODE)="" S ARY(0)="-1^0^Code not specified" Q 0
K ARY N ICD1,ICDC,ICDBA,ICDF,ICDG,ICDS,ICDE,ICDI,ICDI,ICDA,ICDN,ICDD,ICDR,ICDF,ICDS,ICDY,ICDP,ICDT
S ICDC=$TR($G(CODE)," ","") I '$L(ICDC) S ARY(0)="-1^0^Invalid Code specified" Q 0
I $D(^ICD9("AVA",(CODE_" ")))!($D(^ICD0("AVA",(CODE_" ")))) S ARY(0)="-1^0^Invalid Code specified" Q 0
S ICDY=$$SYS^ICDEX($G(SYS))
I +ICDY'>0 D
. N ICDF,ICDE S ICDF=$$CODEFI^ICDEX(ICDC) Q:+ICDF'>0
. S ICDE=$P($$CODECS^ICDEX(ICDC,ICDF),"^",1) Q:+ICDE'>0
. S ICDY=$$SYS^ICDEX(ICDE)
S ICDS=+($G(ICDY)) I +ICDS'>0 S ARY(0)="-1^0^Invalid or undetermined Coding System" Q 0
S ICDR=$$ROOT^ICDEX(ICDS) I '$L(ICDR) S ARY(0)="-1^0^Undetermined global root" Q 0
S ICDI=$$CODEABA^ICDEX(ICDC,ICDR,+ICDS) I +ICDI'>0 S ARY(0)="-1^0^IEN not found" Q 0
S ICDP=$S(ICDR["ICD9":3,1:4),ICD1=$G(@(ICDR_ICDI_",1)")),ICDN=$$MRST(ICDR,ICDI)
S ICDG=ICDR_ICDI_",67,",ICDT=$O(@(ICDG_"""B"","" "")"),-1),ICDT=$O(@(ICDG_"""B"","_+ICDT_","" "")"),-1)
S ICDT=$P($G(@(ICDG_+ICDT_",0)")),"^",2),ARY(0)=ICDI_"^"_'$P(ICD1,"^",7)
S (ICDA,ICDBA)=0,ICDG=ICDR_ICDI_",66,"
F Q:ICDBA D
. N ICDBI,ICDCA,ICDST,ICDV S ICDA=$O(@(ICDG_"""B"","_ICDA_")"))
. I ICDA="" S ICDBA=1 Q
. S ICDF=$O(@(ICDG_"""B"","_ICDA_",0)"))
. I '+ICDF S ICDBA=1 Q
. S ICDST=$P($G(@(ICDG_ICDF_",0)")),"^",2)
. Q:'ICDST ;outer loop looks for active
. ; Versioned text for activation date
. S ICDV=$$MRST(ICDR,ICDI) S:$L(ICDV) ICDT=ICDV
. S ARY(ICDA)="^"_ICDT,ICDBI=0,ICDI=ICDA
. F Q:ICDBI D
. . S ICDI=$O(@(ICDG_"""B"","_ICDI_")"))
. . ; If no inactivation date for ICDA then use TODAY's text
. . I ICDI="" S ARY(ICDA)="^"_ICDN,(ICDBI,ICDBA)=1 Q
. . S ICDF=$O(@(ICDG_"""B"","_ICDI_",0)"))
. . ; If no effective date ICDF for ICDI then use TODAY's text
. . I '+ICDF S ARY(ICDA)="^"_ICDN,(ICDBI,ICDBA)=1 Q
. . S ICDST=$P($G(@(ICDG_ICDF_",0)")),"^",2)
. . ; If Status ICDST not Inactive then use TODAY's text
. . I ICDST S ARY(ICDA)="^"_ICDN,ICDBI=1 Q
. . ; Versioned text for inactive date
. . S ICDV=$$MRST(ICDR,+($G(ARY(0))),ICDI)
. . S:$L(ICDV) $P(ARY(ICDA),"^",2)=ICDV
. . S $P(ARY(ICDA),"^")=ICDI
. . S ICDBI=1,ICDA=ICDI,ICDCA=0
S (ICDI,ICDC)=0 F S ICDI=$O(ARY(ICDI)) Q:+ICDI'>0 S ICDC=ICDC+1
S:ICDC'>0 ARY(0)="-1^0^No activation periods found"
Q ICDC
MRST(ICD,X,Y) ; Most Recent Description from Date
N ICDI,ICDT,ICDE,ICDH,ICDR S ICDR=$G(ICD),ICDI=+($G(X)),ICDT=$G(Y)
Q:'$L(ICDR)!(ICDR'["^")!(ICDR'["(") "" Q:+ICDI'>0 "" I ICDT'>0 D Q X
. N ICDE,ICDH S ICDE=+($O(@(ICDR_+ICDI_",67,""B"","" "")"),-1))
. S ICDH=+($O(@(ICDR_+ICDI_",67,""B"","_ICDE_","" "")"),-1))
. S X=$P($G(@(ICDR_+ICDI_",67,"_ICDH_",0)")),"^",2)
S ICDE=+($O(@(ICDR_+ICDI_",67,""B"","_+ICDT_")"),-1))
S ICDH=+($O(@(ICDR_+ICDI_",67,""B"","_ICDE_","" "")"),-1))
S X=$P($G(@(ICDR_+ICDI_",67,"_ICDH_",0)")),"^",2)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXA2 9786 printed Sep 23, 2025@19:26:32 Page 2
ICDEXA2 ;SLC/KER - ICD Extractor - APIs/Utilities (cont) ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^ICD0("AVA" N/A
+5 ; ^ICD9("AVA" N/A
+6 ;
+7 ; External References
+8 ; $$DT^XLFDT ICR 10103
+9 ;
+10 QUIT
NEXT(CODE,SYS,CDT) ; Next ICD Code (active or inactive)
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD Code or Null for the first code
+5 ; SYS Coding System - see ^ICDS
+6 ;
+7 ; 1 = ICD-9-CM
+8 ; 2 = ICD-9-PCS
+9 ; 30 = ICD-10-CM
+10 ; 31 = ICD-10-PCS
+11 ;
+12 ; CDT Code Date to check
+13 ; If CDT is passed, then the code
+14 ; returned is the next active code
+15 ; based on date. If it is not
+16 ; passed then the next code is
+17 ; returned regardless of status.
+18 ;
+19 ; Output:
+20 ;
+21 ; The Next ICD Code, Null if none
+22 ;
+23 NEW ICDB,ICDC,ICDG,ICDF,ICDD,ICDE,ICDI,ICDR,ICDS,ICDO,ICDN,ICDY
+24 SET ICDC=$TRANSLATE($GET(CODE)," ","")
SET ICDD=$GET(CDT)
SET ICDB=ICDD?7N
+25 SET ICDY=$$SYS^ICDEX(+($GET(SYS)))
+26 if ICDY'>0&($LENGTH(ICDC))
SET ICDY=$$SYS^ICDEX(ICDC)
+27 SET ICDF=$$FILE^ICDEX(+ICDY)
+28 if '$LENGTH(ICDC)&(ICDY'>0)
QUIT ""
SET ICDS=0
SET ICDE=""
+29 if +ICDY>0
SET ICDS=+ICDY
IF $LENGTH(ICDC)
Begin DoDot:1
+30 if "^80^80.1^"'[("^"_ICDF_"^")
SET ICDF=$$CODEFI^ICDEX(ICDC)
+31 SET ICDE=$PIECE($$CODECS^ICDEX(ICDC,ICDF),"^",1)
if ICDS>0
SET ICDE=ICDS
End DoDot:1
+32 if +ICDY>0&(+($GET(ICDE))>0)&(+ICDY'=+($GET(ICDE)))
QUIT ""
+33 if +ICDS'>0&(+($GET(ICDE))>0)
SET ICDS=+($GET(ICDE))
+34 if +ICDS'>0
QUIT ""
SET ICDR=$$ROOT^ICDEX(ICDS)
if '$LENGTH(ICDR)
QUIT ""
+35 SET ICDO=$$NUM^ICDEX(ICDC)
if $LENGTH(ICDC)&(+ICDO'>0)
QUIT ""
+36 IF 'ICDB
SET ICDC=""
Begin DoDot:1
+37 SET ICDN=$ORDER(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")"))
+38 SET ICDC=$SELECT(+ICDN>0:$$COD^ICDEX(+ICDN),1:"")
End DoDot:1
QUIT $SELECT(ICDC="":"",1:ICDC)
+39 IF ICDB
SET ICDC=""
Begin DoDot:1
+40 NEW ICDA
SET ICDA=""
FOR
SET ICDO=$ORDER(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")"))
if +ICDO'>0
QUIT
Begin DoDot:2
+41 NEW ICDI
SET ICDI=0
FOR
SET ICDI=$ORDER(@(ICDR_"""AN"","_+ICDS_","_+ICDO_","_+ICDI_")"))
if +ICDI'>0
QUIT
Begin DoDot:3
+42 NEW ICDE,ICDH
SET ICDE=$ORDER(@(ICDR_+ICDI_",66,""B"","_(ICDD+.001)_")"),-1)
if ICDE'?7N
QUIT
+43 SET ICDH=$ORDER(@(ICDR_+ICDI_",66,""B"","_ICDE_","" "")"),-1)
if +ICDH'>0
QUIT
+44 SET ICDA=$GET(@(ICDR_+ICDI_",66,"_ICDH_",0)"))
SET ICDA=+($PIECE(ICDA,"^",2))
+45 if +ICDA>0
SET ICDC=ICDO
SET ICDC=$SELECT(+($GET(ICDC))>0:$$COD^ICDEX(+ICDC),1:"")
End DoDot:3
if $LENGTH(ICDC)
QUIT
End DoDot:2
if $LENGTH(ICDC)
QUIT
End DoDot:1
QUIT $SELECT(ICDC="":"",1:ICDC)
+46 QUIT $SELECT(ICDC="":"",1:ICDC)
PREV(CODE,SYS,CDT) ; Previous ICD Code (active or inactive)
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD Code or Null for the last code
+5 ; SYS Coding System - see ^ICDS
+6 ;
+7 ; 1 = ICD-9-CM
+8 ; 2 = ICD-9-PCS
+9 ; 30 = ICD-10-CM
+10 ; 31 = ICD-10-PCS
+11 ;
+12 ; CDT Code Date to check
+13 ; If CDT is passed, then the code
+14 ; returned is the previous active
+15 ; code based on date. If it is
+16 ; not passed then the previous
+17 ; code is returned regardless of
+18 ; status.
+19 ;
+20 ; Output:
+21 ;
+22 ; The Previous ICD Code, Null if none
+23 ;
+24 NEW ICDB,ICDC,ICDG,ICDF,ICDD,ICDE,ICDI,ICDR,ICDS,ICDO,ICDN,ICDY
+25 SET ICDC=$TRANSLATE($GET(CODE)," ","")
SET ICDD=$GET(CDT)
SET ICDB=ICDD?7N
+26 SET ICDY=$$SYS^ICDEX(+($GET(SYS)))
+27 if ICDY'>0&($LENGTH(ICDC))
SET ICDY=$$SYS^ICDEX(ICDC)
+28 SET ICDF=$$FILE^ICDEX(+ICDY)
+29 if '$LENGTH(ICDC)&(ICDY'>0)
QUIT ""
SET ICDS=0
SET ICDE=""
+30 if +ICDY>0
SET ICDS=+ICDY
IF $LENGTH(ICDC)
Begin DoDot:1
+31 if "^80^80.1^"'[("^"_ICDF_"^")
SET ICDF=$$CODEFI^ICDEX(ICDC)
+32 SET ICDE=$PIECE($$CODECS^ICDEX(ICDC,ICDF),"^",1)
if ICDS>0
SET ICDE=ICDS
End DoDot:1
+33 if +ICDY>0&(+($GET(ICDE))>0)&(+ICDY'=+($GET(ICDE)))
QUIT ""
+34 if +ICDS'>0&(+($GET(ICDE))>0)
SET ICDS=+($GET(ICDE))
if +ICDS'>0
QUIT ""
+35 SET ICDR=$$ROOT^ICDEX(ICDS)
if '$LENGTH(ICDR)
QUIT ""
+36 SET ICDO=$$NUM^ICDEX(ICDC)
if $LENGTH(ICDC)&(+ICDO'>0)
QUIT ""
+37 IF 'ICDB
Begin DoDot:1
+38 if +ICDO'>0
SET ICDO=$ORDER(@(ICDR_"""AN"","_+ICDS_","" "")"),-1)+1
+39 SET ICDN=0
SET ICDC=""
+40 SET ICDN=$ORDER(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")"),-1)
+41 SET ICDC=$SELECT(+ICDN>0:$$COD^ICDEX(+ICDN),1:"")
End DoDot:1
QUIT $SELECT(ICDC="":"",1:ICDC)
+42 IF ICDB
SET ICDC=""
Begin DoDot:1
+43 NEW ICDA
SET ICDA=""
if +ICDO'>0
SET ICDO=$ORDER(@(ICDR_"""AN"","_+ICDS_","" "")"),-1)+1
+44 FOR
SET ICDO=$ORDER(@(ICDR_"""AN"","_+ICDS_","_+ICDO_")"),-1)
if +ICDO'>0
QUIT
Begin DoDot:2
+45 NEW ICDI
SET ICDI=0
FOR
SET ICDI=$ORDER(@(ICDR_"""AN"","_+ICDS_","_+ICDO_","_+ICDI_")"))
if +ICDI'>0
QUIT
Begin DoDot:3
+46 NEW ICDE,ICDH
SET ICDE=$ORDER(@(ICDR_+ICDI_",66,""B"","_(ICDD+.001)_")"),-1)
if ICDE'?7N
QUIT
+47 SET ICDH=$ORDER(@(ICDR_+ICDI_",66,""B"","_ICDE_","" "")"),-1)
if +ICDH'>0
QUIT
+48 SET ICDA=$GET(@(ICDR_+ICDI_",66,"_ICDH_",0)"))
SET ICDA=+($PIECE(ICDA,"^",2))
+49 if +ICDA>0
SET ICDC=ICDO
SET ICDC=$SELECT(+($GET(ICDC))>0:$$COD^ICDEX(+ICDC),1:"")
End DoDot:3
if $LENGTH(ICDC)
QUIT
End DoDot:2
if $LENGTH(ICDC)
QUIT
End DoDot:1
QUIT $SELECT(ICDC="":"",1:ICDC)
+50 QUIT $SELECT(ICDC="":"",1:ICDC)
HIST(CODE,ARY,SYS) ; Activation History
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD Code (required)
+5 ; .ARY Array, passed by Reference (required)
+6 ; SYS Coding System - see ^ICDS
+7 ;
+8 ; 1 = ICD-9-CM
+9 ; 2 = ICD-9-PCS
+10 ; 30 = ICD-10-CM
+11 ; 31 = ICD-10-PCS
+12 ;
+13 ; Output: Mirrors ARY(0) (or, -1 on error)
+14 ;
+15 ; ARY(0) = Number of Activation History Entries
+16 ; ARY(<date>) = status where: 1 is Active
+17 ; ARY("IEN") = <ien>
+18 ;
+19 if $GET(CODE)=""
QUIT -1
KILL ARY
+20 NEW ICDC,ICDF,ICDS,ICDE,ICDI,ICDA,ICDN,ICDD,ICDR,ICDF,ICDS,ICDY
+21 SET ICDC=$TRANSLATE($GET(CODE)," ","")
if '$LENGTH(ICDC)
QUIT -1
SET ICDY=$$SYS^ICDEX($GET(SYS))
+22 if +ICDY'>0
SET ICDY=$$SYS^ICDEX(ICDC)
+23 SET ICDS=0
if +ICDY>0
SET ICDS=+ICDY
+24 SET ICDF=$$CODEFI^ICDEX(ICDC)
if +ICDF'>0
QUIT -1
+25 SET ICDE=$PIECE($$CODECS^ICDEX(ICDC,ICDF),"^",1)
if +ICDE'>0
QUIT -1
+26 if +ICDS'>0&(+ICDE>0)
SET ICDS=ICDE
+27 if +ICDS>0&(ICDS'=+ICDE)
QUIT -1
+28 SET ICDR=$$ROOT^ICDEX(ICDF)
if '$LENGTH(ICDR)
QUIT -1
+29 SET ICDI=$$CODEABA^ICDEX(ICDC,ICDR,+ICDS)
if +ICDI'>0
QUIT -1
+30 SET ICDE=$PIECE($GET(@(ICDR_ICDI_",1)")),"^",1)
if +ICDS>0&(ICDS'=+ICDE)
QUIT -1
+31 SET ARY("IEN")=ICDI
SET ICDA=""
MERGE ICDA=@(ICDR_ICDI_",66)")
+32 KILL ICDA("B")
SET ARY(0)=+($PIECE($GET(ICDA(0)),"^",4))
+33 if +ARY(0)=0
SET ARY(0)=-1
if ARY(0)=-1
KILL ARY("IEN")
+34 SET (ICDI,ICDC)=0
FOR
SET ICDI=$ORDER(ICDA(ICDI))
if +ICDI=0
QUIT
Begin DoDot:1
+35 SET ICDD=$PIECE($GET(ICDA(ICDI,0)),"^",1)
if +ICDD=0
QUIT
+36 SET ICDF=$PIECE($GET(ICDA(ICDI,0)),"^",2)
if '$LENGTH(ICDF)
QUIT
+37 SET ICDC=ICDC+1
SET ARY(0)=ICDC
SET ARY(ICDD)=ICDF
End DoDot:1
+38 QUIT ARY(0)
PERIOD(CODE,ARY,SYS) ; Return Activation/Inactivation Period in ARY
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD Code (required)
+5 ; ARY Array, passed by Reference (required)
+6 ; SYS Coding System - see ^ICDS
+7 ;
+8 ; 1 = ICD-9-CM
+9 ; 2 = ICD-9-PCS
+10 ; 30 = ICD-10-CM
+11 ; 31 = ICD-10-PCS
+12 ;
+13 ; Output:
+14 ;
+15 ; $$PERIOD Number of activation periods found
+16 ;
+17 ; ARY(0) = IEN ^ Selectable ^ Error Message
+18 ;
+19 ; Where IEN = -1 if error
+20 ; Selectable = 0 for unselectable
+21 ; Error Message if applicable
+22 ;
+23 ; ARY(Activation Date) = Inactivation Date^Short Name
+24 ;
+25 ; Where the Short Name is versioned as follows:
+26 ;
+27 ; Period is active - Text for TODAY's date
+28 ; Period is inactive - Text for inactivation date
+29 ;
+30 IF $GET(CODE)=""
SET ARY(0)="-1^0^Code not specified"
QUIT 0
+31 KILL ARY
NEW ICD1,ICDC,ICDBA,ICDF,ICDG,ICDS,ICDE,ICDI,ICDI,ICDA,ICDN,ICDD,ICDR,ICDF,ICDS,ICDY,ICDP,ICDT
+32 SET ICDC=$TRANSLATE($GET(CODE)," ","")
IF '$LENGTH(ICDC)
SET ARY(0)="-1^0^Invalid Code specified"
QUIT 0
+33 IF $DATA(^ICD9("AVA",(CODE_" ")))!($DATA(^ICD0("AVA",(CODE_" "))))
SET ARY(0)="-1^0^Invalid Code specified"
QUIT 0
+34 SET ICDY=$$SYS^ICDEX($GET(SYS))
+35 IF +ICDY'>0
Begin DoDot:1
+36 NEW ICDF,ICDE
SET ICDF=$$CODEFI^ICDEX(ICDC)
if +ICDF'>0
QUIT
+37 SET ICDE=$PIECE($$CODECS^ICDEX(ICDC,ICDF),"^",1)
if +ICDE'>0
QUIT
+38 SET ICDY=$$SYS^ICDEX(ICDE)
End DoDot:1
+39 SET ICDS=+($GET(ICDY))
IF +ICDS'>0
SET ARY(0)="-1^0^Invalid or undetermined Coding System"
QUIT 0
+40 SET ICDR=$$ROOT^ICDEX(ICDS)
IF '$LENGTH(ICDR)
SET ARY(0)="-1^0^Undetermined global root"
QUIT 0
+41 SET ICDI=$$CODEABA^ICDEX(ICDC,ICDR,+ICDS)
IF +ICDI'>0
SET ARY(0)="-1^0^IEN not found"
QUIT 0
+42 SET ICDP=$SELECT(ICDR["ICD9":3,1:4)
SET ICD1=$GET(@(ICDR_ICDI_",1)"))
SET ICDN=$$MRST(ICDR,ICDI)
+43 SET ICDG=ICDR_ICDI_",67,"
SET ICDT=$ORDER(@(ICDG_"""B"","" "")"),-1)
SET ICDT=$ORDER(@(ICDG_"""B"","_+ICDT_","" "")"),-1)
+44 SET ICDT=$PIECE($GET(@(ICDG_+ICDT_",0)")),"^",2)
SET ARY(0)=ICDI_"^"_'$PIECE(ICD1,"^",7)
+45 SET (ICDA,ICDBA)=0
SET ICDG=ICDR_ICDI_",66,"
+46 FOR
if ICDBA
QUIT
Begin DoDot:1
+47 NEW ICDBI,ICDCA,ICDST,ICDV
SET ICDA=$ORDER(@(ICDG_"""B"","_ICDA_")"))
+48 IF ICDA=""
SET ICDBA=1
QUIT
+49 SET ICDF=$ORDER(@(ICDG_"""B"","_ICDA_",0)"))
+50 IF '+ICDF
SET ICDBA=1
QUIT
+51 SET ICDST=$PIECE($GET(@(ICDG_ICDF_",0)")),"^",2)
+52 ;outer loop looks for active
if 'ICDST
QUIT
+53 ; Versioned text for activation date
+54 SET ICDV=$$MRST(ICDR,ICDI)
if $LENGTH(ICDV)
SET ICDT=ICDV
+55 SET ARY(ICDA)="^"_ICDT
SET ICDBI=0
SET ICDI=ICDA
+56 FOR
if ICDBI
QUIT
Begin DoDot:2
+57 SET ICDI=$ORDER(@(ICDG_"""B"","_ICDI_")"))
+58 ; If no inactivation date for ICDA then use TODAY's text
+59 IF ICDI=""
SET ARY(ICDA)="^"_ICDN
SET (ICDBI,ICDBA)=1
QUIT
+60 SET ICDF=$ORDER(@(ICDG_"""B"","_ICDI_",0)"))
+61 ; If no effective date ICDF for ICDI then use TODAY's text
+62 IF '+ICDF
SET ARY(ICDA)="^"_ICDN
SET (ICDBI,ICDBA)=1
QUIT
+63 SET ICDST=$PIECE($GET(@(ICDG_ICDF_",0)")),"^",2)
+64 ; If Status ICDST not Inactive then use TODAY's text
+65 IF ICDST
SET ARY(ICDA)="^"_ICDN
SET ICDBI=1
QUIT
+66 ; Versioned text for inactive date
+67 SET ICDV=$$MRST(ICDR,+($GET(ARY(0))),ICDI)
+68 if $LENGTH(ICDV)
SET $PIECE(ARY(ICDA),"^",2)=ICDV
+69 SET $PIECE(ARY(ICDA),"^")=ICDI
+70 SET ICDBI=1
SET ICDA=ICDI
SET ICDCA=0
End DoDot:2
End DoDot:1
+71 SET (ICDI,ICDC)=0
FOR
SET ICDI=$ORDER(ARY(ICDI))
if +ICDI'>0
QUIT
SET ICDC=ICDC+1
+72 if ICDC'>0
SET ARY(0)="-1^0^No activation periods found"
+73 QUIT ICDC
MRST(ICD,X,Y) ; Most Recent Description from Date
+1 NEW ICDI,ICDT,ICDE,ICDH,ICDR
SET ICDR=$GET(ICD)
SET ICDI=+($GET(X))
SET ICDT=$GET(Y)
+2 if '$LENGTH(ICDR)!(ICDR'["^")!(ICDR'["(")
QUIT ""
if +ICDI'>0
QUIT ""
IF ICDT'>0
Begin DoDot:1
+3 NEW ICDE,ICDH
SET ICDE=+($ORDER(@(ICDR_+ICDI_",67,""B"","" "")"),-1))
+4 SET ICDH=+($ORDER(@(ICDR_+ICDI_",67,""B"","_ICDE_","" "")"),-1))
+5 SET X=$PIECE($GET(@(ICDR_+ICDI_",67,"_ICDH_",0)")),"^",2)
End DoDot:1
QUIT X
+6 SET ICDE=+($ORDER(@(ICDR_+ICDI_",67,""B"","_+ICDT_")"),-1))
+7 SET ICDH=+($ORDER(@(ICDR_+ICDI_",67,""B"","_ICDE_","" "")"),-1))
+8 SET X=$PIECE($GET(@(ICDR_+ICDI_",67,"_ICDH_",0)")),"^",2)
+9 QUIT X
