165 lines
7.0 KiB
Mathematica
165 lines
7.0 KiB
Mathematica
LEXNDX8 ; ISL/KER/FJF Set/kill indexes 757.02 ; 05/14/2003
|
|
;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
|
|
;
|
|
; 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
|
|
DF(X,CODE) ; Default Status
|
|
N LEXI,LEXDF,LEXNF,LEXL,LEXEFF,LEXC,LEXO
|
|
S LEXI=+($G(X)) Q:+LEXI'>0 ""
|
|
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)
|
|
S LEXO=$P($G(^LEX(757.02,LEXI,0)),U,2)
|
|
S LEXNF=$S(+LEXL=1:"",1:LEXDF)
|
|
S X=LEXNF
|
|
Q X
|
|
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
|