ICPTMIDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
;;6.0;CPT/HCPCS;**14**;May 19, 1997
;
; ICPTMOD CPT/HCPC Code Modifier from Global
; ICPTMODX CPT/HCPC Code Modifier passed in (X)
; ICPTEFF Effective Date
; ICPTSTA Status
; ICPTNOD Global Node (to reduce Global hits)
; DA ien file 81.3 or 81.33
; ICPTIEN,DA(1) ien of file 81.3
; ICPTHIS ien of file 81.33
; X Data passed in to be indexed
;
; Set and Kill Activation History
;
; File 81.3, field .01
SAHC ; Set new value when CPT Code Modifier is Edited
; ^DD(81.3,.01,1,D0,1) = D SAHC^ICPTMIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD,ICPTMODX,ICPTHIS,ICPTIEN
S ICPTMODX=$G(X) Q:'$L(ICPTMODX) S ICPTIEN=+($G(DA)) Q:+ICPTIEN'>0
S ICPTHIS=0 F S ICPTHIS=$O(^DIC(81.3,+ICPTIEN,60,ICPTHIS)) Q:+ICPTHIS=0 D
. N DA,X S DA=+ICPTHIS,DA(1)=+ICPTIEN D HDC
. S ICPTMOD=ICPTMODX Q:'$L($G(ICPTMOD))
. Q:'$L($G(ICPTEFF)) Q:'$L($G(ICPTSTA)) D SHIS
Q
KAHC ; Kill old value when CPT Code is Edited
; ^DD(81.3,.01,1,D0,2) = D KAHC^ICPTMIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD,ICPTMODX,ICPTHIS,ICPTIEN
S ICPTMODX=$G(X) Q:'$L(ICPTMODX) S ICPTIEN=+($G(DA)) Q:+ICPTIEN'>0
S ICPTHIS=0 F S ICPTHIS=$O(^DIC(81.3,+ICPTIEN,60,ICPTHIS)) Q:+ICPTHIS=0 D
. N DA,X S DA=+ICPTHIS,DA(1)=+ICPTIEN D HDC
. S ICPTMOD=ICPTMODX Q:'$L($G(ICPTMOD))
. Q:'$L($G(ICPTEFF)) Q:'$L($G(ICPTSTA)) D KHIS
Q
;
; File 81.33, field .01
SAHD ; Set new value when Effective Date is Edited
; ^DD(81.33,.01,1,D0,1) = D SAHD^ICPTMIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
D HDC Q:'$L($G(ICPTMOD)) 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.33,.01,1,D0,2) = D KAHD^ICPTMIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
D HDC Q:'$L($G(ICPTMOD)) Q:'$L($G(ICPTSTA))
S ICPTEFF=+($G(X)) Q:+ICPTEFF=0 D KHIS
Q
;
; File 81.33, field .02
SAHS ; Set new value when Status is Edited
; ^DD(81.33,.02,1,D0,1) = D SAHS^ICPTMIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
D HDC Q:'$L($G(ICPTMOD)) Q:+ICPTEFF=0
S ICPTSTA=$G(X) Q:'$L(ICPTSTA) D SHIS
Q
KAHS ; Kill old value when Status is Edited
; ^DD(81.33,.02,1,D0,2) = D KAHS^ICPTMIDX
N ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
D HDC Q:'$L($G(ICPTMOD)) Q:+ICPTEFF=0
S ICPTSTA=$G(X) Q:'$L(ICPTSTA) D KHIS
Q
;
HDC ; Set Common Variables (Code, Status and Effective Date)
S (ICPTMOD,ICPTSTA,ICPTEFF)=""
Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^DIC(81.3,+($G(DA(1))),60,+($G(DA)),0))
S ICPTMOD=$P($G(^DIC(81.3,+($G(DA(1))),0)),"^",1),ICPTNOD=$G(^DIC(81.3,+($G(DA(1))),60,+($G(DA)),0))
S ICPTSTA=$P(ICPTNOD,"^",2),ICPTEFF=$P(ICPTNOD,"^",1)
Q
;
SHIS ; Set Index ^DIC(81.3,"ACT",<code>,<status>,<date>,<ien>,<history>)
Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^DIC(81.3,+($G(DA(1))),60,+($G(DA)),0))
S ^DIC(81.3,"ACT",(ICPTMOD_" "),ICPTSTA,ICPTEFF,DA(1),DA)=""
N PIECE,INACT S PIECE=$S('ICPTSTA:7,1:8),INACT=$S('ICPTSTA:1,1:"")
S $P(^DIC(81.3,DA(1),0),"^",5)=INACT,$P(^DIC(81.3,DA(1),0),"^",PIECE)=ICPTEFF
Q
KHIS ; Kill Index ^DIC(81.3,"ACT",<code>,<status>,<date>,<ien>,<history>)
Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(^DIC(81.3,+($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(^DIC(81.3,DA(1),60,"B",OPPEFF),-1) Q:'OPPEFF!BOOL D
. S IEN=$O(^DIC(81.3,DA(1),60,"B",OPPEFF,""))
. I 'IEN S OPPEFF="" Q
. S OPP=$G(^DIC(81.3,DA(1),60,IEN,0)),OPPEFF=$P($G(OPP),"^",1)
. S OPPSTA=$P($G(OPP),"^",2),BOOL=OPPSTA'=ICPTSTA
I BOOL D
. S $P(^DIC(81.3,DA(1),0),"^",5)=INACT,$P(^DIC(81.3,DA(1),0),"^",PIECE)=OPPEFF
E S $P(^DIC(81.3,DA(1),0),"^",5)=1,$P(^DIC(81.3,DA(1),0),"^",7,8)="^"
K ^DIC(81.3,"ACT",(ICPTMOD_" "),ICPTSTA,ICPTEFF,DA(1),DA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICPTMIDX 4003 printed Dec 13, 2024@01:45:45 Page 2
ICPTMIDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
+1 ;;6.0;CPT/HCPCS;**14**;May 19, 1997
+2 ;
+3 ; ICPTMOD CPT/HCPC Code Modifier from Global
+4 ; ICPTMODX CPT/HCPC Code Modifier passed in (X)
+5 ; ICPTEFF Effective Date
+6 ; ICPTSTA Status
+7 ; ICPTNOD Global Node (to reduce Global hits)
+8 ; DA ien file 81.3 or 81.33
+9 ; ICPTIEN,DA(1) ien of file 81.3
+10 ; ICPTHIS ien of file 81.33
+11 ; X Data passed in to be indexed
+12 ;
+13 ; Set and Kill Activation History
+14 ;
+15 ; File 81.3, field .01
SAHC ; Set new value when CPT Code Modifier is Edited
+1 ; ^DD(81.3,.01,1,D0,1) = D SAHC^ICPTMIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD,ICPTMODX,ICPTHIS,ICPTIEN
+3 SET ICPTMODX=$GET(X)
if '$LENGTH(ICPTMODX)
QUIT
SET ICPTIEN=+($GET(DA))
if +ICPTIEN'>0
QUIT
+4 SET ICPTHIS=0
FOR
SET ICPTHIS=$ORDER(^DIC(81.3,+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 ICPTMOD=ICPTMODX
if '$LENGTH($GET(ICPTMOD))
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.3,.01,1,D0,2) = D KAHC^ICPTMIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD,ICPTMODX,ICPTHIS,ICPTIEN
+3 SET ICPTMODX=$GET(X)
if '$LENGTH(ICPTMODX)
QUIT
SET ICPTIEN=+($GET(DA))
if +ICPTIEN'>0
QUIT
+4 SET ICPTHIS=0
FOR
SET ICPTHIS=$ORDER(^DIC(81.3,+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 ICPTMOD=ICPTMODX
if '$LENGTH($GET(ICPTMOD))
QUIT
+7 if '$LENGTH($GET(ICPTEFF))
QUIT
if '$LENGTH($GET(ICPTSTA))
QUIT
DO KHIS
End DoDot:1
+8 QUIT
+9 ;
+10 ; File 81.33, field .01
SAHD ; Set new value when Effective Date is Edited
+1 ; ^DD(81.33,.01,1,D0,1) = D SAHD^ICPTMIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
+3 DO HDC
if '$LENGTH($GET(ICPTMOD))
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.33,.01,1,D0,2) = D KAHD^ICPTMIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
+3 DO HDC
if '$LENGTH($GET(ICPTMOD))
QUIT
if '$LENGTH($GET(ICPTSTA))
QUIT
+4 SET ICPTEFF=+($GET(X))
if +ICPTEFF=0
QUIT
DO KHIS
+5 QUIT
+6 ;
+7 ; File 81.33, field .02
SAHS ; Set new value when Status is Edited
+1 ; ^DD(81.33,.02,1,D0,1) = D SAHS^ICPTMIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
+3 DO HDC
if '$LENGTH($GET(ICPTMOD))
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.33,.02,1,D0,2) = D KAHS^ICPTMIDX
+2 NEW ICPTNOD,ICPTSTA,ICPTEFF,ICPTMOD
+3 DO HDC
if '$LENGTH($GET(ICPTMOD))
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 (ICPTMOD,ICPTSTA,ICPTEFF)=""
+2 if +($GET(DA(1)))'>0
QUIT
if +($GET(DA))'>0
QUIT
if '$DATA(^DIC(81.3,+($GET(DA(1))),60,+($GET(DA)),0))
QUIT
+3 SET ICPTMOD=$PIECE($GET(^DIC(81.3,+($GET(DA(1))),0)),"^",1)
SET ICPTNOD=$GET(^DIC(81.3,+($GET(DA(1))),60,+($GET(DA)),0))
+4 SET ICPTSTA=$PIECE(ICPTNOD,"^",2)
SET ICPTEFF=$PIECE(ICPTNOD,"^",1)
+5 QUIT
+6 ;
SHIS ; Set Index ^DIC(81.3,"ACT",<code>,<status>,<date>,<ien>,<history>)
+1 if +($GET(DA(1)))'>0
QUIT
if +($GET(DA))'>0
QUIT
if '$DATA(^DIC(81.3,+($GET(DA(1))),60,+($GET(DA)),0))
QUIT
+2 SET ^DIC(81.3,"ACT",(ICPTMOD_" "),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(^DIC(81.3,DA(1),0),"^",5)=INACT
SET $PIECE(^DIC(81.3,DA(1),0),"^",PIECE)=ICPTEFF
+5 QUIT
KHIS ; Kill Index ^DIC(81.3,"ACT",<code>,<status>,<date>,<ien>,<history>)
+1 if +($GET(DA(1)))'>0
QUIT
if +($GET(DA))'>0
QUIT
if '$DATA(^DIC(81.3,+($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(^DIC(81.3,DA(1),60,"B",OPPEFF),-1)
if 'OPPEFF!BOOL
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^DIC(81.3,DA(1),60,"B",OPPEFF,""))
+6 IF 'IEN
SET OPPEFF=""
QUIT
+7 SET OPP=$GET(^DIC(81.3,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(^DIC(81.3,DA(1),0),"^",5)=INACT
SET $PIECE(^DIC(81.3,DA(1),0),"^",PIECE)=OPPEFF
End DoDot:1
+11 IF '$TEST
SET $PIECE(^DIC(81.3,DA(1),0),"^",5)=1
SET $PIECE(^DIC(81.3,DA(1),0),"^",7,8)="^"
+12 KILL ^DIC(81.3,"ACT",(ICPTMOD_" "),ICPTSTA,ICPTEFF,DA(1),DA)
+13 QUIT
