ICPTIDX.m

ICPTIDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003

 ;;6.0;CPT/HCPCS;**14**;May 19, 1997

 ;

 ; 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ICPTIDX   3878     printed  Mar 13, 2025@20:50:23                                                                                                                                                                                                     Page 2

ICPTIDX   ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003

 +1       ;;6.0;CPT/HCPCS;**14**;May 19, 1997

 +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