source: WorldVistAEHR/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTIDX.m@ 1046

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

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