LEXNDX8.m

LEXNDX8 ;ISL/KER - Set/kill indexes 757.02 ;05/23/2017

 ;;2.0;LEXICON UTILITY;**25,73,80,103**;Sep 23, 1996;Build 2

 ;               

 ; Global Variables

 ;    None

 ;               

 ; External References

 ;    None

 ;               

 ; Set and Kill Activation History

 ;   File 757.02, field 1

SAHC ;     Set new value when Code is Edited

 ;          ^DD(757.02,1,1,D0,1) = D SAHC^LEXNDX8

 N LEXCOD,LEXCODX,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 S LEXCODX=$G(X) Q:'$L(LEXCODX)  S LEXIEN=+($G(DA)) Q:+LEXIEN'>0

 S LEXSYS=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",3)) Q:LEXSYS'>0

 S LEXPRF=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",5))

 S LEXSYS=$E($G(^LEX(757.03,+LEXSYS,0)),1,3) Q:$L(LEXSYS)'=3

 I $D(^LEX(757.02,+LEXIEN,4,"B")) S LEXHIS=0 D  Q

 . F  S LEXHIS=$O(^LEX(757.02,+LEXIEN,4,LEXHIS)) Q:+LEXHIS=0  D

 . . N DA,X S DA=+LEXHIS,DA(1)=+LEXIEN D HDC

 . . S LEXCOD=LEXCODX Q:'$L($G(LEXCOD))  Q:'$L($G(LEXEFF))

 . . Q:'$L($G(LEXSTA))  D SHIS

 Q

KAHC ;   Kill old value when Code is Edited

 ;   ^DD(757.02,1,1,D0,2) = D KAHC^LEXNDX8

 N LEXCOD,LEXCODX,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 S LEXCODX=$G(X) Q:'$L(LEXCODX)  S LEXIEN=+($G(DA)) Q:+LEXIEN'>0

 S LEXSYS=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",3)) Q:LEXSYS'>0

 S LEXSYS=$E($G(^LEX(757.03,+LEXSYS,0)),1,3) Q:$L(LEXSYS)'=3

 S LEXPRF=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",5))

 I $D(^LEX(757.02,+LEXIEN,4,"B")) S LEXHIS=0 D  Q

 . F  S LEXHIS=$O(^LEX(757.02,+LEXIEN,4,LEXHIS)) Q:+LEXHIS=0  D

 . . N DA,X S DA=+LEXHIS,DA(1)=+LEXIEN D HDC

 . . S LEXCOD=LEXCODX Q:'$L($G(LEXCOD))  Q:'$L($G(LEXEFF))

 . . Q:'$L($G(LEXSTA))  D KHIS

 Q

 ;                    

 ;   File 757.28, field .01

SAHD ;   Set new value when Effective Date is Edited

 ;   ^DD(757.28,.01,1,D0,1) = D SAHD^LEXNDX8

 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 D HDC Q:'$L($G(LEXCOD))

 Q:'$L($G(LEXSTA))  S LEXEFF=+($G(X)) Q:+LEXEFF=0  D SHIS

 Q

KAHD ;   Kill old value when Effective Date is Edited

 ;   ^DD(757.28,.01,1,D0,2) = D KAHD^LEXIDX8

 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 D HDC Q:'$L($G(LEXCOD))

 Q:'$L($G(LEXSTA))  S LEXEFF=+($G(X)) Q:+LEXEFF=0  D KHIS

 Q

 ;                    

 ;   File 757.28 field 1

SAHS ;   Set new value when Status is Edited

 ;   ^DD(757.28,1,1,D0,1) = D SAHS^LEXNDX8

 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 D HDC Q:'$L($G(LEXCOD))  Q:+LEXEFF=0

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

 Q

KAHS ;   Kill old value when Status is Edited

 ;   ^DD(757.28,1,1,D0,2) = D KAHS^LEXIDX8

 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 D HDC Q:'$L($G(LEXCOD))  Q:+LEXEFF=0

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

 Q

 ;                    

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

 S (LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXCOD,LEXSTA,LEXEFF)=""  Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0

 Q:'$D(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))

 S LEXCOD=$P($G(^LEX(757.02,+($G(DA(1))),0)),"^",2)

 S LEXPRF=+($P($G(^LEX(757.02,+($G(DA(1))),0)),"^",5))

 S LEXNOD=$G(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))

 S LEXSTA=$P(LEXNOD,"^",2),LEXEFF=$P(LEXNOD,"^",1)

 S LEXSTA=$S(LEXSTA="A":1,LEXSTA="I":0,1:LEXSTA)

 S LEXDSYS=+($P($G(^LEX(757.02,+($G(DA(1))),0)),"^",3))

 S LEXDSYS=$E($G(^LEX(757.03,+LEXDSYS,0)),1,3)

 S LEXDSTA=$$DF(+($G(DA(1))),$G(LEXCOD))

 S LEXDSTA=$S(+LEXDSTA'>0:1,1:0)

 S LEXDDT=$$DDTBR(LEXDSYS,LEXDSTA)

 Q

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

 ;    0 node

 S LEXCOD=$G(LEXCODX),LEXSYS=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",3))

 S (LEXSYS,LEXDSYS)=$E($G(^LEX(757.03,+LEXSYS,0)),1,3)

 S LEXPRF=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",5))

 S LEXSTA=$$DF(+($G(DA(1))),$G(LEXCOD))

 S (LEXSTA,LEXDSTA)=$S(+LEXSTA'>0:1,1:0)

 S LEXEFF=$$DDTBR(LEXSYS,LEXSTA)

 S LEXDDT=$$DDTBR(LEXDSYS,LEXDSTA)

 Q

SHIS ;  Set Index 

 ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 Q:'$L($G(LEXCOD))  Q:'$L($G(LEXSTA))  Q:'$L($G(LEXEFF)) 

 Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0

 Q:'$D(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))

 K:$L($G(LEXDDT)) ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXDDT,DA(1),0)

 S ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,DA(1),DA)=""

 I +($G(LEXPRF))>0 D

 . K:$L($G(LEXDDT)) ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,DA(1),0)

 . S ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,DA(1),DA)=""

 Q

SDHIS ;  Set Default Index 

 ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 Q:'$L($G(LEXCOD))  Q:'$L($G(LEXSTA))  Q:'$L($G(LEXEFF))

 Q:+($G(LEXIEN))'>0  Q:'$D(^LEX(757.02,+($G(LEXIEN)),0))

 S ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,+LEXIEN,0)=""

 I +($G(LEXPRF))>0 D

 . S ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,+LEXIEN,0)=""

 Q

KHIS ;  Kill Index

 ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 Q:'$L($G(LEXCOD))  Q:'$L($G(LEXSTA))  Q:'$L($G(LEXEFF))

 Q:+($G(DA(1)))'>0  Q:+($G(DA))'>0

 Q:'$D(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))

 K ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,DA(1),DA)

 I +($G(LEXPRF))>0 D

 . K:$L($G(LEXDDT)) ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,DA(1),0)

 . K ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,DA(1),DA)

 Q

KDHIS ;  Kill Default Index

 ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 Q:'$L($G(LEXCOD))  Q:'$L($G(LEXSTA))  Q:'$L($G(LEXEFF))

 Q:+($G(LEXIEN))'>0  Q:'$D(^LEX(757.02,+($G(LEXIEN)),0))

 K ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,+LEXIEN,0)

 I +($G(LEXPRF))>0 D

 . K ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,+LEXIEN,0)

 Q

S10 ;  Set ICD-10 Index 

 ;  ^LEX(757.02,"ADX",<dx code>,<date>,<status>,<ien>,<history>)

 ;  ^LEX(757.02,"APR",<pr code>,<date>,<status>,<ien>,<history>)

 N LEXEF,LEXIX,LEXND,LEXSB,LEXSO,LEXSR,LEXST

 S LEXND=$G(^LEX(757.02,+($G(DA(1))),0)) Q:'$L(LEXND)

 S LEXSR=$P(LEXND,"^",3) Q:+LEXSR'>0

 S LEXSB=$E($G(^LEX(757.03,+LEXSR,0)),1,3) Q:"^10D^10P^"'[("^"_LEXSB_"^")

 S LEXIX=$S(LEXSB="10D":"ADX",LEXSB="10P":"APR",1:"") Q:'$L(LEXIX)

 S LEXSO=$P(LEXND,"^",2) Q:'$L(LEXSO)

 S LEXND=$G(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0)) Q:'$L(LEXND)

 S LEXEF=$P(LEXND,"^",1) Q:LEXEF'?7N

 S LEXST=$P(LEXND,"^",2) Q:LEXST'?1N

 S ^LEX(757.02,LEXIX,(LEXSO_" "),LEXEF,LEXST,+($G(DA(1))),+($G(DA)))=""

 Q

K10 ;  Kill ICD-10 Index

 ;  ^LEX(757.02,"ADX",<dx code>,<date>,<status>,<ien>,<history>)

 ;  ^LEX(757.02,"APR",<pr code>,<date>,<status>,<ien>,<history>)

 N LEXEF,LEXIX,LEXND,LEXSB,LEXSO,LEXSR,LEXST

 S LEXND=$G(^LEX(757.02,+($G(DA(1))),0)) Q:'$L(LEXND)

 S LEXSR=$P(LEXND,"^",3) Q:+LEXSR'>0

 S LEXSB=$E($G(^LEX(757.03,+LEXSR,0)),1,3) Q:"^10D^10P^"'[("^"_LEXSB_"^")

 S LEXIX=$S(LEXSB="10D":"ADX",LEXSB="10P":"APR",1:"") Q:'$L(LEXIX)

 S LEXSO=$P(LEXND,"^",2) Q:'$L(LEXSO)

 S LEXND=$G(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0)) Q:'$L(LEXND)

 S LEXEF=$P(LEXND,"^",1) Q:LEXEF'?7N

 S LEXST=$P(LEXND,"^",2) Q:LEXST'?1N

 K ^LEX(757.02,LEXIX,(LEXSO_" "),LEXEF,LEXST,+($G(DA(1))),+($G(DA)))

 Q

DF(X,CODE) ; Default Status

 N LEXI,LEXDF,LEXNF,LEXL,LEXEFF,LEXC,LEXO,LEXND,LEXSRC

 S LEXI=+($G(X)) Q:+LEXI'>0 ""

 S LEXND=$G(^LEX(757.02,+LEXI,0)),LEXSRC=$P(LEXND,"^",3)

 S LEXEFF=$O(^LEX(757.02,+LEXI,4,"B"," "),-1)

 S LEXL=$O(^LEX(757.02,+LEXI,4,"B",+LEXEFF,0))

 S LEXL=$P($G(^LEX(757.02,+LEXI,4,+LEXL,0)),"^",2)

 S LEXC=$G(CODE) S:'$L(LEXC) LEXC=$P($G(^LEX(757.02,LEXI,0)),U,2)

 S LEXDF='+$$STATCHK^LEXSRC2(LEXC,,,LEXSRC)

 S LEXO=$P($G(^LEX(757.02,LEXI,0)),U,2)

 S LEXNF=$S(+LEXL=1:"",1:LEXDF)

 S X=LEXNF

 Q X

SAUPD ; Set Update Date

 N LEXSRC,LEXSAB,LEXDT,LEXIEN,LEXHIS

 S LEXDT=$G(X) Q:'$L(LEXDT)  Q:LEXDT'?7N  Q:LEXDT'>2770101

 S LEXHIS=+($G(DA)) Q:+LEXHIS'>0

 S LEXIEN=+($G(DA(1))) Q:+LEXIEN'>0

 S LEXSRC=$P($G(^LEX(757.02,+LEXIEN,0)),"^",3) Q:LEXSRC'>0

 S LEXSAB=$E($P($G(^LEX(757.03,+LEXSRC,0)),"^",1),1,3) Q:$L(LEXSAB)'=3

 S ^LEX(757.02,"AUPD",LEXSAB,LEXDT,LEXIEN)=""

 Q

KAUPD ; Kill Update Date

 N LEXSRC,LEXSAB,LEXDT,LEXIEN,LEXHIS

 S LEXDT=$G(X) Q:'$L(LEXDT)  Q:LEXDT'?7N  Q:LEXDT'>2770101

 S LEXHIS=+($G(DA)) Q:+LEXHIS'>0

 S LEXIEN=+($G(DA(1))) Q:+LEXIEN'>0

 S LEXSRC=$P($G(^LEX(757.02,+LEXIEN,0)),"^",3) Q:LEXSRC'>0

 S LEXSAB=$E($P($G(^LEX(757.03,+LEXSRC,0)),"^",1),1,3) Q:$L(LEXSAB)'=3

 K ^LEX(757.02,"AUPD",LEXSAB,LEXDT,LEXIEN)

 Q

DDTBR(SYS,STA) ; Default Date Business Rules

 ; Input:

 ;   SYS - System

 ;   STA - Status

 ; Output:

 ;   If Status = 1 (Active)

 ;      If SYS = ICD/ICP  use October 1, 1978      2781001

 ;      If SYS = CPT/CPC  use January 1, 1989      2890101

 ;      If SYS is not listed above, use            2960923

 ;   If Status = 0 (Inactive)

 ;      If SYS = ICD/ICP  use October 2, 1978      2791001

 ;      If SYS = CPT/CPC  use January 2, 1989      2900101

 ;      If SYS is not listed above, use            2960924

 N LEXSTA,LEXSYS,LEXDT

 S LEXSTA=+($G(STA)),LEXSYS=$G(SYS),LEXDT=0

 S:$L(LEXSYS)=3&("^ICD^ICP^CPT^CPC^"'[LEXSYS) LEXSTA=1

 ;   No System, use Lexicon Release Date

 I $L(LEXSYS)'=3 D  Q LEXDT

 . S:+LEXSTA>0 LEXDT=2960923 S:+LEXSTA'>0 LEXDT=2970923

 ;   System is ICD, use 2781001/2791001

 I LEXSYS="ICD"!(LEXSYS="ICP") D  Q LEXDT

 . S:LEXSTA>0 LEXDT=2781001 S:LEXSTA'>0 LEXDT=2791001

 ;   System is CPT, use 2890101/2900101

 I LEXSYS="CPT"!(LEXSYS="CPC") D  Q LEXDT

 . S:LEXSTA>0 LEXDT=2890101 S:LEXSTA'>0 LEXDT=2900101

 ;   System is neither ICD or CPT, use 2960923/2970923

 I "^ICD^ICP^CPT^CPC^"'[LEXSYS D  Q LEXDT

 . S:LEXSTA>0 LEXDT=2960923 S:LEXSTA'>0 LEXDT=2970923

 ;   None of the Above

 S:+LEXSTA>0 LEXDT=2960923 S:+LEXSTA'>0 LEXDT=2970923

 Q LEXDT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEXNDX8   9704     printed  Feb 18, 2025@23:34:23                                                                                                                                                                                                     Page 2

LEXNDX8   ;ISL/KER - Set/kill indexes 757.02 ;05/23/2017

 +1       ;;2.0;LEXICON UTILITY;**25,73,80,103**;Sep 23, 1996;Build 2

 +2       ;               

 +3       ; Global Variables

 +4       ;    None

 +5       ;               

 +6       ; External References

 +7       ;    None

 +8       ;               

 +9       ; Set and Kill Activation History

 +10      ;   File 757.02, field 1

SAHC      ;     Set new value when Code is Edited

 +1       ;          ^DD(757.02,1,1,D0,1) = D SAHC^LEXNDX8

 +2        NEW LEXCOD,LEXCODX,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 +3        SET LEXCODX=$GET(X)

           if '$LENGTH(LEXCODX)

               QUIT 

           SET LEXIEN=+($GET(DA))

           if +LEXIEN'>0

               QUIT 

 +4        SET LEXSYS=+($PIECE($GET(^LEX(757.02,+LEXIEN,0)),"^",3))

           if LEXSYS'>0

               QUIT 

 +5        SET LEXPRF=+($PIECE($GET(^LEX(757.02,+LEXIEN,0)),"^",5))

 +6        SET LEXSYS=$EXTRACT($GET(^LEX(757.03,+LEXSYS,0)),1,3)

           if $LENGTH(LEXSYS)'=3

               QUIT 

 +7        IF $DATA(^LEX(757.02,+LEXIEN,4,"B"))

               SET LEXHIS=0

               Begin DoDot:1

 +8                FOR 

                       SET LEXHIS=$ORDER(^LEX(757.02,+LEXIEN,4,LEXHIS))

                       if +LEXHIS=0

                           QUIT 

                       Begin DoDot:2

 +9                        NEW DA,X

                           SET DA=+LEXHIS

                           SET DA(1)=+LEXIEN

                           DO HDC

 +10                       SET LEXCOD=LEXCODX

                           if '$LENGTH($GET(LEXCOD))

                               QUIT 

                           if '$LENGTH($GET(LEXEFF))

                               QUIT 

 +11                       if '$LENGTH($GET(LEXSTA))

                               QUIT 

                           DO SHIS

                       End DoDot:2

               End DoDot:1

               QUIT 

 +12       QUIT 

KAHC      ;   Kill old value when Code is Edited

 +1       ;   ^DD(757.02,1,1,D0,2) = D KAHC^LEXNDX8

 +2        NEW LEXCOD,LEXCODX,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 +3        SET LEXCODX=$GET(X)

           if '$LENGTH(LEXCODX)

               QUIT 

           SET LEXIEN=+($GET(DA))

           if +LEXIEN'>0

               QUIT 

 +4        SET LEXSYS=+($PIECE($GET(^LEX(757.02,+LEXIEN,0)),"^",3))

           if LEXSYS'>0

               QUIT 

 +5        SET LEXSYS=$EXTRACT($GET(^LEX(757.03,+LEXSYS,0)),1,3)

           if $LENGTH(LEXSYS)'=3

               QUIT 

 +6        SET LEXPRF=+($PIECE($GET(^LEX(757.02,+LEXIEN,0)),"^",5))

 +7        IF $DATA(^LEX(757.02,+LEXIEN,4,"B"))

               SET LEXHIS=0

               Begin DoDot:1

 +8                FOR 

                       SET LEXHIS=$ORDER(^LEX(757.02,+LEXIEN,4,LEXHIS))

                       if +LEXHIS=0

                           QUIT 

                       Begin DoDot:2

 +9                        NEW DA,X

                           SET DA=+LEXHIS

                           SET DA(1)=+LEXIEN

                           DO HDC

 +10                       SET LEXCOD=LEXCODX

                           if '$LENGTH($GET(LEXCOD))

                               QUIT 

                           if '$LENGTH($GET(LEXEFF))

                               QUIT 

 +11                       if '$LENGTH($GET(LEXSTA))

                               QUIT 

                           DO KHIS

                       End DoDot:2

               End DoDot:1

               QUIT 

 +12       QUIT 

 +13      ;                    

 +14      ;   File 757.28, field .01

SAHD      ;   Set new value when Effective Date is Edited

 +1       ;   ^DD(757.28,.01,1,D0,1) = D SAHD^LEXNDX8

 +2        NEW LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 +3        DO HDC

           if '$LENGTH($GET(LEXCOD))

               QUIT 

 +4        if '$LENGTH($GET(LEXSTA))

               QUIT 

           SET LEXEFF=+($GET(X))

           if +LEXEFF=0

               QUIT 

           DO SHIS

 +5        QUIT 

KAHD      ;   Kill old value when Effective Date is Edited

 +1       ;   ^DD(757.28,.01,1,D0,2) = D KAHD^LEXIDX8

 +2        NEW LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 +3        DO HDC

           if '$LENGTH($GET(LEXCOD))

               QUIT 

 +4        if '$LENGTH($GET(LEXSTA))

               QUIT 

           SET LEXEFF=+($GET(X))

           if +LEXEFF=0

               QUIT 

           DO KHIS

 +5        QUIT 

 +6       ;                    

 +7       ;   File 757.28 field 1

SAHS      ;   Set new value when Status is Edited

 +1       ;   ^DD(757.28,1,1,D0,1) = D SAHS^LEXNDX8

 +2        NEW LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 +3        DO HDC

           if '$LENGTH($GET(LEXCOD))

               QUIT 

           if +LEXEFF=0

               QUIT 

 +4        SET LEXSTA=$GET(X)

           if '$LENGTH(LEXSTA)

               QUIT 

           DO SHIS

 +5        QUIT 

KAHS      ;   Kill old value when Status is Edited

 +1       ;   ^DD(757.28,1,1,D0,2) = D KAHS^LEXIDX8

 +2        NEW LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF

 +3        DO HDC

           if '$LENGTH($GET(LEXCOD))

               QUIT 

           if +LEXEFF=0

               QUIT 

 +4        SET LEXSTA=$GET(X)

           if '$LENGTH(LEXSTA)

               QUIT 

           DO KHIS

 +5        QUIT 

 +6       ;                    

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

 +1        SET (LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXCOD,LEXSTA,LEXEFF)=""

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

               QUIT 

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

               QUIT 

 +2        if '$DATA(^LEX(757.02,+($GET(DA(1))),4,+($GET(DA)),0))

               QUIT 

 +3        SET LEXCOD=$PIECE($GET(^LEX(757.02,+($GET(DA(1))),0)),"^",2)

 +4        SET LEXPRF=+($PIECE($GET(^LEX(757.02,+($GET(DA(1))),0)),"^",5))

 +5        SET LEXNOD=$GET(^LEX(757.02,+($GET(DA(1))),4,+($GET(DA)),0))

 +6        SET LEXSTA=$PIECE(LEXNOD,"^",2)

           SET LEXEFF=$PIECE(LEXNOD,"^",1)

 +7        SET LEXSTA=$SELECT(LEXSTA="A":1,LEXSTA="I":0,1:LEXSTA)

 +8        SET LEXDSYS=+($PIECE($GET(^LEX(757.02,+($GET(DA(1))),0)),"^",3))

 +9        SET LEXDSYS=$EXTRACT($GET(^LEX(757.03,+LEXDSYS,0)),1,3)

 +10       SET LEXDSTA=$$DF(+($GET(DA(1))),$GET(LEXCOD))

 +11       SET LEXDSTA=$SELECT(+LEXDSTA'>0:1,1:0)

 +12       SET LEXDDT=$$DDTBR(LEXDSYS,LEXDSTA)

 +13       QUIT 

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

 +1       ;    0 node

 +2        SET LEXCOD=$GET(LEXCODX)

           SET LEXSYS=+($PIECE($GET(^LEX(757.02,+LEXIEN,0)),"^",3))

 +3        SET (LEXSYS,LEXDSYS)=$EXTRACT($GET(^LEX(757.03,+LEXSYS,0)),1,3)

 +4        SET LEXPRF=+($PIECE($GET(^LEX(757.02,+LEXIEN,0)),"^",5))

 +5        SET LEXSTA=$$DF(+($GET(DA(1))),$GET(LEXCOD))

 +6        SET (LEXSTA,LEXDSTA)=$SELECT(+LEXSTA'>0:1,1:0)

 +7        SET LEXEFF=$$DDTBR(LEXSYS,LEXSTA)

 +8        SET LEXDDT=$$DDTBR(LEXDSYS,LEXDSTA)

 +9        QUIT 

SHIS      ;  Set Index 

 +1       ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 +2        if '$LENGTH($GET(LEXCOD))

               QUIT 

           if '$LENGTH($GET(LEXSTA))

               QUIT 

           if '$LENGTH($GET(LEXEFF))

               QUIT 

 +3        if +($GET(DA(1)))'>0

               QUIT 

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

               QUIT 

 +4        if '$DATA(^LEX(757.02,+($GET(DA(1))),4,+($GET(DA)),0))

               QUIT 

 +5        if $LENGTH($GET(LEXDDT))

               KILL ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXDDT,DA(1),0)

 +6        SET ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,DA(1),DA)=""

 +7        IF +($GET(LEXPRF))>0

               Begin DoDot:1

 +8                if $LENGTH($GET(LEXDDT))

                       KILL ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,DA(1),0)

 +9                SET ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,DA(1),DA)=""

               End DoDot:1

 +10       QUIT 

SDHIS     ;  Set Default Index 

 +1       ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 +2        if '$LENGTH($GET(LEXCOD))

               QUIT 

           if '$LENGTH($GET(LEXSTA))

               QUIT 

           if '$LENGTH($GET(LEXEFF))

               QUIT 

 +3        if +($GET(LEXIEN))'>0

               QUIT 

           if '$DATA(^LEX(757.02,+($GET(LEXIEN)),0))

               QUIT 

 +4        SET ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,+LEXIEN,0)=""

 +5        IF +($GET(LEXPRF))>0

               Begin DoDot:1

 +6                SET ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,+LEXIEN,0)=""

               End DoDot:1

 +7        QUIT 

KHIS      ;  Kill Index

 +1       ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 +2        if '$LENGTH($GET(LEXCOD))

               QUIT 

           if '$LENGTH($GET(LEXSTA))

               QUIT 

           if '$LENGTH($GET(LEXEFF))

               QUIT 

 +3        if +($GET(DA(1)))'>0

               QUIT 

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

               QUIT 

 +4        if '$DATA(^LEX(757.02,+($GET(DA(1))),4,+($GET(DA)),0))

               QUIT 

 +5        KILL ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,DA(1),DA)

 +6        IF +($GET(LEXPRF))>0

               Begin DoDot:1

 +7                if $LENGTH($GET(LEXDDT))

                       KILL ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,DA(1),0)

 +8                KILL ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,DA(1),DA)

               End DoDot:1

 +9        QUIT 

KDHIS     ;  Kill Default Index

 +1       ;  ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)

 +2        if '$LENGTH($GET(LEXCOD))

               QUIT 

           if '$LENGTH($GET(LEXSTA))

               QUIT 

           if '$LENGTH($GET(LEXEFF))

               QUIT 

 +3        if +($GET(LEXIEN))'>0

               QUIT 

           if '$DATA(^LEX(757.02,+($GET(LEXIEN)),0))

               QUIT 

 +4        KILL ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,+LEXIEN,0)

 +5        IF +($GET(LEXPRF))>0

               Begin DoDot:1

 +6                KILL ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,+LEXIEN,0)

               End DoDot:1

 +7        QUIT 

S10       ;  Set ICD-10 Index 

 +1       ;  ^LEX(757.02,"ADX",<dx code>,<date>,<status>,<ien>,<history>)

 +2       ;  ^LEX(757.02,"APR",<pr code>,<date>,<status>,<ien>,<history>)

 +3        NEW LEXEF,LEXIX,LEXND,LEXSB,LEXSO,LEXSR,LEXST

 +4        SET LEXND=$GET(^LEX(757.02,+($GET(DA(1))),0))

           if '$LENGTH(LEXND)

               QUIT 

 +5        SET LEXSR=$PIECE(LEXND,"^",3)

           if +LEXSR'>0

               QUIT 

 +6        SET LEXSB=$EXTRACT($GET(^LEX(757.03,+LEXSR,0)),1,3)

           if "^10D^10P^"'[("^"_LEXSB_"^")

               QUIT 

 +7        SET LEXIX=$SELECT(LEXSB="10D":"ADX",LEXSB="10P":"APR",1:"")

           if '$LENGTH(LEXIX)

               QUIT 

 +8        SET LEXSO=$PIECE(LEXND,"^",2)

           if '$LENGTH(LEXSO)

               QUIT 

 +9        SET LEXND=$GET(^LEX(757.02,+($GET(DA(1))),4,+($GET(DA)),0))

           if '$LENGTH(LEXND)

               QUIT 

 +10       SET LEXEF=$PIECE(LEXND,"^",1)

           if LEXEF'?7N

               QUIT 

 +11       SET LEXST=$PIECE(LEXND,"^",2)

           if LEXST'?1N

               QUIT 

 +12       SET ^LEX(757.02,LEXIX,(LEXSO_" "),LEXEF,LEXST,+($GET(DA(1))),+($GET(DA)))=""

 +13       QUIT 

K10       ;  Kill ICD-10 Index

 +1       ;  ^LEX(757.02,"ADX",<dx code>,<date>,<status>,<ien>,<history>)

 +2       ;  ^LEX(757.02,"APR",<pr code>,<date>,<status>,<ien>,<history>)

 +3        NEW LEXEF,LEXIX,LEXND,LEXSB,LEXSO,LEXSR,LEXST

 +4        SET LEXND=$GET(^LEX(757.02,+($GET(DA(1))),0))

           if '$LENGTH(LEXND)

               QUIT 

 +5        SET LEXSR=$PIECE(LEXND,"^",3)

           if +LEXSR'>0

               QUIT 

 +6        SET LEXSB=$EXTRACT($GET(^LEX(757.03,+LEXSR,0)),1,3)

           if "^10D^10P^"'[("^"_LEXSB_"^")

               QUIT 

 +7        SET LEXIX=$SELECT(LEXSB="10D":"ADX",LEXSB="10P":"APR",1:"")

           if '$LENGTH(LEXIX)

               QUIT 

 +8        SET LEXSO=$PIECE(LEXND,"^",2)

           if '$LENGTH(LEXSO)

               QUIT 

 +9        SET LEXND=$GET(^LEX(757.02,+($GET(DA(1))),4,+($GET(DA)),0))

           if '$LENGTH(LEXND)

               QUIT 

 +10       SET LEXEF=$PIECE(LEXND,"^",1)

           if LEXEF'?7N

               QUIT 

 +11       SET LEXST=$PIECE(LEXND,"^",2)

           if LEXST'?1N

               QUIT 

 +12       KILL ^LEX(757.02,LEXIX,(LEXSO_" "),LEXEF,LEXST,+($GET(DA(1))),+($GET(DA)))

 +13       QUIT 

DF(X,CODE) ; Default Status

 +1        NEW LEXI,LEXDF,LEXNF,LEXL,LEXEFF,LEXC,LEXO,LEXND,LEXSRC

 +2        SET LEXI=+($GET(X))

           if +LEXI'>0

               QUIT ""

 +3        SET LEXND=$GET(^LEX(757.02,+LEXI,0))

           SET LEXSRC=$PIECE(LEXND,"^",3)

 +4        SET LEXEFF=$ORDER(^LEX(757.02,+LEXI,4,"B"," "),-1)

 +5        SET LEXL=$ORDER(^LEX(757.02,+LEXI,4,"B",+LEXEFF,0))

 +6        SET LEXL=$PIECE($GET(^LEX(757.02,+LEXI,4,+LEXL,0)),"^",2)

 +7        SET LEXC=$GET(CODE)

           if '$LENGTH(LEXC)

               SET LEXC=$PIECE($GET(^LEX(757.02,LEXI,0)),U,2)

 +8        SET LEXDF='+$$STATCHK^LEXSRC2(LEXC,,,LEXSRC)

 +9        SET LEXO=$PIECE($GET(^LEX(757.02,LEXI,0)),U,2)

 +10       SET LEXNF=$SELECT(+LEXL=1:"",1:LEXDF)

 +11       SET X=LEXNF

 +12       QUIT X

SAUPD     ; Set Update Date

 +1        NEW LEXSRC,LEXSAB,LEXDT,LEXIEN,LEXHIS

 +2        SET LEXDT=$GET(X)

           if '$LENGTH(LEXDT)

               QUIT 

           if LEXDT'?7N

               QUIT 

           if LEXDT'>2770101

               QUIT 

 +3        SET LEXHIS=+($GET(DA))

           if +LEXHIS'>0

               QUIT 

 +4        SET LEXIEN=+($GET(DA(1)))

           if +LEXIEN'>0

               QUIT 

 +5        SET LEXSRC=$PIECE($GET(^LEX(757.02,+LEXIEN,0)),"^",3)

           if LEXSRC'>0

               QUIT 

 +6        SET LEXSAB=$EXTRACT($PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",1),1,3)