source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX8.m@ 711

Last change on this file since 711 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1LEXNDX8 ; ISL/KER/FJF Set/kill indexes 757.02 ; 05/14/2003
2 ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
3 ;
4 ; Set and Kill Activation History
5 ; File 757.02, field 1
6SAHC ; Set new value when Code is Edited
7 ; ^DD(757.02,1,1,D0,1) = D SAHC^LEXNDX8
8 N LEXCOD,LEXCODX,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF
9 S LEXCODX=$G(X) Q:'$L(LEXCODX) S LEXIEN=+($G(DA)) Q:+LEXIEN'>0
10 S LEXSYS=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",3)) Q:LEXSYS'>0
11 S LEXPRF=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",5))
12 S LEXSYS=$E($G(^LEX(757.03,+LEXSYS,0)),1,3) Q:$L(LEXSYS)'=3
13 I $D(^LEX(757.02,+LEXIEN,4,"B")) S LEXHIS=0 D Q
14 . F S LEXHIS=$O(^LEX(757.02,+LEXIEN,4,LEXHIS)) Q:+LEXHIS=0 D
15 . . N DA,X S DA=+LEXHIS,DA(1)=+LEXIEN D HDC
16 . . S LEXCOD=LEXCODX Q:'$L($G(LEXCOD)) Q:'$L($G(LEXEFF))
17 . . Q:'$L($G(LEXSTA)) D SHIS
18 Q
19KAHC ; Kill old value when Code is Edited
20 ; ^DD(757.02,1,1,D0,2) = D KAHC^LEXNDX8
21 N LEXCOD,LEXCODX,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF
22 S LEXCODX=$G(X) Q:'$L(LEXCODX) S LEXIEN=+($G(DA)) Q:+LEXIEN'>0
23 S LEXSYS=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",3)) Q:LEXSYS'>0
24 S LEXSYS=$E($G(^LEX(757.03,+LEXSYS,0)),1,3) Q:$L(LEXSYS)'=3
25 S LEXPRF=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",5))
26 I $D(^LEX(757.02,+LEXIEN,4,"B")) S LEXHIS=0 D Q
27 . F S LEXHIS=$O(^LEX(757.02,+LEXIEN,4,LEXHIS)) Q:+LEXHIS=0 D
28 . . N DA,X S DA=+LEXHIS,DA(1)=+LEXIEN D HDC
29 . . S LEXCOD=LEXCODX Q:'$L($G(LEXCOD)) Q:'$L($G(LEXEFF))
30 . . Q:'$L($G(LEXSTA)) D KHIS
31 Q
32 ;
33 ; File 757.28, field .01
34SAHD ; Set new value when Effective Date is Edited
35 ; ^DD(757.28,.01,1,D0,1) = D SAHD^LEXNDX8
36 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF
37 D HDC Q:'$L($G(LEXCOD))
38 Q:'$L($G(LEXSTA)) S LEXEFF=+($G(X)) Q:+LEXEFF=0 D SHIS
39 Q
40KAHD ; Kill old value when Effective Date is Edited
41 ; ^DD(757.28,.01,1,D0,2) = D KAHD^LEXIDX8
42 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF
43 D HDC Q:'$L($G(LEXCOD))
44 Q:'$L($G(LEXSTA)) S LEXEFF=+($G(X)) Q:+LEXEFF=0 D KHIS
45 Q
46 ;
47 ; File 757.28 field 1
48SAHS ; Set new value when Status is Edited
49 ; ^DD(757.28,1,1,D0,1) = D SAHS^LEXNDX8
50 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF
51 D HDC Q:'$L($G(LEXCOD)) Q:+LEXEFF=0
52 S LEXSTA=$G(X) Q:'$L(LEXSTA) D SHIS
53 Q
54KAHS ; Kill old value when Status is Edited
55 ; ^DD(757.28,1,1,D0,2) = D KAHS^LEXIDX8
56 N LEXCOD,LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXSYS,LEXPRF
57 D HDC Q:'$L($G(LEXCOD)) Q:+LEXEFF=0
58 S LEXSTA=$G(X) Q:'$L(LEXSTA) D KHIS
59 Q
60 ;
61HDC ; Set Common Variables (Code, Status and Effective Date)
62 S (LEXDDT,LEXDSYS,LEXDF,LEXDSTA,LEXCOD,LEXSTA,LEXEFF)="" Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0
63 Q:'$D(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))
64 S LEXCOD=$P($G(^LEX(757.02,+($G(DA(1))),0)),"^",2)
65 S LEXPRF=+($P($G(^LEX(757.02,+($G(DA(1))),0)),"^",5))
66 S LEXNOD=$G(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))
67 S LEXSTA=$P(LEXNOD,"^",2),LEXEFF=$P(LEXNOD,"^",1)
68 S LEXSTA=$S(LEXSTA="A":1,LEXSTA="I":0,1:LEXSTA)
69 S LEXDSYS=+($P($G(^LEX(757.02,+($G(DA(1))),0)),"^",3))
70 S LEXDSYS=$E($G(^LEX(757.03,+LEXDSYS,0)),1,3)
71 S LEXDSTA=$$DF(+($G(DA(1))),$G(LEXCOD))
72 S LEXDSTA=$S(+LEXDSTA'>0:1,1:0)
73 S LEXDDT=$$DDTBR(LEXDSYS,LEXDSTA)
74 Q
75DHDC ; Set Default Common Variables (Code, Status and Effective Date)
76 ; 0 node
77 S LEXCOD=$G(LEXCODX),LEXSYS=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",3))
78 S (LEXSYS,LEXDSYS)=$E($G(^LEX(757.03,+LEXSYS,0)),1,3)
79 S LEXPRF=+($P($G(^LEX(757.02,+LEXIEN,0)),"^",5))
80 S LEXSTA=$$DF(+($G(DA(1))),$G(LEXCOD))
81 S (LEXSTA,LEXDSTA)=$S(+LEXSTA'>0:1,1:0)
82 S LEXEFF=$$DDTBR(LEXSYS,LEXSTA)
83 S LEXDDT=$$DDTBR(LEXDSYS,LEXDSTA)
84 Q
85SHIS ; Set Index
86 ; ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)
87 Q:'$L($G(LEXCOD)) Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
88 Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0
89 Q:'$D(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))
90 K:$L($G(LEXDDT)) ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXDDT,DA(1),0)
91 S ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,DA(1),DA)=""
92 I +($G(LEXPRF))>0 D
93 . K:$L($G(LEXDDT)) ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,DA(1),0)
94 . S ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,DA(1),DA)=""
95 Q
96SDHIS ; Set Default Index
97 ; ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)
98 Q:'$L($G(LEXCOD)) Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
99 Q:+($G(LEXIEN))'>0 Q:'$D(^LEX(757.02,+($G(LEXIEN)),0))
100 S ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,+LEXIEN,0)=""
101 I +($G(LEXPRF))>0 D
102 . S ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,+LEXIEN,0)=""
103 Q
104KHIS ; Kill Index
105 ; ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)
106 Q:'$L($G(LEXCOD)) Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
107 Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0
108 Q:'$D(^LEX(757.02,+($G(DA(1))),4,+($G(DA)),0))
109 K ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,DA(1),DA)
110 I +($G(LEXPRF))>0 D
111 . K:$L($G(LEXDDT)) ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,DA(1),0)
112 . K ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXEFF,DA(1),DA)
113 Q
114KDHIS ; Kill Default Index
115 ; ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>,<history>)
116 Q:'$L($G(LEXCOD)) Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF))
117 Q:+($G(LEXIEN))'>0 Q:'$D(^LEX(757.02,+($G(LEXIEN)),0))
118 K ^LEX(757.02,"ACT",(LEXCOD_" "),LEXSTA,LEXEFF,+LEXIEN,0)
119 I +($G(LEXPRF))>0 D
120 . K ^LEX(757.02,"ACT",(LEXCOD_" "),(+LEXSTA+2),LEXDDT,+LEXIEN,0)
121 Q
122DF(X,CODE) ; Default Status
123 N LEXI,LEXDF,LEXNF,LEXL,LEXEFF,LEXC,LEXO
124 S LEXI=+($G(X)) Q:+LEXI'>0 ""
125 S LEXEFF=$O(^LEX(757.02,+LEXI,4,"B"," "),-1)
126 S LEXL=$O(^LEX(757.02,+LEXI,4,"B",+LEXEFF,0))
127 S LEXL=$P($G(^LEX(757.02,+LEXI,4,+LEXL,0)),"^",2)
128 S LEXC=$G(CODE) S:'$L(LEXC) LEXC=$P($G(^LEX(757.02,LEXI,0)),U,2)
129 S LEXDF='+$$STATCHK^LEXSRC2(LEXC)
130 S LEXO=$P($G(^LEX(757.02,LEXI,0)),U,2)
131 S LEXNF=$S(+LEXL=1:"",1:LEXDF)
132 S X=LEXNF
133 Q X
134DDTBR(SYS,STA) ; Default Date Business Rules
135 ; Input:
136 ; SYS - System
137 ; STA - Status
138 ; Output:
139 ; If Status = 1 (Active)
140 ; If SYS = ICD/ICP use October 1, 1978 2781001
141 ; If SYS = CPT/CPC use January 1, 1989 2890101
142 ; If SYS is not listed above, use 2960923
143 ; If Status = 0 (Inactive)
144 ; If SYS = ICD/ICP use October 2, 1978 2791001
145 ; If SYS = CPT/CPC use January 2, 1989 2900101
146 ; If SYS is not listed above, use 2960924
147 N LEXSTA,LEXSYS,LEXDT
148 S LEXSTA=+($G(STA)),LEXSYS=$G(SYS),LEXDT=0
149 S:$L(LEXSYS)=3&("^ICD^ICP^CPT^CPC^"'[LEXSYS) LEXSTA=1
150 ; No System, use Lexicon Release Date
151 I $L(LEXSYS)'=3 D Q LEXDT
152 . S:+LEXSTA>0 LEXDT=2960923 S:+LEXSTA'>0 LEXDT=2970923
153 ; System is ICD, use 2781001/2791001
154 I LEXSYS="ICD"!(LEXSYS="ICP") D Q LEXDT
155 . S:LEXSTA>0 LEXDT=2781001 S:LEXSTA'>0 LEXDT=2791001
156 ; System is CPT, use 2890101/2900101
157 I LEXSYS="CPT"!(LEXSYS="CPC") D Q LEXDT
158 . S:LEXSTA>0 LEXDT=2890101 S:LEXSTA'>0 LEXDT=2900101
159 ; System is neither ICD or CPT, use 2960923/2970923
160 I "^ICD^ICP^CPT^CPC^"'[LEXSYS D Q LEXDT
161 . S:LEXSTA>0 LEXDT=2960923 S:LEXSTA'>0 LEXDT=2970923
162 ; None of the Above
163 S:+LEXSTA>0 LEXDT=2960923 S:+LEXSTA'>0 LEXDT=2970923
164 Q LEXDT
Note: See TracBrowser for help on using the repository browser.