ICDEXA2.m

ICDEXA2 ;SLC/KER - ICD Extractor - APIs/Utilities (cont) ;04/21/2014

 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7

 ;               

 ; 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

ICDEXA2   ;SLC/KER - ICD Extractor - APIs/Utilities (cont) ;04/21/2014

 +1       ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7

 +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=""