LEXNDX9 ;ISL/KER - Set/kill indexes 757.33 ;01/03/2011
;;2.0;LEXICON UTILITY;**73**;Sep 23, 1996;Build 10
;
; Set and Kill Activation History
; File 757.33, field 1
SAHC ; Set new value when Code is Edited
; ^DD(757.33,1,1,D0,1) = D SAHC^LEXNDX9
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF
N LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP
S LEXIEN=+$G(DA) Q:+LEXIEN'>0
I $D(^LEX(757.33,+LEXIEN,2,"B")) S LEXHIS=0 D Q
.F S LEXHIS=$O(^LEX(757.33,+LEXIEN,2,LEXHIS)) Q:+LEXHIS=0 D
..N DA,X
..S DA=+LEXHIS,DA(1)=+LEXIEN
..D HDC
..Q:'$L($G(LEXEFF))
..Q:'$L($G(LEXSTA))
..D SHIS
Q
KAHC ; Kill old value when Code is Edited
; ^DD(757.33,1,1,D0,2) = D KAHC^LEXNDX9
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF
N LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP
S LEXIEN=+$G(DA) Q:+LEXIEN'>0
I $D(^LEX(757.33,+LEXIEN,2,"B")) S LEXHIS=0 D Q
.F S LEXHIS=$O(^LEX(757.33,+LEXIEN,2,LEXHIS)) Q:+LEXHIS=0 D
..N DA,X S DA=+LEXHIS,DA(1)=+LEXIEN D HDC
..Q:'$L($G(LEXEFF))
..Q:'$L($G(LEXSTA))
..D KHIS
Q
;
; File 757.333, field .01
SAHD ; Set new value when Effective Date is Edited
; ^DD(757.333,.01,1,D0,1) = D SAHD^LEXNDX9
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
N LEXNOD,LEXSTA
D HDC
Q:'$L($G(LEXSTA))
Q:+LEXEFF=0
D SHIS
Q
KAHD ; Kill old value when Effective Date is Edited
; ^DD(757.333,.01,1,D0,2) = D KAHD^LEXIDX8
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
N LEXNOD,LEXSTA
D HDC
Q:'$L($G(LEXSTA))
S LEXEFF=+$G(X) Q:+LEXEFF=0
D KHIS
Q
;
; File 757.333 field 1
SAHS ; Set new value when Status is Edited
; ^DD(757.333,1,1,D0,1) = D SAHS^LEXNDX9
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
N LEXNOD,LEXSTA,LEXSYS
D HDC
Q:+LEXEFF=0
S LEXSTA=$G(X)
Q:'$L(LEXSTA)
D SHIS
Q
KAHS ; Kill old value when Status is Edited
; ^DD(757.333,1,1,D0,2) = D KAHS^LEXIDX9
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
N LEXNOD,LEXSTA
D HDC
Q:+LEXEFF=0
S LEXSTA=$G(X)
Q:'$L(LEXSTA)
D KHIS
Q
;
HDC ; Set Common Variables (Status and Effective Date)
S (LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXSTA,LEXMAP)=""
Q:+$G(DA(1))'>0
Q:+$G(DA)'>0
Q:'$D(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0))
S LEXMAP=$P(^LEX(757.33,DA(1),0),U)
S LEXNOD=$G(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0))
S LEXSTA=$P(LEXNOD,U,2),LEXEFF=$P(LEXNOD,U)
S LEXSTA=$S(LEXSTA="A":1,LEXSTA="I":0,1:LEXSTA)
S LEXDDT=$$DDTBR(LEXDSYS,LEXSTA)
Q
SHIS ; Set Index
; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
Q:+$G(DA(1))'>0 Q:+$G(DA)'>0
Q:'$D(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0))
K:$L($G(LEXDDT)) ^LEX(757.33,"G",LEXMAP,LEXDDT,LEXSTA,DA(1))
S ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1))=""
Q
SDHIS ; Set Default Index
; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
Q:+$G(LEXIEN)'>0 Q:'$D(^LEX(757.33,+$G(LEXIEN),0))
S ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN)=""
Q
KHIS ; Kill Index
; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
Q:+$G(DA(1))'>0 Q:+$G(DA)'>0
Q:'$D(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0))
K ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1),DA)
Q
KDHIS ; Kill Default Index
; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
Q:+$G(LEXIEN)'>0 Q:'$D(^LEX(757.33,+$G(LEXIEN),0))
K ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN,0)
Q
DF(X,CODE) ; Default Status
N LEXI,LEXNF,LEXL,LEXEFF,LEXC
S LEXI=+$G(X) Q:+LEXI'>0 ""
S LEXEFF=$O(^LEX(757.33,+LEXI,2,"B"," "),-1)
S LEXL=$O(^LEX(757.33,+LEXI,2,"B",+LEXEFF,0))
S LEXL=$P($G(^LEX(757.33,+LEXI,2,+LEXL,0)),U,2)
S X=LEXL
Q X
DDTBR(SYS,STA) ; Default Date Business Rules
; Input:
; SYS - System
; STA - Status
; Output:
; If Status = 1 (Give)
; 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 (InGive)
; 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
LEXNDX9 ;ISL/KER - Set/kill indexes 757.33 ;01/03/2011
+1 ;;2.0;LEXICON UTILITY;**73**;Sep 23, 1996;Build 10
+2 ;
+3 ; Set and Kill Activation History
+4 ; File 757.33, field 1
SAHC ; Set new value when Code is Edited
+1 ; ^DD(757.33,1,1,D0,1) = D SAHC^LEXNDX9
+2 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF
+3 NEW LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP
+4 SET LEXIEN=+$GET(DA)
IF +LEXIEN'>0
QUIT
+5 IF $DATA(^LEX(757.33,+LEXIEN,2,"B"))
SET LEXHIS=0
Begin DoDot:1
+6 FOR
SET LEXHIS=$ORDER(^LEX(757.33,+LEXIEN,2,LEXHIS))
IF +LEXHIS=0
QUIT
Begin DoDot:2
+7 NEW DA,X
+8 SET DA=+LEXHIS
SET DA(1)=+LEXIEN
+9 DO HDC
+10 IF '$LENGTH($GET(LEXEFF))
QUIT
+11 IF '$LENGTH($GET(LEXSTA))
QUIT
+12 DO SHIS
End DoDot:2
End DoDot:1
QUIT
+13 QUIT
KAHC ; Kill old value when Code is Edited
+1 ; ^DD(757.33,1,1,D0,2) = D KAHC^LEXNDX9
+2 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF
+3 NEW LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP
+4 SET LEXIEN=+$GET(DA)
IF +LEXIEN'>0
QUIT
+5 IF $DATA(^LEX(757.33,+LEXIEN,2,"B"))
SET LEXHIS=0
Begin DoDot:1
+6 FOR
SET LEXHIS=$ORDER(^LEX(757.33,+LEXIEN,2,LEXHIS))
IF +LEXHIS=0
QUIT
Begin DoDot:2
+7 NEW DA,X
SET DA=+LEXHIS
SET DA(1)=+LEXIEN
DO HDC
+8 IF '$LENGTH($GET(LEXEFF))
QUIT
+9 IF '$LENGTH($GET(LEXSTA))
QUIT
+10 DO KHIS
End DoDot:2
End DoDot:1
QUIT
+11 QUIT
+12 ;
+13 ; File 757.333, field .01
SAHD ; Set new value when Effective Date is Edited
+1 ; ^DD(757.333,.01,1,D0,1) = D SAHD^LEXNDX9
+2 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
+3 NEW LEXNOD,LEXSTA
+4 DO HDC
+5 IF '$LENGTH($GET(LEXSTA))
QUIT
+6 IF +LEXEFF=0
QUIT
+7 DO SHIS
+8 QUIT
KAHD ; Kill old value when Effective Date is Edited
+1 ; ^DD(757.333,.01,1,D0,2) = D KAHD^LEXIDX8
+2 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
+3 NEW LEXNOD,LEXSTA
+4 DO HDC
+5 IF '$LENGTH($GET(LEXSTA))
QUIT
+6 SET LEXEFF=+$GET(X)
IF +LEXEFF=0
QUIT
+7 DO KHIS
+8 QUIT
+9 ;
+10 ; File 757.333 field 1
SAHS ; Set new value when Status is Edited
+1 ; ^DD(757.333,1,1,D0,1) = D SAHS^LEXNDX9
+2 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
+3 NEW LEXNOD,LEXSTA,LEXSYS
+4 DO HDC
+5 IF +LEXEFF=0
QUIT
+6 SET LEXSTA=$GET(X)
+7 IF '$LENGTH(LEXSTA)
QUIT
+8 DO SHIS
+9 QUIT
KAHS ; Kill old value when Status is Edited
+1 ; ^DD(757.333,1,1,D0,2) = D KAHS^LEXIDX9
+2 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP
+3 NEW LEXNOD,LEXSTA
+4 DO HDC
+5 IF +LEXEFF=0
QUIT
+6 SET LEXSTA=$GET(X)
+7 IF '$LENGTH(LEXSTA)
QUIT
+8 DO KHIS
+9 QUIT
+10 ;
HDC ; Set Common Variables (Status and Effective Date)
+1 SET (LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXSTA,LEXMAP)=""
+2 IF +$GET(DA(1))'>0
QUIT
+3 IF +$GET(DA)'>0
QUIT
+4 IF '$DATA(^LEX(757.33,+$GET(DA(1)),2,+$GET(DA),0))
QUIT
+5 SET LEXMAP=$PIECE(^LEX(757.33,DA(1),0),U)
+6 SET LEXNOD=$GET(^LEX(757.33,+$GET(DA(1)),2,+$GET(DA),0))
+7 SET LEXSTA=$PIECE(LEXNOD,U,2)
SET LEXEFF=$PIECE(LEXNOD,U)
+8 SET LEXSTA=$SELECT(LEXSTA="A":1,LEXSTA="I":0,1:LEXSTA)
+9 SET LEXDDT=$$DDTBR(LEXDSYS,LEXSTA)
+10 QUIT
SHIS ; Set Index
+1 ; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
+2 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.33,+$GET(DA(1)),2,+$GET(DA),0))
QUIT
+5 IF $LENGTH($GET(LEXDDT))
KILL ^LEX(757.33,"G",LEXMAP,LEXDDT,LEXSTA,DA(1))
+6 SET ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1))=""
+7 QUIT
SDHIS ; Set Default Index
+1 ; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
+2 IF '$LENGTH($GET(LEXSTA))
QUIT
IF '$LENGTH($GET(LEXEFF))
QUIT
+3 IF +$GET(LEXIEN)'>0
QUIT
IF '$DATA(^LEX(757.33,+$GET(LEXIEN),0))
QUIT
+4 SET ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN)=""
+5 QUIT
KHIS ; Kill Index
+1 ; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
+2 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.33,+$GET(DA(1)),2,+$GET(DA),0))
QUIT
+5 KILL ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1),DA)
+6 QUIT
KDHIS ; Kill Default Index
+1 ; ^LEX(757.33,"G",<code>,<date>,<status>,<ien>)
+2 IF '$LENGTH($GET(LEXSTA))
QUIT
IF '$LENGTH($GET(LEXEFF))
QUIT
+3 IF +$GET(LEXIEN)'>0
QUIT
IF '$DATA(^LEX(757.33,+$GET(LEXIEN),0))
QUIT
+4 KILL ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN,0)
+5 QUIT
DF(X,CODE) ; Default Status
+1 NEW LEXI,LEXNF,LEXL,LEXEFF,LEXC
+2 SET LEXI=+$GET(X)
IF +LEXI'>0
QUIT ""
+3 SET LEXEFF=$ORDER(^LEX(757.33,+LEXI,2,"B"," "),-1)
+4 SET LEXL=$ORDER(^LEX(757.33,+LEXI,2,"B",+LEXEFF,0))
+5 SET LEXL=$PIECE($GET(^LEX(757.33,+LEXI,2,+LEXL,0)),U,2)
+6 SET X=LEXL
+7 QUIT X
DDTBR(SYS,STA) ; Default Date Business Rules
+1 ; Input:
+2 ; SYS - System
+3 ; STA - Status
+4 ; Output:
+5 ; If Status = 1 (Give)
+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 (InGive)
+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
