ICPTMIDX.m

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

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

 ;

 ; 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

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

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

 +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