LEXQC4.m

LEXQC4 ;ISL/KER - Query - Changes - CPT/MOD ;05/23/2017

 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2

 ;               

 ; Global Variables

 ;    ^DIC(81.3,          ICR   4492

 ;    ^ICPT(              ICR   4489

 ;    ^TMP("LEXQC")       SACC 2.3.2.5.1

 ;               

 ; External References

 ;    None

 ;               

 ; Local Variables NEWed in LEXQC

 ;    LEXADT              After Date

 ;    LEXBDT              Before Date

 ;    LEXCDT              Versioning Date

 ;    LEXQLEN             Length of Display

 ;    LEXQSTR             Length of String

 ;    LEXQTOT             Total Records

 ;               

CPT ; CPT Procedures Changes

 K ^TMP("LEXQC",$J,"CPT"),^TMP("LEXQC",$J,"CPC") N LEX1,LEX2,LEX3,LEX4

 N LEX5,LEX6,LEXAEF,LEXAST,LEXBEF,LEXBST,LEXCEF,LEXCNT,LEXCST,LEXH

 N LEXIDT,LEXIEN,LEXLC,LEXND,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID

 S LEXQLEN=+($G(LEXQLEN)),LEXQTOT=+($G(LEXQTOT))

 S LEXQSTR=+($G(LEXQSTR)),LEXCNT=0,LEXLC=0

 S LEXIDT=$$IMPDATE^LEXU("CPT"),LEXCDT=$G(LEXCDT)

 Q:LEXCDT'?7N  Q:LEXCDT'>LEXIDT  S LEXIEN=0

 F  S LEXIEN=$O(^ICPT(LEXIEN)) Q:+LEXIEN'>0  D

 . N LEX1,LEX2,LEX3,LEX4,LEX5,LEX6,LEX7,LEX7D,LEX8,LEX8D,LEXAEF

 . N LEXAST,LEXBEF,LEXBST,LEXCEF,LEXCST,LEXH,LEXND,LEXPEF,LEXPST

 . N LEXQL,LEXSO,LEXSTID,LEXSID

 . S LEXCNT=LEXCNT+1 I LEXCNT'<+($G(LEXQSTR)) S LEXLC=+($G(LEXLC))+1 D

 . . W:'$D(ZTQUEUED)&('$D(LEXQUIET))&(LEXLC'>+($G(LEXQLEN))) "." S LEXCNT=0

 . S LEXSID="CPT",LEXSO=$P($G(^ICPT(LEXIEN,0)),"^",1) Q:'$L(LEXSO)

 . S:$E(LEXSO,1)?1U LEXSID="CPC"

 . S LEXH=$O(^ICPT(+LEXIEN,60,"B",LEXCDT," "),-1)

 . S LEXND=$G(^ICPT(+LEXIEN,60,+LEXH,0))

 . S LEXCEF=$P(LEXND,"^",1),LEXCST=$P(LEXND,"^",2)

 . S LEXH=$O(^ICPT(+LEXIEN,60,"B",LEXBDT," "),-1)

 . S LEXND=$G(^ICPT(+LEXIEN,60,+LEXH,0))

 . S LEXBEF=$P(LEXND,"^",1),LEXBST=$P(LEXND,"^",2)

 . S LEXH=$O(^ICPT(+LEXIEN,60,"B",LEXADT," "),-1)

 . S LEXND=$G(^ICPT(+LEXIEN,60,+LEXH,0))

 . S LEXAEF=$P(LEXND,"^",1),LEXAST=$P(LEXND,"^",2)

 . S LEXH=$O(^ICPT(+LEXIEN,60,"B",LEXCDT),-1)

 . S LEXH=$O(^ICPT(+LEXIEN,60,"B",+LEXH," "),-1)

 . S LEXND=$G(^ICPT(+LEXIEN,60,+LEXH,0))

 . S LEXPEF=$P(LEXND,"^",1),LEXPST=$P(LEXND,"^",2)

 . S LEX1=$D(^ICPT(+LEXIEN,61,"B",LEXCDT))>0

 . S LEX2=$D(^ICPT(+LEXIEN,62,"B",LEXCDT))>0

 . S LEX3=$O(^ICPT(+LEXIEN,61,"B",LEXCDT),-1)

 . S LEX4=$O(^ICPT(+LEXIEN,62,"B",LEXCDT),-1)

 . S LEX5=$D(^ICPT(+LEXIEN,61,"B",LEXCDT))

 . S LEX6=$D(^ICPT(+LEXIEN,62,"B",LEXCDT))

 . ; Short IEN Dupe

 . S LEX7=$O(^ICPT(+LEXIEN,61,"B",LEXCDT," "),-1),LEX7=$$DUPS^LEXQC5(81,LEXIEN,LEX7)

 . ; Long IEN Dupe

 . S LEX8=$O(^ICPT(+LEXIEN,62,"B",LEXCDT," "),-1),LEX8=$$DUPL^LEXQC5(81,LEXIEN,LEX8)

 . ; Activiation/Inactiviation/Re-Activation

 . ;   Has a current status and effective date

 . ;   Has a previous status and effective date

 . ;   Current status not equal to previosu status

 . ;   Has a short description

 . ;   Has a long description

 . ;   Activation - current status >0

 . ;   Inactivatin - current status =0

 . ;   Reactivation - current status >0 past status =0

 . S LEXQL=0 I $L(LEXCST),$L(LEXCEF) D  Q:LEXQL

 . . Q:$L(LEXBEF)&($L(LEXBST))&(LEXBST'=LEXCST)

 . . Q:$L(LEXAEF)&($L(LEXAST))&(LEXAST'=LEXCST)

 . . Q:(LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))  Q:'$L($G(LEXSO))

 . . N LEXCT,LEXO,LEXSTID S LEXSTID=$S(+LEXCST>0:"ACT",1:"INA")

 . . I LEXSTID="ACT",$G(LEXPEF)?7N,+($G(LEXPST))'>0 D

 . . . I +($G(LEX5))'>0,+($G(LEX6))'>0 S LEXSTID="REA"

 . . S LEXQL=1

 . . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,LEXSTID,0)))

 . . S:'$D(^TMP("LEXQC",$J,LEXSID,LEXSTID,1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,1,(LEXSO_" "))=LEXO

 . . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,0)=LEXCT

 . ; Revision

 . ;   I Previous status (LEXPST) >0 and

 . ;     Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or

 . ;     long exist (LEX2) with a previosu long (LEX4) and not a duplicate (LEX8)

 . S LEXQL=0 I +LEXPST>0,((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0))) D  Q:LEXQL

 . . N LEXCT,LEXO Q:'$L($G(LEXSO))

 . . S LEXQL=1,LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"REV",0)))

 . . S:'$D(^TMP("LEXQC",$J,LEXSID,"REV",1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . S ^TMP("LEXQC",$J,LEXSID,"REV",1,(LEXSO_" "))=LEXO

 . . S ^TMP("LEXQC",$J,LEXSID,"REV",0)=LEXCT

 . ; Re-Use

 . ;   Current status (LEXCST) exist and active

 . ;   Previous Status (LEXPST) exist and is active

 . ;     Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or

 . ;     long exist (LEX2) with a previosu long (LEX4) and not a duplicate (LEX8)

 . S LEXQL=0 I ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0))),((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0))) D

 . . N LEXCT,LEXO S LEXQL=1

 . . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"REU",0)))

 . . S:'$D(^TMP("LEXQC",$J,LEXSID,"REU",1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . S ^TMP("LEXQC",$J,LEXSID,"REU",1,(LEXSO_" "))=LEXO

 . . S ^TMP("LEXQC",$J,LEXSID,"REU",0)=LEXCT

 D:$D(^TMP("LEXQC",$J,"CPT")) UPC("CPT")

 D:$D(^TMP("LEXQC",$J,"CPC")) UPC("CPC")

 N LEXQUIET

 Q

MOD ; CPT Modifier Changes

 K ^TMP("LEXQC",$J,"MOD") N LEX1,LEX2,LEX3,LEX4,LEX5,LEX6,LEXAEF

 N LEXAST,LEXBEF,LEXBST,LEXCEF,LEXCNT,LEXCST,LEXH,LEXIDT,LEXIEN

 N LEXLC,LEXND,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID

 S LEXQLEN=+($G(LEXQLEN)) S LEXQTOT=+($G(LEXQTOT))

 S LEXQSTR=+($G(LEXQSTR)),LEXCNT=0,LEXLC=0

 S LEXIDT=$$IMPDATE^LEXU("CPT"),LEXCDT=$G(LEXCDT)

 Q:LEXCDT'?7N  Q:LEXCDT'>LEXIDT  S LEXIEN=0

 F  S LEXIEN=$O(^DIC(81.3,LEXIEN)) Q:+LEXIEN'>0  D

 . Q:$O(^DIC(81.3,+LEXIEN,60,0))'>0  N LEX1,LEX2,LEX3,LEX4,LEX5

 . N LEX6,LEX7,LEX8,LEXAEF,LEXAF,LEXAST,LEXACT,LEXBEF,LEXBST,LEXCEF

 . N LEXCST,LEXH,LEXIF,LEXINA,LEXND,LEXPEF,LEXPST,LEXQL,LEXR,LEXRI

 . N LEXSO,LEXSTID,LEXSID S LEXCNT=LEXCNT+1

 . I LEXCNT'<+($G(LEXQSTR)) S LEXLC=+($G(LEXLC))+1 D

 . . W:'$D(ZTQUEUED)&('$D(LEXQUIET))&(LEXLC'>+($G(LEXQLEN))) "." S LEXCNT=0

 . S LEXSID="MOD" S LEXSO=$P($G(^DIC(81.3,LEXIEN,0)),"^",1)

 . Q:'$L(LEXSO)  S LEXH=$O(^DIC(81.3,+LEXIEN,60,"B",LEXCDT," "),-1)

 . S LEXND=$G(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 . S LEXCEF=$P(LEXND,"^",1),LEXCST=$P(LEXND,"^",2)

 . S LEXH=$O(^DIC(81.3,+LEXIEN,60,"B",LEXBDT," "),-1)

 . S LEXND=$G(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 . S LEXBEF=$P(LEXND,"^",1),LEXBST=$P(LEXND,"^",2)

 . S LEXH=$O(^DIC(81.3,+LEXIEN,60,"B",LEXADT," "),-1)

 . S LEXND=$G(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 . S LEXAEF=$P(LEXND,"^",1),LEXAST=$P(LEXND,"^",2)

 . S LEXH=$O(^DIC(81.3,+LEXIEN,60,"B",LEXCDT),-1)

 . S LEXH=$O(^DIC(81.3,+LEXIEN,60,"B",+LEXH," "),-1)

 . S LEXND=$G(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 . S LEXPEF=$P(LEXND,"^",1),LEXPST=$P(LEXND,"^",2)

 . S LEX1=$D(^DIC(81.3,+LEXIEN,61,"B",LEXCDT))>0

 . S LEX2=$D(^DIC(81.3,+LEXIEN,62,"B",LEXCDT))>0

 . S LEX3=$O(^DIC(81.3,+LEXIEN,61,"B",LEXCDT),-1)

 . S LEX4=$O(^DIC(81.3,+LEXIEN,62,"B",LEXCDT),-1)

 . S LEX5=$D(^DIC(81.3,+LEXIEN,61,"B",LEXCDT))

 . S LEX6=$D(^DIC(81.3,+LEXIEN,62,"B",LEXCDT))

 . ; Short IEN Dupe

 . S LEX7=$O(^DIC(81.3,+LEXIEN,61,"B",LEXCDT," "),-1),LEX7=$$DUPS^LEXQC5(81.3,LEXIEN,LEX7)

 . ; Long IEN Dupe

 . S LEX8=$O(^DIC(81.3,+LEXIEN,62,"B",LEXCDT," "),-1),LEX8=$$DUPL^LEXQC5(81.3,LEXIEN,LEX8)

 . ; Activiation/Inactiviation/Re-Activation

 . ;   Has a current status and effective date

 . ;   Has a previous status and effective date

 . ;   Current status not equal to previosu status

 . ;   Has a short description

 . ;   Has a long description

 . ;   Activation - current status >0

 . ;   Inactivatin - current status =0

 . ;   Reactivation - current status >0 past status =0

 . S LEXQL=0 I $L(LEXCST),$L(LEXCEF) D

 . . Q:$L(LEXBEF)&($L(LEXBST))&(LEXBST'=LEXCST)

 . . Q:$L(LEXAEF)&($L(LEXAST))&(LEXAST'=LEXCST)

 . . Q:(LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))

 . . N LEXSTID Q:'$L($G(LEXSO))

 . . N LEXCT,LEXO S LEXSTID=$S(+LEXCST>0:"ACT",1:"INA")

 . . I LEXSTID="ACT",$G(LEXPEF)?7N,+($G(LEXPST))'>0 D

 . . . I +($G(LEX5))'>0,+($G(LEX6))'>0 S LEXSTID="REA"

 . . S LEXQL=1,LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,LEXSTID,0)))

 . . S:'$D(^TMP("LEXQC",$J,LEXSID,LEXSTID,1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,1,(LEXSO_" "))=LEXO

 . . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,0)=LEXCT

 . ; Revision

 . ;   I Previous status (LEXPST) >0 and

 . ;     Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or

 . ;     Long exist (LEX2) with a previosu long (LEX4) and not a duplicate (LEX8)

 . I 'LEXQL I +LEXPST>0,((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0))) D  Q:LEXQL

 . . N LEXCT,LEXO Q:'$L($G(LEXSO))  S LEXQL=1

 . . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"REV",0)))

 . . S:'$D(^TMP("LEXQC",$J,LEXSID,"REV",1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . S ^TMP("LEXQC",$J,LEXSID,"REV",1,(LEXSO_" "))=LEXO

 . . S ^TMP("LEXQC",$J,LEXSID,"REV",0)=LEXCT

 . ; Re-Used

 . ;   Current status (LEXCST) exist and active

 . ;   Previous Status (LEXPST) exist and is active

 . ;     Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or

 . ;     Long exist (LEX2) with a previosu long (LEX4) and not a duplicate (LEX8)

 . I 'LEXQL S LEXQL=0 I ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0))),((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0))) D

 . . N LEXCT,LEXO S LEXQL=1

 . . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"REU",0)))

 . . S:'$D(^TMP("LEXQC",$J,LEXSID,"REU",1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . S ^TMP("LEXQC",$J,LEXSID,"REU",1,(LEXSO_" "))=LEXO

 . . S ^TMP("LEXQC",$J,LEXSID,"REU",0)=LEXCT

 . S (LEXAF,LEXIF,LEXRI)=0,LEXSID="RAN",LEXR=0

 . F  S LEXRI=$O(^DIC(81.3,+LEXIEN,10,LEXRI)) Q:+LEXRI'>0  D  Q:LEXR>1

 . . S LEXND=$G(^DIC(81.3,+LEXIEN,10,LEXRI,0))

 . . S LEXACT=$P(LEXND,"^",3),LEXINA=$P(LEXND,"^",4)

 . . I LEXACT=LEXCDT,'$L(LEXINA) D

 . . . N LEXCT,LEXO Q:$D(^TMP("LEXQC",$J,LEXSID,"ACT",1,(LEXSO_" ")))

 . . . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"ACT",0)))

 . . . S:'$D(^TMP("LEXQC",$J,LEXSID,"ACT",1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . . S ^TMP("LEXQC",$J,LEXSID,"ACT",1,(LEXSO_" "))=LEXO

 . . . S ^TMP("LEXQC",$J,LEXSID,"ACT",0)=LEXCT,LEXAF=1

 . . I LEXINA=LEXCDT,$L(LEXACT),LEXINA>LEXACT,(LEXINA-LEXACT)>1 D

 . . . N LEXCT,LEXO Q:$D(^TMP("LEXQC",$J,LEXSID,"INA",1,(LEXSO_" ")))

 . . . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 . . . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"INA",0)))

 . . . S:'$D(^TMP("LEXQC",$J,LEXSID,"INA",1,(LEXSO_" "))) LEXCT=LEXCT+1

 . . . S ^TMP("LEXQC",$J,LEXSID,"INA",1,(LEXSO_" "))=LEXO

 . . . S ^TMP("LEXQC",$J,LEXSID,"INA",0)=LEXCT,LEXIF=1

 . . S LEXR=+LEXAF+LEXIF

 D:$D(^TMP("LEXQC",$J,"MOD")) UPC("MOD")

 N LEXQUIET

 Q

UPC(X) ; Update Counters

 N LEXSID,LEXACT,LEXORD,LEXCT S LEXSID=$G(X) Q:'$L(LEXSID)

 S LEXACT="" F  S LEXACT=$O(^TMP("LEXQC",$J,LEXSID,LEXACT)) Q:'$L(LEXACT)  D

 . S LEXCT=0,LEXORD="" F  S LEXORD=$O(^TMP("LEXQC",$J,LEXSID,LEXACT,1,LEXORD)) Q:'$L(LEXORD)  S LEXCT=LEXCT+1

 . S ^TMP("LEXQC",$J,LEXSID,LEXACT,0)=LEXCT

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEXQC4   11127     printed  Mar 13, 2025@21:12:55                                                                                                                                                                                                     Page 2

LEXQC4    ;ISL/KER - Query - Changes - CPT/MOD ;05/23/2017

 +1       ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2

 +2       ;               

 +3       ; Global Variables

 +4       ;    ^DIC(81.3,          ICR   4492

 +5       ;    ^ICPT(              ICR   4489

 +6       ;    ^TMP("LEXQC")       SACC 2.3.2.5.1

 +7       ;               

 +8       ; External References

 +9       ;    None

 +10      ;               

 +11      ; Local Variables NEWed in LEXQC

 +12      ;    LEXADT              After Date

 +13      ;    LEXBDT              Before Date

 +14      ;    LEXCDT              Versioning Date

 +15      ;    LEXQLEN             Length of Display

 +16      ;    LEXQSTR             Length of String

 +17      ;    LEXQTOT             Total Records

 +18      ;               

CPT       ; CPT Procedures Changes

 +1        KILL ^TMP("LEXQC",$JOB,"CPT"),^TMP("LEXQC",$JOB,"CPC")

           NEW LEX1,LEX2,LEX3,LEX4

 +2        NEW LEX5,LEX6,LEXAEF,LEXAST,LEXBEF,LEXBST,LEXCEF,LEXCNT,LEXCST,LEXH

 +3        NEW LEXIDT,LEXIEN,LEXLC,LEXND,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID

 +4        SET LEXQLEN=+($GET(LEXQLEN))

           SET LEXQTOT=+($GET(LEXQTOT))

 +5        SET LEXQSTR=+($GET(LEXQSTR))

           SET LEXCNT=0

           SET LEXLC=0

 +6        SET LEXIDT=$$IMPDATE^LEXU("CPT")

           SET LEXCDT=$GET(LEXCDT)

 +7        if LEXCDT'?7N

               QUIT 

           if LEXCDT'>LEXIDT

               QUIT 

           SET LEXIEN=0

 +8        FOR 

               SET LEXIEN=$ORDER(^ICPT(LEXIEN))

               if +LEXIEN'>0

                   QUIT 

               Begin DoDot:1

 +9                NEW LEX1,LEX2,LEX3,LEX4,LEX5,LEX6,LEX7,LEX7D,LEX8,LEX8D,LEXAEF

 +10               NEW LEXAST,LEXBEF,LEXBST,LEXCEF,LEXCST,LEXH,LEXND,LEXPEF,LEXPST

 +11               NEW LEXQL,LEXSO,LEXSTID,LEXSID

 +12               SET LEXCNT=LEXCNT+1

                   IF LEXCNT'<+($GET(LEXQSTR))

                       SET LEXLC=+($GET(LEXLC))+1

                       Begin DoDot:2

 +13                       if '$DATA(ZTQUEUED)&('$DATA(LEXQUIET))&(LEXLC'>+($GET(LEXQLEN)))

                               WRITE "."

                           SET LEXCNT=0

                       End DoDot:2

 +14               SET LEXSID="CPT"

                   SET LEXSO=$PIECE($GET(^ICPT(LEXIEN,0)),"^",1)

                   if '$LENGTH(LEXSO)

                       QUIT 

 +15               if $EXTRACT(LEXSO,1)?1U

                       SET LEXSID="CPC"

 +16               SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXCDT," "),-1)

 +17               SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))

 +18               SET LEXCEF=$PIECE(LEXND,"^",1)

                   SET LEXCST=$PIECE(LEXND,"^",2)

 +19               SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXBDT," "),-1)

 +20               SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))

 +21               SET LEXBEF=$PIECE(LEXND,"^",1)

                   SET LEXBST=$PIECE(LEXND,"^",2)

 +22               SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXADT," "),-1)

 +23               SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))

 +24               SET LEXAEF=$PIECE(LEXND,"^",1)

                   SET LEXAST=$PIECE(LEXND,"^",2)

 +25               SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXCDT),-1)

 +26               SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",+LEXH," "),-1)

 +27               SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))

 +28               SET LEXPEF=$PIECE(LEXND,"^",1)

                   SET LEXPST=$PIECE(LEXND,"^",2)

 +29               SET LEX1=$DATA(^ICPT(+LEXIEN,61,"B",LEXCDT))>0

 +30               SET LEX2=$DATA(^ICPT(+LEXIEN,62,"B",LEXCDT))>0

 +31               SET LEX3=$ORDER(^ICPT(+LEXIEN,61,"B",LEXCDT),-1)

 +32               SET LEX4=$ORDER(^ICPT(+LEXIEN,62,"B",LEXCDT),-1)

 +33               SET LEX5=$DATA(^ICPT(+LEXIEN,61,"B",LEXCDT))

 +34               SET LEX6=$DATA(^ICPT(+LEXIEN,62,"B",LEXCDT))

 +35      ; Short IEN Dupe

 +36               SET LEX7=$ORDER(^ICPT(+LEXIEN,61,"B",LEXCDT," "),-1)

                   SET LEX7=$$DUPS^LEXQC5(81,LEXIEN,LEX7)

 +37      ; Long IEN Dupe

 +38               SET LEX8=$ORDER(^ICPT(+LEXIEN,62,"B",LEXCDT," "),-1)

                   SET LEX8=$$DUPL^LEXQC5(81,LEXIEN,LEX8)

 +39      ; Activiation/Inactiviation/Re-Activation

 +40      ;   Has a current status and effective date

 +41      ;   Has a previous status and effective date

 +42      ;   Current status not equal to previosu status

 +43      ;   Has a short description

 +44      ;   Has a long description

 +45      ;   Activation - current status >0

 +46      ;   Inactivatin - current status =0

 +47      ;   Reactivation - current status >0 past status =0

 +48               SET LEXQL=0

                   IF $LENGTH(LEXCST)

                       IF $LENGTH(LEXCEF)

                           Begin DoDot:2

 +49                           if $LENGTH(LEXBEF)&($LENGTH(LEXBST))&(LEXBST'=LEXCST)

                                   QUIT 

 +50                           if $LENGTH(LEXAEF)&($LENGTH(LEXAST))&(LEXAST'=LEXCST)

                                   QUIT 

 +51                           if (LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))

                                   QUIT 

                               if '$LENGTH($GET(LEXSO))

                                   QUIT 

 +52                           NEW LEXCT,LEXO,LEXSTID

                               SET LEXSTID=$SELECT(+LEXCST>0:"ACT",1:"INA")

 +53                           IF LEXSTID="ACT"

                                   IF $GET(LEXPEF)?7N

                                       IF +($GET(LEXPST))'>0

                                           Begin DoDot:3

 +54                                           IF +($GET(LEX5))'>0

                                                   IF +($GET(LEX6))'>0

                                                       SET LEXSTID="REA"

                                           End DoDot:3

 +55                           SET LEXQL=1

 +56                           SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 +57                           SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,LEXSTID,0)))

 +58                           if '$DATA(^TMP("LEXQC",$JOB,LEXSID,LEXSTID,1,(LEXSO_" ")))

                                   SET LEXCT=LEXCT+1

 +59                           SET ^TMP("LEXQC",$JOB,LEXSID,LEXSTID,1,(LEXSO_" "))=LEXO

 +60                           SET ^TMP("LEXQC",$JOB,LEXSID,LEXSTID,0)=LEXCT

                           End DoDot:2

                           if LEXQL

                               QUIT 

 +61      ; Revision

 +62      ;   I Previous status (LEXPST) >0 and

 +63      ;     Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or

 +64      ;     long exist (LEX2) with a previosu long (LEX4) and not a duplicate (LEX8)

 +65               SET LEXQL=0

                   IF +LEXPST>0

                       IF ((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0)))

                           Begin DoDot:2

 +66                           NEW LEXCT,LEXO

                               if '$LENGTH($GET(LEXSO))

                                   QUIT 

 +67                           SET LEXQL=1

                               SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 +68                           SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"REV",0)))

 +69                           if '$DATA(^TMP("LEXQC",$JOB,LEXSID,"REV",1,(LEXSO_" ")))

                                   SET LEXCT=LEXCT+1

 +70                           SET ^TMP("LEXQC",$JOB,LEXSID,"REV",1,(LEXSO_" "))=LEXO

 +71                           SET ^TMP("LEXQC",$JOB,LEXSID,"REV",0)=LEXCT

                           End DoDot:2

                           if LEXQL

                               QUIT 

 +72      ; Re-Use

 +73      ;   Current status (LEXCST) exist and active

 +74      ;   Previous Status (LEXPST) exist and is active

 +75      ;     Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or

 +76      ;     long exist (LEX2) with a previosu long (LEX4) and not a duplicate (LEX8)

 +77               SET LEXQL=0

                   IF ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0)))

                       IF ((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0)))

                           Begin DoDot:2

 +78                           NEW LEXCT,LEXO

                               SET LEXQL=1

 +79                           SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT

 +80                           SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"REU",0)))

 +81                           if '$DATA(^TMP("LEXQC",$JOB,LEXSID,"REU",1,(LEXSO_" ")))

                                   SET LEXCT=LEXCT+1

 +82                           SET ^TMP("LEXQC",$JOB,LEXSID,"REU",1,(LEXSO_" "))=LEXO

 +83                           SET ^TMP("LEXQC",$JOB,LEXSID,"REU",0)=LEXCT

                           End DoDot:2

               End DoDot:1

 +84       if $DATA(^TMP("LEXQC",$JOB,"CPT"))

               DO UPC("CPT")

 +85       if $DATA(^TMP("LEXQC",$JOB,"CPC"))

               DO UPC("CPC")

 +86       NEW LEXQUIET

 +87       QUIT 

MOD       ; CPT Modifier Changes

 +1        KILL ^TMP("LEXQC",$JOB,"MOD")

           NEW LEX1,LEX2,LEX3,LEX4,LEX5,LEX6,LEXAEF

 +2        NEW LEXAST,LEXBEF,LEXBST,LEXCEF,LEXCNT,LEXCST,LEXH,LEXIDT,LEXIEN

 +3        NEW LEXLC,LEXND,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID

 +4        SET LEXQLEN=+($GET(LEXQLEN))

           SET LEXQTOT=+($GET(LEXQTOT))

 +5        SET LEXQSTR=+($GET(LEXQSTR))

           SET LEXCNT=0

           SET LEXLC=0

 +6        SET LEXIDT=$$IMPDATE^LEXU("CPT")

           SET LEXCDT=$GET(LEXCDT)

 +7        if LEXCDT'?7N

               QUIT 

           if LEXCDT'>LEXIDT

               QUIT 

           SET LEXIEN=0

 +8        FOR 

               SET LEXIEN=$ORDER(^DIC(81.3,LEXIEN))

               if +LEXIEN'>0

                   QUIT 

               Begin DoDot:1

 +9                if $ORDER(^DIC(81.3,+LEXIEN,60,0))'>0

                       QUIT 

                   NEW LEX1,LEX2,LEX3,LEX4,LEX5

 +10               NEW LEX6,LEX7,LEX8,LEXAEF,LEXAF,LEXAST,LEXACT,LEXBEF,LEXBST,LEXCEF

 +11               NEW LEXCST,LEXH,LEXIF,LEXINA,LEXND,LEXPEF,LEXPST,LEXQL,LEXR,LEXRI

 +12               NEW LEXSO,LEXSTID,LEXSID

                   SET LEXCNT=LEXCNT+1

 +13               IF LEXCNT'<+($GET(LEXQSTR))

                       SET LEXLC=+($GET(LEXLC))+1

                       Begin DoDot:2

 +14                       if '$DATA(ZTQUEUED)&('$DATA(LEXQUIET))&(LEXLC'>+($GET(LEXQLEN)))

                               WRITE "."

                           SET LEXCNT=0

                       End DoDot:2

 +15               SET LEXSID="MOD"

                   SET LEXSO=$PIECE($GET(^DIC(81.3,LEXIEN,0)),"^",1)

 +16               if '$LENGTH(LEXSO)

                       QUIT 

                   SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXCDT," "),-1)

 +17               SET LEXND=$GET(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 +18               SET LEXCEF=$PIECE(LEXND,"^",1)

                   SET LEXCST=$PIECE(LEXND,"^",2)

 +19               SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXBDT," "),-1)

 +20               SET LEXND=$GET(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 +21               SET LEXBEF=$PIECE(LEXND,"^",1)

                   SET LEXBST=$PIECE(LEXND,"^",2)

 +22               SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXADT," "),-1)

 +23               SET LEXND=$GET(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 +24               SET LEXAEF=$PIECE(LEXND,"^",1)

                   SET LEXAST=$PIECE(LEXND,"^",2)

 +25               SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXCDT),-1)

 +26               SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",+LEXH," "),-1)

 +27               SET LEXND=$GET(^DIC(81.3,+LEXIEN,60,+LEXH,0))

 +28               SET LEXPEF=$PIECE(LEXND,"^",1)

                   SET LEXPST=$PIECE(LEXND,"^",2)

 +29               SET LEX1=$DATA(^DIC(81.3,+LEXIEN,61,"B",LEXCDT))>0

 +30               SET LEX2=$DATA(^DIC(81.3,+LEXIEN,62,"B",LEXCDT))>0

 +31               SET LEX3=$ORDER(^DIC(81.3,+LEXIEN,61,"B",LEXCDT),-1)

 +32               SET LEX4=$ORDER(^DIC(81.3,+LEXIEN,62,"B",LEXCDT),-1)

 +33               SET LEX5=$DATA(^DIC(81.3,+LEXIEN,61,"B",LEXCDT))

 +34               SET LEX6=$DATA(^DIC(81.3,+LEXIEN,62,"B",LEXCDT))

 +35      ; Short IEN Dupe

 +36               SET LEX7=$ORDER(^DIC(81.3,+LEXIEN,61,"B",LEXCDT," "),-1)

                   SET LEX7=$$DUPS^LEXQC5(81.3,LEXIEN,LEX7)

 +37      ; Long IEN Dupe

 +38               SET LEX8=$ORDER(^DIC(81.3,+LEXIEN,62,"B",LEXCDT," "),-1)

                   SET LEX8=$$DUPL^LEXQC5(81.3,LEXIEN,LEX8)

 +39      ; Activiation/Inactiviation/Re-Activation

 +40      ;   Has a current status and effective date

 +41      ;   Has a previous status and effective date

 +42      ;   Current status not equal to previosu status

 +43      ;   Has a short description

 +44      ;   Has a long description

 +45      ;   Activation - current status >0

 +46      ;   Inactivatin - current status =0

 +47      ;   Reactivation - current status >0 past status =0

 +48               SET LEXQL=0

                   IF $LENGTH(LEXCST)

                       IF $LENGTH(LEXCEF)

                           Begin DoDot:2

 +49                           if $LENGTH(LEXBEF)&($LENGTH(LEXBST))&(LEXBST'=LEXCST)

                                   QUIT 

 +50                           if $LENGTH(LEXAEF)&($LENGTH(LEXAST))&(LEXAST'=LEXCST)

                                   QUIT 

 +51                           if (LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))

                                   QUIT 

 +52                           NEW LEXSTID

                               if '$LENGTH($GET(LEXSO))

                                   QUIT 

 +53                           NEW LEXCT,LEXO

                               SET LEXSTID=$SELECT(+LEXCST>0:"ACT",1:"INA")

 +54                           IF LEXSTID="ACT"

                                   IF $GET(LEXPEF)?7N

                                       IF +($GET(LEXPST))'>0

                                           Begin DoDot:3

 +55                                           IF +($GET(LEX5))'>0