- 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
