ICPTIDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
;;6.0;CPT/HCPCS;**14**;May 19, 1997;Build 44
;
; ICPTCOD CPT/HCPC Code from Global
; ICPTCODX CPT/HCPC Code passed in (X)
; ICPTEFF Effective Date
; ICPTSTA Status
; ICPTNOD Global Node (to reduce Global hits)
; DA ien file 81 or 81.02
; ICPTIEN,DA(1) ien of file 81
; ICPTHIS ien of file 81.02
; X Data passed in to be indexed
;
; Set and Kill Activation History
;
; File 81, field .01
SAHC ; Set new value when CPT Code is Edited
; ^DD(81,.01,1,D0,1) = D SAHC^ICPTIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD,ICPTCODX,ICPTHIS,ICPTIEN
S ICPTCODX=$G(X) Q:'$L(ICPTCODX) S ICPTIEN=+($G(DA)) Q:+ICPTIEN'>0
S ICPTHIS=0 F S ICPTHIS=$O(^ICPT(+ICPTIEN,60,ICPTHIS)) Q:+ICPTHIS=0 D
. N DA,X S DA=+ICPTHIS,DA(1)=+ICPTIEN D HDC
. S ICPTCOD=ICPTCODX Q:'$L($G(ICPTCOD))
. Q:'$L($G(ICPTEFF)) Q:'$L($G(ICPTSTA)) D SHIS
Q
KAHC ; Kill old value when CPT Code is Edited
; ^DD(81,.01,1,D0,2) = D KAHC^ICPTIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD,ICPTCODX,ICPTHIS,ICPTIEN
S ICPTCODX=$G(X) Q:'$L(ICPTCODX) S ICPTIEN=+($G(DA)) Q:+ICPTIEN'>0
S ICPTHIS=0 F S ICPTHIS=$O(^ICPT(+ICPTIEN,60,ICPTHIS)) Q:+ICPTHIS=0 D
. N DA,X S DA=+ICPTHIS,DA(1)=+ICPTIEN D HDC
. S ICPTCOD=ICPTCODX Q:'$L($G(ICPTCOD))
. Q:'$L($G(ICPTEFF)) Q:'$L($G(ICPTSTA)) D KHIS
Q
;
; File 81.02, field .01
SAHD ; Set new value when Effective Date is Edited
; ^DD(81.02,.01,1,D0,1) = D SAHD^ICPTIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD
D HDC Q:'$L($G(ICPTCOD)) Q:'$L($G(ICPTSTA)) S ICPTEFF=+($G(X)) Q:+ICPTEFF=0 D SHIS
Q
KAHD ; Kill old value when Effective Date is Edited
; ^DD(81.02,.01,1,D0,2) = D KAHD^ICPTIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD D HDC Q:'$L($G(ICPTCOD)) Q:'$L($G(ICPTSTA))
S ICPTEFF=+($G(X)) Q:+ICPTEFF=0 D KHIS
Q
;
; File 81.02, field .02
SAHS ; Set new value when Status is Edited
; ^DD(81.02,.02,1,D0,1) = D SAHS^ICPTIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD
D HDC Q:'$L($G(ICPTCOD)) Q:+ICPTEFF=0
S ICPTSTA=$G(X) Q:'$L(ICPTSTA) D SHIS
Q
KAHS ; Kill old value when Status is Edited
; ^DD(81.02,.02,1,D0,2) = D KAHS^ICPTIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD
D HDC Q:'$L($G(ICPTCOD)) Q:+ICPTEFF=0
S ICPTSTA=$G(X) Q:'$L(ICPTSTA) D KHIS
Q
;
HDC ; Set Common Variables (Code, Status and Effective Date)
S (ICPTCOD,ICPTSTA,ICPTEFF)=""
Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^ICPT(+($G(DA(1))),60,+($G(DA)),0))
S ICPTCOD=$P($G(^ICPT(+($G(DA(1))),0)),"^",1),ICPTNOD=$G(^ICPT(+($G(DA(1))),60,+($G(DA)),0))
S ICPTSTA=$P(ICPTNOD,"^",2),ICPTEFF=$P(ICPTNOD,"^",1)
Q
;
SHIS ; Set Index ^ICPT("ACT",<code>,<status>,<date>,<ien>,<history>)
Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^ICPT(+($G(DA(1))),60,+($G(DA)),0))
S ^ICPT("ACT",(ICPTCOD_" "),ICPTSTA,ICPTEFF,DA(1),DA)=""
N PIECE,INACT S PIECE=$S('ICPTSTA:7,1:8),INACT=$S('ICPTSTA:1,1:"")
S $P(^ICPT(DA(1),0),"^",4)=INACT,$P(^ICPT(DA(1),0),"^",PIECE)=ICPTEFF
Q
KHIS ; Kill Index ^ICPT("ACT",<code>,<status>,<date>,<ien>,<history>)
Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^ICPT(+($G(DA(1))),60,+($G(DA)),0))
N PIECE,INACT,IEN,OPP,OPPSTA,OPPEFF,BOOL
S PIECE=$S('ICPTSTA:7,1:8),INACT=$S('ICPTSTA:"",1:1),OPPEFF=ICPTEFF,BOOL=0
F S OPPEFF=$O(^ICPT(DA(1),60,"B",OPPEFF),-1) Q:'OPPEFF!BOOL D
. S IEN=$O(^ICPT(DA(1),60,"B",OPPEFF,""))
. I 'IEN S OPPEFF="" Q
. S OPP=$G(^ICPT(DA(1),60,IEN,0)),OPPEFF=$P($G(OPP),"^",1)
. S OPPSTA=$P($G(OPP),"^",2),BOOL=OPPSTA'=ICPTSTA
I BOOL D
. S $P(^ICPT(DA(1),0),"^",4)=INACT,$P(^ICPT(DA(1),0),"^",PIECE)=OPPEFF
E S $P(^ICPT(DA(1),0),"^",4)=1,$P(^ICPT(DA(1),0),"^",7,8)="^"
K ^ICPT("ACT",(ICPTCOD_" "),ICPTSTA,ICPTEFF,DA(1),DA)
Q
ICPTIDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
+1 ;;6.0;CPT/HCPCS;**14**;May 19, 1997;Build 44
+2 ;
+3 ; ICPTCOD CPT/HCPC Code from Global
+4 ; ICPTCODX CPT/HCPC Code passed in (X)
+5 ; ICPTEFF Effective Date
+6 ; ICPTSTA Status
+7 ; ICPTNOD Global Node (to reduce Global hits)
+8 ; DA ien file 81 or 81.02
+9 ; ICPTIEN,DA(1) ien of file 81
+10 ; ICPTHIS ien of file 81.02
+11 ; X Data passed in to be indexed
+12 ;
+13 ; Set and Kill Activation History
+14 ;
+15 ; File 81, field .01
SAHC ; Set new value when CPT Code is Edited
+1 ; ^DD(81,.01,1,D0,1) = D SAHC^ICPTIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD,ICPTCODX,ICPTHIS,ICPTIEN
+3 SET ICPTCODX=$GET(X)
IF '$LENGTH(ICPTCODX)
QUIT
SET ICPTIEN=+($GET(DA))
IF +ICPTIEN'>0
QUIT
+4 SET ICPTHIS=0
FOR
SET ICPTHIS=$ORDER(^ICPT(+ICPTIEN,60,ICPTHIS))
IF +ICPTHIS=0
QUIT
Begin DoDot:1
+5 NEW DA,X
SET DA=+ICPTHIS
SET DA(1)=+ICPTIEN
DO HDC
+6 SET ICPTCOD=ICPTCODX
IF '$LENGTH($GET(ICPTCOD))
QUIT
+7 IF '$LENGTH($GET(ICPTEFF))
QUIT
IF '$LENGTH($GET(ICPTSTA))
QUIT
DO SHIS
End DoDot:1
+8 QUIT
KAHC ; Kill old value when CPT Code is Edited
+1 ; ^DD(81,.01,1,D0,2) = D KAHC^ICPTIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD,ICPTCODX,ICPTHIS,ICPTIEN
+3 SET ICPTCODX=$GET(X)
IF '$LENGTH(ICPTCODX)
QUIT
SET ICPTIEN=+($GET(DA))
IF +ICPTIEN'>0
QUIT
+4 SET ICPTHIS=0
FOR
SET ICPTHIS=$ORDER(^ICPT(+ICPTIEN,60,ICPTHIS))
IF +ICPTHIS=0
QUIT
Begin DoDot:1
+5 NEW DA,X
SET DA=+ICPTHIS
SET DA(1)=+ICPTIEN
DO HDC
+6 SET ICPTCOD=ICPTCODX
IF '$LENGTH($GET(ICPTCOD))
QUIT
+7 IF '$LENGTH($GET(ICPTEFF))
QUIT
IF '$LENGTH($GET(ICPTSTA))
QUIT
DO KHIS
End DoDot:1
+8 QUIT
+9 ;
+10 ; File 81.02, field .01
SAHD ; Set new value when Effective Date is Edited
+1 ; ^DD(81.02,.01,1,D0,1) = D SAHD^ICPTIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD
+3 DO HDC
IF '$LENGTH($GET(ICPTCOD))
QUIT
IF '$LENGTH($GET(ICPTSTA))
QUIT
SET ICPTEFF=+($GET(X))
IF +ICPTEFF=0
QUIT
DO SHIS
+4 QUIT
KAHD ; Kill old value when Effective Date is Edited
+1 ; ^DD(81.02,.01,1,D0,2) = D KAHD^ICPTIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD
DO HDC
IF '$LENGTH($GET(ICPTCOD))
QUIT
IF '$LENGTH($GET(ICPTSTA))
QUIT
+3 SET ICPTEFF=+($GET(X))
IF +ICPTEFF=0
QUIT
DO KHIS
+4 QUIT
+5 ;
+6 ; File 81.02, field .02
SAHS ; Set new value when Status is Edited
+1 ; ^DD(81.02,.02,1,D0,1) = D SAHS^ICPTIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD
+3 DO HDC
IF '$LENGTH($GET(ICPTCOD))
QUIT
IF +ICPTEFF=0
QUIT
+4 SET ICPTSTA=$GET(X)
IF '$LENGTH(ICPTSTA)
QUIT
DO SHIS
+5 QUIT
KAHS ; Kill old value when Status is Edited
+1 ; ^DD(81.02,.02,1,D0,2) = D KAHS^ICPTIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTCOD
+3 DO HDC
IF '$LENGTH($GET(ICPTCOD))
QUIT
IF +ICPTEFF=0
QUIT
+4 SET ICPTSTA=$GET(X)
IF '$LENGTH(ICPTSTA)
QUIT
DO KHIS
+5 QUIT
+6 ;
HDC ; Set Common Variables (Code, Status and Effective Date)
+1 SET (ICPTCOD,ICPTSTA,ICPTEFF)=""
+2 IF +($GET(DA(1)))'>0
QUIT
IF +($GET(DA))'>0
QUIT
IF '$DATA(^ICPT(+($GET(DA(1))),60,+($GET(DA)),0))
QUIT
+3 SET ICPTCOD=$PIECE($GET(^ICPT(+($GET(DA(1))),0)),"^",1)
SET ICPTNOD=$GET(^ICPT(+($GET(DA(1))),60,+($GET(DA)),0))
+4 SET ICPTSTA=$PIECE(ICPTNOD,"^",2)
SET ICPTEFF=$PIECE(ICPTNOD,"^",1)
+5 QUIT
+6 ;
SHIS ; Set Index ^ICPT("ACT",<code>,<status>,<date>,<ien>,<history>)
+1 IF +($GET(DA(1)))'>0
QUIT
IF +($GET(DA))'>0
QUIT
IF '$DATA(^ICPT(+($GET(DA(1))),60,+($GET(DA)),0))
QUIT
+2 SET ^ICPT("ACT",(ICPTCOD_" "),ICPTSTA,ICPTEFF,DA(1),DA)=""
+3 NEW PIECE,INACT
SET PIECE=$SELECT('ICPTSTA:7,1:8)
SET INACT=$SELECT('ICPTSTA:1,1:"")
+4 SET $PIECE(^ICPT(DA(1),0),"^",4)=INACT
SET $PIECE(^ICPT(DA(1),0),"^",PIECE)=ICPTEFF
+5 QUIT
KHIS ; Kill Index ^ICPT("ACT",<code>,<status>,<date>,<ien>,<history>)
+1 IF +($GET(DA(1)))'>0
QUIT
IF +($GET(DA))'>0
QUIT
IF '$DATA(^ICPT(+($GET(DA(1))),60,+($GET(DA)),0))
QUIT
+2 NEW PIECE,INACT,IEN,OPP,OPPSTA,OPPEFF,BOOL
+3 SET PIECE=$SELECT('ICPTSTA:7,1:8)
SET INACT=$SELECT('ICPTSTA:"",1:1)
SET OPPEFF=ICPTEFF
SET BOOL=0
+4 FOR
SET OPPEFF=$ORDER(^ICPT(DA(1),60,"B",OPPEFF),-1)
IF 'OPPEFF!BOOL
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^ICPT(DA(1),60,"B",OPPEFF,""))
+6 IF 'IEN
SET OPPEFF=""
QUIT
+7 SET OPP=$GET(^ICPT(DA(1),60,IEN,0))
SET OPPEFF=$PIECE($GET(OPP),"^",1)
+8 SET OPPSTA=$PIECE($GET(OPP),"^",2)
SET BOOL=OPPSTA'=ICPTSTA
End DoDot:1
+9 IF BOOL
Begin DoDot:1
+10 SET $PIECE(^ICPT(DA(1),0),"^",4)=INACT
SET $PIECE(^ICPT(DA(1),0),"^",PIECE)=OPPEFF
End DoDot:1
+11 IF '$TEST
SET $PIECE(^ICPT(DA(1),0),"^",4)=1
SET $PIECE(^ICPT(DA(1),0),"^",7,8)="^"
+12 KILL ^ICPT("ACT",(ICPTCOD_" "),ICPTSTA,ICPTEFF,DA(1),DA)
+13 QUIT
