Routine: ICD9IDX

ICD9IDX ;DLS/DEK - MUMPS Cross Reference Routine for History ;28-Mar-2011 09:11;DU

 ;;18.0;DRG Grouper;**6,1003**;Oct 20, 2000;Build 2

 ;Modified - IHS/MCS/PLS - 03/28/2011 - Line SHIS+5

 ; ICDCOD          ICD Code from Global

 ; ICDCODX         ICD Code passed in (X)

 ; ICDEFF          Effective Date

 ; ICDSTA          Status

 ; ICDNOD          Global Node (to reduce Global hits)

 ; DA              ien file 80 or 80.066

 ; ICDIEN,DA(1)    ien of file 80

 ; ICDHIS          ien of file 80.066

 ; X               Data passed in to be indexed

 ; Set and Kill Activation History

 ;   File 80, field .01

SAHC ; Set new value when ICD Code is Edited

 ; ^DD(80,.01,1,D0,1) = D SAHC^ICD9IDX

 N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN

 S ICDCODX=$G(X) Q:'$L(ICDCODX)  S ICDIEN=+($G(DA)) Q:+ICDIEN'>0  Q:'$D(^ICD9(+ICDIEN,66))

 S ICDHIS=0 F  S ICDHIS=$O(^ICD9(+ICDIEN,66,ICDHIS)) Q:+ICDHIS=0  D

 . N DA,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC

 . S ICDCOD=ICDCODX Q:'$L($G(ICDCOD))

 . Q:'$L($G(ICDEFF))  Q:'$L($G(ICDSTA))  D SHIS

KAHC ; Kill old value when ICD Code is Edited

 ; ^DD(80,.01,1,D0,2) = D KAHC^ICD9IDX

 N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN

 S ICDCODX=$G(X) Q:'$L(ICDCODX)  S ICDIEN=+($G(DA)) Q:+ICDIEN'>0  Q:'$D(^ICD9(+ICDIEN,66))

 S ICDHIS=0 F  S ICDHIS=$O(^ICD9(+ICDIEN,66,ICDHIS)) Q:+ICDHIS=0  D

 . N DA,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC

 . S ICDCOD=ICDCODX Q:'$L($G(ICDCOD))

 . Q:'$L($G(ICDEFF))  Q:'$L($G(ICDSTA))  D KHIS

 ; File 80.066, field .01

SAHD ; Set new value when Effective Date is Edited

 ; ^DD(80.066,.01,1,D0,1) = D SAHD^ICD9IDX

 N ICDNOD,ICDSTA,ICDEFF,ICDCOD

 D HDC Q:'$L($G(ICDCOD))  Q:'$L($G(ICDSTA))  S ICDEFF=+($G(X)) Q:+ICDEFF=0  D SHIS

KAHD ; Kill old value when Effective Date is Edited

 ; ^DD(80.066,.01,1,D0,2) = D KAHD^ICD9IDX

 N ICDNOD,ICDSTA,ICDEFF,ICDCOD

 D HDC Q:'$L($G(ICDCOD))  Q:'$L($G(ICDSTA))

 S ICDEFF=+($G(X)) Q:+ICDEFF=0  D KHIS

 ; File 80.066, field .02

SAHS ; Set new value when Status is Edited

 ; ^DD(80.066,.02,1,D0,1) = D SAHS^ICD9IDX

 N ICDNOD,ICDSTA,ICDEFF,ICDCOD

 D HDC Q:'$L($G(ICDCOD))  Q:+ICDEFF=0

 S ICDSTA=$G(X) Q:'$L(ICDSTA)  D SHIS

KAHS ; Kill old value when Status is Edited

 ; ^DD(80.066,.02,1,D0,2) = D KAHS^ICD9IDX

 N ICDNOD,ICDSTA,ICDEFF,ICDCOD

 D HDC Q:'$L($G(ICDCOD))  Q:+ICDEFF=0

 S ICDSTA=$G(X) Q:'$L(ICDSTA)  D KHIS

HDC ;  Set Common Variables (Code, Status and Effective Date)

 S (ICDCOD,ICDSTA,ICDEFF)=""

 Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  Q:'$D(^ICD9(+($G(DA(1))),66,+($G(DA)),0))

 S ICDCOD=$P($G(^ICD9(+($G(DA(1))),0)),"^",1),ICDNOD=$G(^ICD9(+($G(DA(1))),66,+($G(DA)),0))

 S ICDSTA=$P(ICDNOD,"^",2),ICDEFF=$P(ICDNOD,"^",1)

SHIS ; Set Index ^ICD9("ACT",<code>,<status>,<date>,<ien>,<history>)

 Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  Q:'$D(^ICD9(+($G(DA(1))),66,+($G(DA)),0))

 S ^ICD9("ACT",(ICDCOD_" "),ICDSTA,ICDEFF,DA(1),DA)=""

 N PIECE,INACT S PIECE=$S('ICDSTA:11,1:16),INACT=$S('ICDSTA:1,1:"")

 S $P(^ICD9(DA(1),0),"^",9)=INACT,$P(^ICD9(DA(1),0),"^",PIECE)=ICDEFF

 ;IHS/MSC/PLS - 03/28/2011 - NEW LINE

 S:INACT="" $P(^ICD9(DA(1),0),"^",11)=""

KHIS ; Kill Index ^ICD9("ACT",<code>,<status>,<date>,<ien>,<history>)

 Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0  Q:'$D(^ICD9(+($G(DA(1))),66,+($G(DA)),0))

 N PIECE,INACT,IEN,OPP,OPPSTA,OPPEFF,BOOL

 S PIECE=$S('ICDSTA:11,1:16),INACT=$S('ICDSTA:"",1:1),OPPEFF=ICDEFF,BOOL=0

 F  S OPPEFF=$O(^ICD9(DA(1),66,"B",OPPEFF),-1) Q:'OPPEFF!BOOL  D

 . S IEN=$O(^ICD9(DA(1),66,"B",OPPEFF,""))

 . I 'IEN S OPPEFF="" Q

 . S OPP=$G(^ICD9(DA(1),66,IEN,0)),OPPEFF=$P($G(OPP),"^",1)

 . S OPPSTA=$P($G(OPP),"^",2),BOOL=OPPSTA'=ICDSTA

 I BOOL D

 . S $P(^ICD9(DA(1),0),"^",9)=INACT,$P(^ICD9(DA(1),0),"^",PIECE)=$G(OPPEFF)

 E  S $P(^ICD9(DA(1),0),"^",9)=1,$P(^ICD9(DA(1),0),"^",11)="",$P(^ICD9(DA(1),0),"^",16)=""

 K ^ICD9("ACT",(ICDCOD_" "),ICDSTA,ICDEFF,DA(1),DA)

ICD9IDX   ;DLS/DEK - MUMPS Cross Reference Routine for History ;28-Mar-2011 09:11;DU

 +1       ;;18.0;DRG Grouper;**6,1003**;Oct 20, 2000;Build 2

 +2       ;Modified - IHS/MCS/PLS - 03/28/2011 - Line SHIS+5

 +3       ;

 +4       ; ICDCOD          ICD Code from Global

 +5       ; ICDCODX         ICD Code passed in (X)

 +6       ; ICDEFF          Effective Date

 +7       ; ICDSTA          Status

 +8       ; ICDNOD          Global Node (to reduce Global hits)

 +9       ; DA              ien file 80 or 80.066

 +10      ; ICDIEN,DA(1)    ien of file 80

 +11      ; ICDHIS          ien of file 80.066

 +12      ; X               Data passed in to be indexed

 +13      ;

 +14      ; Set and Kill Activation History

 +15      ;

 +16      ;   File 80, field .01

SAHC      ; Set new value when ICD Code is Edited

 +1       ; ^DD(80,.01,1,D0,1) = D SAHC^ICD9IDX

 +2        NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN

 +3        SET ICDCODX=$GET(X)

           IF '$LENGTH(ICDCODX)

               QUIT

           SET ICDIEN=+($GET(DA))

           IF +ICDIEN'>0

               QUIT

           IF '$DATA(^ICD9(+ICDIEN,66))

               QUIT

 +4        SET ICDHIS=0

FOR

               SET ICDHIS=$ORDER(^ICD9(+ICDIEN,66,ICDHIS))

               IF +ICDHIS=0

                   QUIT

               Begin DoDot:1

 +5                NEW DA,X

                   SET DA=+ICDHIS

                   SET DA(1)=+ICDIEN

                   DO HDC

 +6                SET ICDCOD=ICDCODX

                   IF '$LENGTH($GET(ICDCOD))

                       QUIT

 +7                IF '$LENGTH($GET(ICDEFF))

                       QUIT

                   IF '$LENGTH($GET(ICDSTA))

                       QUIT

                   DO SHIS

               End DoDot:1

 +8        QUIT

KAHC      ; Kill old value when ICD Code is Edited

 +1       ; ^DD(80,.01,1,D0,2) = D KAHC^ICD9IDX

 +2        NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN

 +3        SET ICDCODX=$GET(X)

           IF '$LENGTH(ICDCODX)

               QUIT

           SET ICDIEN=+($GET(DA))

           IF +ICDIEN'>0

               QUIT

           IF '$DATA(^ICD9(+ICDIEN,66))

               QUIT

 +4        SET ICDHIS=0

FOR

               SET ICDHIS=$ORDER(^ICD9(+ICDIEN,66,ICDHIS))

               IF +ICDHIS=0

                   QUIT

               Begin DoDot:1

 +5                NEW DA,X

                   SET DA=+ICDHIS

                   SET DA(1)=+ICDIEN

                   DO HDC

 +6                SET ICDCOD=ICDCODX

                   IF '$LENGTH($GET(ICDCOD))

                       QUIT

 +7                IF '$LENGTH($GET(ICDEFF))

                       QUIT

                   IF '$LENGTH($GET(ICDSTA))

                       QUIT

                   DO KHIS

               End DoDot:1

 +8        QUIT

 +9       ;

 +10      ; File 80.066, field .01

SAHD      ; Set new value when Effective Date is Edited

 +1       ; ^DD(80.066,.01,1,D0,1) = D SAHD^ICD9IDX

 +2        NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD

 +3        DO HDC

           IF '$LENGTH($GET(ICDCOD))

               QUIT

           IF '$LENGTH($GET(ICDSTA))

               QUIT

           SET ICDEFF=+($GET(X))

           IF +ICDEFF=0

               QUIT

           DO SHIS

 +4        QUIT

KAHD      ; Kill old value when Effective Date is Edited

 +1       ; ^DD(80.066,.01,1,D0,2) = D KAHD^ICD9IDX

 +2        NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD

 +3        DO HDC

           IF '$LENGTH($GET(ICDCOD))

               QUIT

           IF '$LENGTH($GET(ICDSTA))

               QUIT

 +4        SET ICDEFF=+($GET(X))

           IF +ICDEFF=0

               QUIT

           DO KHIS

 +5        QUIT

 +6       ;

 +7       ; File 80.066, field .02

SAHS      ; Set new value when Status is Edited

 +1       ; ^DD(80.066,.02,1,D0,1) = D SAHS^ICD9IDX

 +2        NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD

 +3        DO HDC

           IF '$LENGTH($GET(ICDCOD))

               QUIT

           IF +ICDEFF=0

               QUIT

 +4        SET ICDSTA=$GET(X)

           IF '$LENGTH(ICDSTA)

               QUIT

           DO SHIS

 +5        QUIT

KAHS      ; Kill old value when Status is Edited

 +1       ; ^DD(80.066,.02,1,D0,2) = D KAHS^ICD9IDX

 +2        NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD

 +3        DO HDC

           IF '$LENGTH($GET(ICDCOD))

               QUIT

           IF +ICDEFF=0

               QUIT

 +4        SET ICDSTA=$GET(X)

           IF '$LENGTH(ICDSTA)

               QUIT

           DO KHIS

 +5        QUIT

 +6       ;

HDC       ;  Set Common Variables (Code, Status and Effective Date)

 +1        SET (ICDCOD,ICDSTA,ICDEFF)=""

 +2        IF +($GET(DA(1)))'>0

               QUIT

           IF +($GET(DA))'>0

               QUIT

           IF '$DATA(^ICD9(+($GET(DA(1))),66,+($GET(DA)),0))

               QUIT

 +3        SET ICDCOD=$PIECE($GET(^ICD9(+($GET(DA(1))),0)),"^",1)

           SET ICDNOD=$GET(^ICD9(+($GET(DA(1))),66,+($GET(DA)),0))

 +4        SET ICDSTA=$PIECE(ICDNOD,"^",2)

           SET ICDEFF=$PIECE(ICDNOD,"^",1)

 +5        QUIT

 +6       ;

SHIS      ; Set Index ^ICD9("ACT",<code>,<status>,<date>,<ien>,<history>)

 +1        IF +($GET(DA(1)))'>0

               QUIT

           IF +($GET(DA))'>0

               QUIT

           IF '$DATA(^ICD9(+($GET(DA(1))),66,+($GET(DA)),0))

               QUIT

 +2        SET ^ICD9("ACT",(ICDCOD_" "),ICDSTA,ICDEFF,DA(1),DA)=""

 +3        NEW PIECE,INACT

           SET PIECE=$SELECT('ICDSTA:11,1:16)

           SET INACT=$SELECT('ICDSTA:1,1:"")

 +4        SET $PIECE(^ICD9(DA(1),0),"^",9)=INACT

           SET $PIECE(^ICD9(DA(1),0),"^",PIECE)=ICDEFF

 +5       ;IHS/MSC/PLS - 03/28/2011 - NEW LINE

 +6        IF INACT=""

               SET $PIECE(^ICD9(DA(1),0),"^",11)=""

 +7        QUIT

KHIS      ; Kill Index ^ICD9("ACT",<code>,<status>,<date>,<ien>,<history>)

 +1        IF +($GET(DA(1)))'>0

               QUIT

           IF +($GET(DA))'>0

               QUIT

           IF '$DATA(^ICD9(+($GET(DA(1))),66,+($GET(DA)),0))

               QUIT

 +2        NEW PIECE,INACT,IEN,OPP,OPPSTA,OPPEFF,BOOL

 +3        SET PIECE=$SELECT('ICDSTA:11,1:16)

           SET INACT=$SELECT('ICDSTA:"",1:1)

           SET OPPEFF=ICDEFF

           SET BOOL=0

 +4        FOR

               SET OPPEFF=$ORDER(^ICD9(DA(1),66,"B",OPPEFF),-1)

               IF 'OPPEFF!BOOL

                   QUIT

               Begin DoDot:1

 +5                SET IEN=$ORDER(^ICD9(DA(1),66,"B",OPPEFF,""))

 +6                IF 'IEN

                       SET OPPEFF=""

                       QUIT

 +7                SET OPP=$GET(^ICD9(DA(1),66,IEN,0))

                   SET OPPEFF=$PIECE($GET(OPP),"^",1)

 +8                SET OPPSTA=$PIECE($GET(OPP),"^",2)

                   SET BOOL=OPPSTA'=ICDSTA

               End DoDot:1

 +9        IF BOOL

               Begin DoDot:1

 +10               SET $PIECE(^ICD9(DA(1),0),"^",9)=INACT

                   SET $PIECE(^ICD9(DA(1),0),"^",PIECE)=$GET(OPPEFF)

               End DoDot:1

 +11      IF '$TEST

               SET $PIECE(^ICD9(DA(1),0),"^",9)=1

               SET $PIECE(^ICD9(DA(1),0),"^",11)=""

               SET $PIECE(^ICD9(DA(1),0),"^",16)=""

 +12       KILL ^ICD9("ACT",(ICDCOD_" "),ICDSTA,ICDEFF,DA(1),DA)

 +13       QUIT

ICD9IDX.m