source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD0IDX.m@ 1671

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

initial load of FOIAVistA 6/30/08 version
File size: 3.7 KB
Line 
1ICD0IDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
2 ;;18.0;DRG Grouper;**6**;Oct 20, 2000
3 ;
4 ; ICDCOD ICD Code from Global
5 ; ICDCODX ICD Code passed in (X)
6 ; ICDEFF Effective Date
7 ; ICDSTA Status
8 ; ICDNOD Global Node (to reduce Global hits)
9 ; DA ien file 80.1 or 80.166
10 ; ICDIEN,DA(1) ien of file 80.1
11 ; ICDHIS ien of file 80.166
12 ; X Data passed in to be indexed
13 ;
14 ; Set and Kill Activation History
15 ;
16 ; File 80.1, field .01
17SAHC ; Set new value when ICD Code is Edited
18 ; ^DD(80.1,.01,1,D0,1) = D SAHC^ICD0IDX
19 N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN
20 S ICDCODX=$G(X) Q:'$L(ICDCODX) S ICDIEN=+($G(DA)) Q:+ICDIEN'>0 Q:'$D(^ICD0(+ICDIEN,66))
21 S ICDHIS=0 F S ICDHIS=$O(^ICD0(+ICDIEN,66,ICDHIS)) Q:+ICDHIS=0 D
22 . N DA,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC
23 . S ICDCOD=ICDCODX Q:'$L($G(ICDCOD))
24 . Q:'$L($G(ICDEFF)) Q:'$L($G(ICDSTA)) D SHIS
25 Q
26KAHC ; Kill old value when ICD Code is Edited
27 ; ^DD(80.1,.01,1,D0,2) = D KAHC^ICD0IDX
28 N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN
29 S ICDCODX=$G(X) Q:'$L(ICDCODX) S ICDIEN=+($G(DA)) Q:+ICDIEN'>0 Q:'$D(^ICD0(+ICDIEN,66))
30 S ICDHIS=0 F S ICDHIS=$O(^ICD0(+ICDIEN,66,ICDHIS)) Q:+ICDHIS=0 D
31 . N DA,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC
32 . S ICDCOD=ICDCODX Q:'$L($G(ICDCOD))
33 . Q:'$L($G(ICDEFF)) Q:'$L($G(ICDSTA)) D KHIS
34 Q
35 ;
36 ; File 80.166, field .01
37SAHD ; Set new value when Effective Date is Edited
38 ; ^DD(80.166,.01,1,D0,1) = D SAHD^ICD0IDX
39 N ICDNOD,ICDSTA,ICDEFF,ICDCOD
40 D HDC Q:'$L($G(ICDCOD)) Q:'$L($G(ICDSTA)) S ICDEFF=+($G(X)) Q:+ICDEFF=0 D SHIS
41 Q
42KAHD ; Kill old value when Effective Date is Edited
43 ; ^DD(80.166,.01,1,D0,2) = D KAHD^ICD0IDX
44 N ICDNOD,ICDSTA,ICDEFF,ICDCOD
45 D HDC Q:'$L($G(ICDCOD)) Q:'$L($G(ICDSTA))
46 S ICDEFF=+($G(X)) Q:+ICDEFF=0 D KHIS
47 Q
48 ;
49 ; File 80.166, field .02
50SAHS ; Set new value when Status is Edited
51 ; ^DD(80.166,.02,1,D0,1) = D SAHS^ICD0IDX
52 N ICDNOD,ICDSTA,ICDEFF,ICDCOD
53 D HDC Q:'$L($G(ICDCOD)) Q:+ICDEFF=0
54 S ICDSTA=$G(X) Q:'$L(ICDSTA) D SHIS
55 Q
56KAHS ; Kill old value when Status is Edited
57 ; ^DD(80.1.066,.02,1,D0,2) = D KAHS^ICD0IDX
58 N ICDNOD,ICDSTA,ICDEFF,ICDCOD
59 D HDC Q:'$L($G(ICDCOD)) Q:+ICDEFF=0
60 S ICDSTA=$G(X) Q:'$L(ICDSTA) D KHIS
61 Q
62 ;
63HDC ; Set Common Variables (Code, Status and Effective Date)
64 S (ICDCOD,ICDSTA,ICDEFF)=""
65 Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^ICD0(+($G(DA(1))),66,+($G(DA)),0))
66 S ICDCOD=$P($G(^ICD0(+($G(DA(1))),0)),"^",1),ICDNOD=$G(^ICD0(+($G(DA(1))),66,+($G(DA)),0))
67 S ICDSTA=$P(ICDNOD,"^",2),ICDEFF=$P(ICDNOD,"^",1)
68 Q
69 ;
70SHIS ; Set Index ^ICD0("ACT",<code>,<status>,<date>,<ien>,<history>)
71 Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^ICD0(+($G(DA(1))),66,+($G(DA)),0))
72 S ^ICD0("ACT",(ICDCOD_" "),ICDSTA,ICDEFF,DA(1),DA)=""
73 N PIECE,INACT S PIECE=$S('ICDSTA:11,1:12),INACT=$S('ICDSTA:1,1:"")
74 S $P(^ICD0(DA(1),0),"^",9)=INACT,$P(^ICD0(DA(1),0),"^",PIECE)=ICDEFF
75 Q
76KHIS ; Kill Index ^ICD0("ACT",<code>,<status>,<date>,<ien>,<history>)
77 Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^ICD0(+($G(DA(1))),66,+($G(DA)),0))
78 N PIECE,INACT,IEN,OPP,OPPSTA,OPPEFF,BOOL
79 S PIECE=$S('ICDSTA:11,1:12),INACT=$S('ICDSTA:"",1:1),OPPEFF=ICDEFF,BOOL=0
80 F S OPPEFF=$O(^ICD0(DA(1),66,"B",OPPEFF),-1) Q:'OPPEFF!BOOL D
81 . S IEN=$O(^ICD0(DA(1),66,"B",OPPEFF,""))
82 . I 'IEN S OPPEFF="" Q
83 . S OPP=$G(^ICD0(DA(1),66,IEN,0)),OPPEFF=$P($G(OPP),"^",1)
84 . S OPPSTA=$P($G(OPP),"^",2),BOOL=OPPSTA'=ICDSTA
85 I BOOL D
86 . S $P(^ICD0(DA(1),0),"^",9)=INACT,$P(^ICD0(DA(1),0),"^",PIECE)=$G(OPPEFF)
87 E S $P(^ICD0(DA(1),0),"^",9)=1,$P(^ICD0(DA(1),0),"^",11,12)="^"
88 K ^ICD0("ACT",(ICDCOD_" "),ICDSTA,ICDEFF,DA(1),DA)
89 Q
Note: See TracBrowser for help on using the repository browser.