LEXQC4 ;ISL/KER - Query - Changes - CPT/MOD ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; 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,LEXAEF,LEXAST,LEXBEF,LEXBST,LEXCEF
. N LEXCST,LEXH,LEXND,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID,LEXSID
. S LEXCNT=LEXCNT+1 I LEXCNT'<+($G(LEXQSTR)) S LEXLC=+($G(LEXLC))+1 D
. . W: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))
. 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)))+1
. . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,1,(LEXSO_" "))=LEXO
. . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,0)=LEXCT
. S LEXQL=0 I +LEXPST>0,((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))) 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)))+1
. . S ^TMP("LEXQC",$J,LEXSID,"REV",1,(LEXSO_" "))=LEXO
. . S ^TMP("LEXQC",$J,LEXSID,"REV",0)=LEXCT
. S LEXQL=0 I ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0))),((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))) D
. . N LEXCT,LEXO S LEXQL=1
. . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
. . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"REU",0)))+1
. . S ^TMP("LEXQC",$J,LEXSID,"REU",1,(LEXSO_" "))=LEXO
. . S ^TMP("LEXQC",$J,LEXSID,"REU",0)=LEXCT
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,LEXAEF,LEXAF,LEXAST,LEXACT,LEXBEF,LEXBST,LEXCEF,LEXCST
. N LEXH,LEXIF,LEXINA,LEXND,LEXPEF,LEXPST,LEXQL,LEXR,LEXRI,LEXSO
. N LEXSTID,LEXSID S LEXCNT=LEXCNT+1
. I LEXCNT'<+($G(LEXQSTR)) S LEXLC=+($G(LEXLC))+1 D
. . W: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))
. 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)))+1
. . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,1,(LEXSO_" "))=LEXO
. . S ^TMP("LEXQC",$J,LEXSID,LEXSTID,0)=LEXCT
. I 'LEXQL I +LEXPST>0,((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))) 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)))+1
. . S ^TMP("LEXQC",$J,LEXSID,"REV",1,(LEXSO_" "))=LEXO
. . S ^TMP("LEXQC",$J,LEXSID,"REV",0)=LEXCT
. I 'LEXQL S LEXQL=0 I ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0))),((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))) D
. . N LEXCT,LEXO S LEXQL=1
. . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
. . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSID,"REU",0)))+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)))+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)))+1
. . . S ^TMP("LEXQC",$J,LEXSID,"INA",1,(LEXSO_" "))=LEXO
. . . S ^TMP("LEXQC",$J,LEXSID,"INA",0)=LEXCT,LEXIF=1
. . S LEXR=+LEXAF+LEXIF
Q
LEXQC4 ;ISL/KER - Query - Changes - CPT/MOD ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+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,LEXAEF,LEXAST,LEXBEF,LEXBST,LEXCEF
+10 NEW LEXCST,LEXH,LEXND,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID,LEXSID
+11 SET LEXCNT=LEXCNT+1
IF LEXCNT'<+($GET(LEXQSTR))
SET LEXLC=+($GET(LEXLC))+1
Begin DoDot:2
+12 IF LEXLC'>+($GET(LEXQLEN))
WRITE "."
SET LEXCNT=0
End DoDot:2
+13 SET LEXSID="CPT"
SET LEXSO=$PIECE($GET(^ICPT(LEXIEN,0)),"^",1)
IF '$LENGTH(LEXSO)
QUIT
+14 IF $EXTRACT(LEXSO,1)?1U
SET LEXSID="CPC"
+15 SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXCDT," "),-1)
+16 SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))
+17 SET LEXCEF=$PIECE(LEXND,"^",1)
SET LEXCST=$PIECE(LEXND,"^",2)
+18 SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXBDT," "),-1)
+19 SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))
+20 SET LEXBEF=$PIECE(LEXND,"^",1)
SET LEXBST=$PIECE(LEXND,"^",2)
+21 SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXADT," "),-1)
+22 SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))
+23 SET LEXAEF=$PIECE(LEXND,"^",1)
SET LEXAST=$PIECE(LEXND,"^",2)
+24 SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",LEXCDT),-1)
+25 SET LEXH=$ORDER(^ICPT(+LEXIEN,60,"B",+LEXH," "),-1)
+26 SET LEXND=$GET(^ICPT(+LEXIEN,60,+LEXH,0))
+27 SET LEXPEF=$PIECE(LEXND,"^",1)
SET LEXPST=$PIECE(LEXND,"^",2)
+28 SET LEX1=$DATA(^ICPT(+LEXIEN,61,"B",LEXCDT))>0
+29 SET LEX2=$DATA(^ICPT(+LEXIEN,62,"B",LEXCDT))>0
+30 SET LEX3=$ORDER(^ICPT(+LEXIEN,61,"B",LEXCDT),-1)
+31 SET LEX4=$ORDER(^ICPT(+LEXIEN,62,"B",LEXCDT),-1)
+32 SET LEX5=$DATA(^ICPT(+LEXIEN,61,"B",LEXCDT))
+33 SET LEX6=$DATA(^ICPT(+LEXIEN,62,"B",LEXCDT))
+34 SET LEXQL=0
IF $LENGTH(LEXCST)
IF $LENGTH(LEXCEF)
Begin DoDot:2
+35 IF $LENGTH(LEXBEF)&($LENGTH(LEXBST))&(LEXBST'=LEXCST)
QUIT
+36 IF $LENGTH(LEXAEF)&($LENGTH(LEXAST))&(LEXAST'=LEXCST)
QUIT
+37 IF (LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))
QUIT
IF '$LENGTH($GET(LEXSO))
QUIT
+38 NEW LEXCT,LEXO,LEXSTID
SET LEXSTID=$SELECT(+LEXCST>0:"ACT",1:"INA")
+39 IF LEXSTID="ACT"
IF $GET(LEXPEF)?7N
IF +($GET(LEXPST))'>0
Begin DoDot:3
+40 IF +($GET(LEX5))'>0
IF +($GET(LEX6))'>0
SET LEXSTID="REA"
End DoDot:3
+41 SET LEXQL=1
+42 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+43 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,LEXSTID,0)))+1
+44 SET ^TMP("LEXQC",$JOB,LEXSID,LEXSTID,1,(LEXSO_" "))=LEXO
+45 SET ^TMP("LEXQC",$JOB,LEXSID,LEXSTID,0)=LEXCT
End DoDot:2
IF LEXQL
QUIT
+46 SET LEXQL=0
IF +LEXPST>0
IF ((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N)))
Begin DoDot:2
+47 NEW LEXCT,LEXO
IF '$LENGTH($GET(LEXSO))
QUIT
+48 SET LEXQL=1
SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+49 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"REV",0)))+1
+50 SET ^TMP("LEXQC",$JOB,LEXSID,"REV",1,(LEXSO_" "))=LEXO
+51 SET ^TMP("LEXQC",$JOB,LEXSID,"REV",0)=LEXCT
End DoDot:2
IF LEXQL
QUIT
+52 SET LEXQL=0
IF ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0)))
IF ((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N)))
Begin DoDot:2
+53 NEW LEXCT,LEXO
SET LEXQL=1
+54 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+55 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"REU",0)))+1
+56 SET ^TMP("LEXQC",$JOB,LEXSID,"REU",1,(LEXSO_" "))=LEXO
+57 SET ^TMP("LEXQC",$JOB,LEXSID,"REU",0)=LEXCT
End DoDot:2
End DoDot:1
+58 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,LEXAEF,LEXAF,LEXAST,LEXACT,LEXBEF,LEXBST,LEXCEF,LEXCST
+11 NEW LEXH,LEXIF,LEXINA,LEXND,LEXPEF,LEXPST,LEXQL,LEXR,LEXRI,LEXSO
+12 NEW LEXSTID,LEXSID
SET LEXCNT=LEXCNT+1
+13 IF LEXCNT'<+($GET(LEXQSTR))
SET LEXLC=+($GET(LEXLC))+1
Begin DoDot:2
+14 IF 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 SET LEXQL=0
IF $LENGTH(LEXCST)
IF $LENGTH(LEXCEF)
Begin DoDot:2
+36 IF $LENGTH(LEXBEF)&($LENGTH(LEXBST))&(LEXBST'=LEXCST)
QUIT
+37 IF $LENGTH(LEXAEF)&($LENGTH(LEXAST))&(LEXAST'=LEXCST)
QUIT
+38 IF (LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))
QUIT
+39 NEW LEXSTID
IF '$LENGTH($GET(LEXSO))
QUIT
+40 NEW LEXCT,LEXO
SET LEXSTID=$SELECT(+LEXCST>0:"ACT",1:"INA")
+41 IF LEXSTID="ACT"
IF $GET(LEXPEF)?7N
IF +($GET(LEXPST))'>0
Begin DoDot:3
+42 IF +($GET(LEX5))'>0
IF +($GET(LEX6))'>0
SET LEXSTID="REA"
End DoDot:3
+43 SET LEXQL=1
SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+44 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,LEXSTID,0)))+1
+45 SET ^TMP("LEXQC",$JOB,LEXSID,LEXSTID,1,(LEXSO_" "))=LEXO
+46 SET ^TMP("LEXQC",$JOB,LEXSID,LEXSTID,0)=LEXCT
End DoDot:2
+47 IF 'LEXQL
IF +LEXPST>0
IF ((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N)))
Begin DoDot:2
+48 NEW LEXCT,LEXO
IF '$LENGTH($GET(LEXSO))
QUIT
SET LEXQL=1
+49 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+50 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"REV",0)))+1
+51 SET ^TMP("LEXQC",$JOB,LEXSID,"REV",1,(LEXSO_" "))=LEXO
+52 SET ^TMP("LEXQC",$JOB,LEXSID,"REV",0)=LEXCT
End DoDot:2
IF LEXQL
QUIT
+53 IF 'LEXQL
SET LEXQL=0
IF ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0)))
IF ((LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N)))
Begin DoDot:2
+54 NEW LEXCT,LEXO
SET LEXQL=1
+55 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+56 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"REU",0)))+1
+57 SET ^TMP("LEXQC",$JOB,LEXSID,"REU",1,(LEXSO_" "))=LEXO
+58 SET ^TMP("LEXQC",$JOB,LEXSID,"REU",0)=LEXCT
End DoDot:2
+59 SET (LEXAF,LEXIF,LEXRI)=0
SET LEXSID="RAN"
SET LEXR=0
+60 FOR
SET LEXRI=$ORDER(^DIC(81.3,+LEXIEN,10,LEXRI))
IF +LEXRI'>0
QUIT
Begin DoDot:2
+61 SET LEXND=$GET(^DIC(81.3,+LEXIEN,10,LEXRI,0))
+62 SET LEXACT=$PIECE(LEXND,"^",3)
SET LEXINA=$PIECE(LEXND,"^",4)
+63 IF LEXACT=LEXCDT
IF '$LENGTH(LEXINA)
Begin DoDot:3
+64 NEW LEXCT,LEXO
IF $DATA(^TMP("LEXQC",$JOB,LEXSID,"ACT",1,(LEXSO_" ")))
QUIT
+65 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+66 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"ACT",0)))+1
+67 SET ^TMP("LEXQC",$JOB,LEXSID,"ACT",1,(LEXSO_" "))=LEXO
+68 SET ^TMP("LEXQC",$JOB,LEXSID,"ACT",0)=LEXCT
SET LEXAF=1
End DoDot:3
+69 IF LEXINA=LEXCDT
IF $LENGTH(LEXACT)
IF LEXINA>LEXACT
IF (LEXINA-LEXACT)>1
Begin DoDot:3
+70 NEW LEXCT,LEXO
IF $DATA(^TMP("LEXQC",$JOB,LEXSID,"INA",1,(LEXSO_" ")))
QUIT
+71 SET LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
+72 SET LEXCT=+($GET(^TMP("LEXQC",$JOB,LEXSID,"INA",0)))+1
+73 SET ^TMP("LEXQC",$JOB,LEXSID,"INA",1,(LEXSO_" "))=LEXO
+74 SET ^TMP("LEXQC",$JOB,LEXSID,"INA",0)=LEXCT
SET LEXIF=1
End DoDot:3
+75 SET LEXR=+LEXAF+LEXIF
End DoDot:2
IF LEXR>1
QUIT
End DoDot:1
+76 QUIT
