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 ---[H[J[2J[HLEXQC4 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
IF +($GET(LEX6))'>0
SET LEXSTID="REA"
End DoDot:3
+56 SET LEXQL=1
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
+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 IF 'LEXQL
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
SET LEXQL=1
+67 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-Used
+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 IF 'LEXQL
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
+84 SET (LEXAF,LEXIF,LEXRI)=0
SET LEXSID="RAN"
SET LEXR=0
+85 FOR
SET LEXRI=$ORDER(^DIC(81.3,+LEXIEN,10,LEXRI))
if +LEXRI'>0
QUIT
Begin DoDot:2
+86 SET LEXND=$GET(^DIC(81.3,+LEXIEN,10,LEXRI,0))
+87 SET LEXACT=$PIECE(LEXND,"^",3)
SET LEXINA=$PIECE(LEXND,"^",4)
+88 IF LEXACT=LEXCDT
IF '$LENGTH(LEXINA)
Begin DoDot:3
+89 NEW LEXCT,LEXO
if $DATA(^TMP("LEXQC",$JOB,LEXSID,"ACT",1,(LEXSO_" ")))
QUIT
+90 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+91 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"ACT",0)))
+92 if '$DATA(^TMP("LEXQC",$JOB,LEXSID,"ACT",1,(LEXSO_" ")))
SET LEXCT=LEXCT+1
+93 SET ^TMP("LEXQC",$JOB,LEXSID,"ACT",1,(LEXSO_" "))=LEXO
+94 SET ^TMP("LEXQC",$JOB,LEXSID,"ACT",0)=LEXCT
SET LEXAF=1
End DoDot:3
+95 IF LEXINA=LEXCDT
IF $LENGTH(LEXACT)
IF LEXINA>LEXACT
IF (LEXINA-LEXACT)>1
Begin DoDot:3
+96 NEW LEXCT,LEXO
if $DATA(^TMP("LEXQC",$JOB,LEXSID,"INA",1,(LEXSO_" ")))
QUIT
+97 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+98 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"INA",0)))
+99 if '$DATA(^TMP("LEXQC",$JOB,LEXSID,"INA",1,(LEXSO_" ")))
SET LEXCT=LEXCT+1
+100 SET ^TMP("LEXQC",$JOB,LEXSID,"INA",1,(LEXSO_" "))=LEXO
+101 SET ^TMP("LEXQC",$JOB,LEXSID,"INA",0)=LEXCT
SET LEXIF=1
End DoDot:3
+102 SET LEXR=+LEXAF+LEXIF
End DoDot:2
if LEXR>1
QUIT
End DoDot:1
+103 if $DATA(^TMP("LEXQC",$JOB,"MOD"))
DO UPC("MOD")
+104 NEW LEXQUIET
+105 QUIT
UPC(X) ; Update Counters
+1 NEW LEXSID,LEXACT,LEXORD,LEXCT
SET LEXSID=$GET(X)
if '$LENGTH(LEXSID)
QUIT
+2 SET LEXACT=""
FOR
SET LEXACT=$ORDER(^TMP("LEXQC",$JOB,LEXSID,LEXACT))
if '$LENGTH(LEXACT)
QUIT
Begin DoDot:1
+3 SET LEXCT=0
SET LEXORD=""
FOR
SET LEXORD=$ORDER(^TMP("LEXQC",$JOB,LEXSID,LEXACT,1,LEXORD))
if '$LENGTH(LEXORD)
QUIT
SET LEXCT=LEXCT+1
+4 SET ^TMP("LEXQC",$JOB,LEXSID,LEXACT,0)=LEXCT
End DoDot:1
+5 QUIT
