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 ---[H[J[2J[HLEXNDX8 9704 printed Dec 13, 2024@02:08:19 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)
if $LENGTH(LEXSAB)'=3
QUIT
+7 SET ^LEX(757.02,"AUPD",LEXSAB,LEXDT,LEXIEN)=""
+8 QUIT
KAUPD ; Kill 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)
if $LENGTH(LEXSAB)'=3
QUIT
+7 KILL ^LEX(757.02,"AUPD",LEXSAB,LEXDT,LEXIEN)
+8 QUIT
DDTBR(SYS,STA) ; Default Date Business Rules
+1 ; Input:
+2 ; SYS - System
+3 ; STA - Status
+4 ; Output:
+5 ; If Status = 1 (Active)
+6 ; If SYS = ICD/ICP use October 1, 1978 2781001
+7 ; If SYS = CPT/CPC use January 1, 1989 2890101
+8 ; If SYS is not listed above, use 2960923
+9 ; If Status = 0 (Inactive)
+10 ; If SYS = ICD/ICP use October 2, 1978 2791001
+11 ; If SYS = CPT/CPC use January 2, 1989 2900101
+12 ; If SYS is not listed above, use 2960924
+13 NEW LEXSTA,LEXSYS,LEXDT
+14 SET LEXSTA=+($GET(STA))
SET LEXSYS=$GET(SYS)
SET LEXDT=0
+15 if $LENGTH(LEXSYS)=3&("^ICD^ICP^CPT^CPC^"'[LEXSYS)
SET LEXSTA=1
+16 ; No System, use Lexicon Release Date
+17 IF $LENGTH(LEXSYS)'=3
Begin DoDot:1
+18 if +LEXSTA>0
SET LEXDT=2960923
if +LEXSTA'>0
SET LEXDT=2970923
End DoDot:1
QUIT LEXDT
+19 ; System is ICD, use 2781001/2791001
+20 IF LEXSYS="ICD"!(LEXSYS="ICP")
Begin DoDot:1
+21 if LEXSTA>0
SET LEXDT=2781001
if LEXSTA'>0
SET LEXDT=2791001
End DoDot:1
QUIT LEXDT
+22 ; System is CPT, use 2890101/2900101
+23 IF LEXSYS="CPT"!(LEXSYS="CPC")
Begin DoDot:1
+24 if LEXSTA>0
SET LEXDT=2890101
if LEXSTA'>0
SET LEXDT=2900101
End DoDot:1
QUIT LEXDT
+25 ; System is neither ICD or CPT, use 2960923/2970923
+26 IF "^ICD^ICP^CPT^CPC^"'[LEXSYS
Begin DoDot:1
+27 if LEXSTA>0
SET LEXDT=2960923
if LEXSTA'>0
SET LEXDT=2970923
End DoDot:1
QUIT LEXDT
+28 ; None of the Above
+29 if +LEXSTA>0
SET LEXDT=2960923
if +LEXSTA'>0
SET LEXDT=2970923
+30 QUIT LEXDT
