LEXXFQ ;ISL/KER - Set Frequencies in 757.001 ;05/23/2017
;;2.0;LEXICON UTILITY;**4,25,73,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.001) N/A
;
; External References
; $$FMDIFF^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; HOME^%ZIS ICR 10086
; NOW^%DTC ICR 10000
; ^%ZTLOAD ICR 10063
;
Q
EN ; Update term frequencies when not found (at site)
N Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
S ZTRTN="UP^LEXXFQ",ZTDESC="Update Term Frequency in file 757.001"
S ZTIO="",ZTDTH=$H
D ^%ZTLOAD,HOME^%ZIS
Q
EN2 ; Reset term frequencies to export values (at CIOFO)
N Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
S ZTRTN="RE^LEXXFQ",ZTDESC="Reset Term Frequencies in file 757.001"
S ZTIO="",ZTDTH=$H
D ^%ZTLOAD,HOME^%ZIS
Q
CHK ; Check frequencies (at site or IRMFO)
N LEXI,LEXC S (LEXI,LEXC)=0
F S LEXI=$O(^LEX(757,LEXI)) Q:+LEXI=0 S:'$D(^LEX(757.001,LEXI)) LEXC=LEXC+1
I '$D(ZTQUEUED) D
.W:LEXC>0 !!,LEXC," Concepts do not have frequencies set",!!
.W:LEXC'>0 !!,"All concepts have frequencies set",!!
Q
UP ; Update frequencies
S:$D(ZTQUEUED) ZTREQ="@"
N LEX1,LEX2,LEXU,LEXUC,LEXDC,LEXMA,LEXT,LEXL,LEXH
S (LEXDC,LEXU,LEXUC,LEXT,LEXL,LEXMA)=0,LEXH="."
S LEX1=$$HACK
I '$D(ZTQUEUED) D
.W !!,"Initializing Global",!," Start: ",$P(LEX1,"^",2),!," "
F S LEXMA=$O(^LEX(757,LEXMA)) Q:+LEXMA=0 D
. S:'$D(^LEX(757.001,LEXMA,0)) LEXH="+" S LEXT=LEXT+1,LEXL=LEXMA
. W:'$D(ZTQUEUED)&(LEXT#1000=0) LEXH S:LEXT#1000=0 LEXH=".",LEXDC=LEXDC+1
. W:'$D(ZTQUEUED)&(LEXDC#76=0)&(LEXDC>0)&(LEXT#1000=0) !," "
. I '$D(^LEX(757.001,LEXMA,0)) D SET S LEXUC=LEXUC+1
W:'$D(ZTQUEUED) LEXH
S:LEXT>0 $P(^LEX(757.001,0),"^",4)=LEXT
S:LEXL>0 $P(^LEX(757.001,0),"^",3)=LEXL S:$D(ZTQUEUED) ZTREQ="@"
S LEX2=$$HACK
I '$D(ZTQUEUED) D
.W !," Finished: ",$P(LEX2,"^",2)
.W !," Time: ",$$TIME($P(LEX1,"^",1),$P(LEX2,"^",1)),!
Q
RE ; Reset frequencies
S:$D(ZTQUEUED) ZTREQ="@"
N LEXMA,LEXT,LEXL S (LEXT,LEXL,LEXMA)=0
F S LEXMA=$O(^LEX(757,LEXMA)) Q:+LEXMA=0 S LEXT=LEXT+1,LEXL=LEXMA D SET
S:LEXT>0 $P(^LEX(757.001,0),"^",4)=LEXT
S:LEXL>0 $P(^LEX(757.001,0),"^",3)=LEXL S:$D(ZTQUEUED) ZTREQ="@" Q
SET ; Set frequency
N DIK,DIC,DA,LEXFQ
S LEXMA=+($G(LEXMA))
Q:'$D(^LEX(757,LEXMA,0))
S DIC="^LEX(757.001,",DA=LEXMA,LEXFQ=+($$FQ(LEXMA))
D:$D(^LEX(757.001,DA)) KILL^LEXNDX2
S ^LEX(757.001,LEXMA,0)=LEXMA_"^"_LEXFQ_"^"_LEXFQ
D SET^LEXNDX2
Q
FQ(LEXX) ; Frequency
;
; LEXSAB Source Abbreviation
; LEXSMC Semantic Class
; LEXNUR Nursing Class
; LEXBEH Behavior/Mental Health Class
; LEXPRO Procedural Class
; LEXDIA Diagnostic Class
; LEXSA IEN Source Code (ICD, CPT, DSM, etc)
; LEXMC IEN Major Concept
; LEXSO Code
;
N LEXMC S LEXMC=+($G(LEXX)) Q:'$D(^LEX(757,LEXMC,0)) 0 Q:LEXMC<3 0
N LEXSA,LEXSAB,LEXSMC,LEXNUR,LEXBEH,LEXPRO,LEXDIA,LEXSN,LEXSO,LEXSR
S (LEXSA,LEXNUR,LEXBEH,LEXPRO,LEXDIA)=0
F S LEXSA=$O(^LEX(757.02,"AMC",LEXMC,LEXSA)) Q:+LEXSA=0 D
. S LEXSN=$G(^LEX(757.02,LEXSA,0))
. S LEXSO=$P(LEXSN,"^",2),LEXSR=$P(LEXSN,"^",3)
. Q:+$$STATCHK^LEXSRC2(LEXSO,,,LEXSR)=0
. S LEXSAB=+($P($G(^LEX(757.02,LEXSA,0)),"^",3)) Q:LEXSAB=0
. Q:LEXSAB>15 S:LEXSAB=1 LEXDIA=1
. S:LEXSAB>1&(LEXSAB<5) LEXPRO=1
. S:LEXSAB>4&(LEXSAB<7) LEXBEH=1
. S:LEXSAB>10&(LEXSAB<16) LEXNUR=1
S LEXSMC=$$SM(LEXMC),LEXX=0 I LEXDIA=1 S LEXX=4 Q LEXX
I LEXBEH=1!(LEXSMC=1) S LEXX=3 Q LEXX
I LEXPRO=1 S LEXX=2 Q LEXX
I LEXNUR=1 S LEXX=1 Q LEXX
Q LEXX
SM(LEXX) ; Semantic Map (757.1)
N LEXMC,LEXCL,LEXSA
S LEXSA=0,LEXMC=+($G(LEXX)),LEXX=0
Q:'$D(^LEX(757,LEXMC,0)) 0
F S LEXSA=$O(^LEX(757.1,"B",LEXMC,LEXSA)) Q:+LEXSA=0 D
.S LEXCL=+($P($G(^LEX(757.1,LEXSA,0)),"^",2))
.I LEXCL=3!(LEXCL=6) S LEXX=1
Q LEXX
HACK(LEXX) ; Time Hack
N X,%,%H,%I
N HACK D NOW^%DTC S HACK=$$FMTE^XLFDT(%,1),HACK=$TR(HACK,"@"," ")
S LEXX=%_"^"_HACK Q LEXX
TIME(LEXBEG,LEXEND) ; Elapsed time from begining to end
S LEXBEG=+($G(LEXBEG)) Q:LEXBEG=0 "" S LEXEND=+($G(LEXEND)) Q:LEXBEG=0 ""
S LEXBEG=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3) S:$L($P(LEXBEG,":",1))=1 $P(LEXBEG,":",1)="0"_$P(LEXBEG,":",1) S LEXBEG=$TR(LEXBEG," ","0")
Q LEXBEG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXFQ 4298 printed Dec 13, 2024@02:10:10 Page 2
LEXXFQ ;ISL/KER - Set Frequencies in 757.001 ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**4,25,73,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.001) N/A
+5 ;
+6 ; External References
+7 ; $$FMDIFF^XLFDT ICR 10103
+8 ; $$FMTE^XLFDT ICR 10103
+9 ; HOME^%ZIS ICR 10086
+10 ; NOW^%DTC ICR 10000
+11 ; ^%ZTLOAD ICR 10063
+12 ;
+13 QUIT
EN ; Update term frequencies when not found (at site)
+1 NEW Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
+2 SET ZTRTN="UP^LEXXFQ"
SET ZTDESC="Update Term Frequency in file 757.001"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
+4 DO ^%ZTLOAD
DO HOME^%ZIS
+5 QUIT
EN2 ; Reset term frequencies to export values (at CIOFO)
+1 NEW Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
+2 SET ZTRTN="RE^LEXXFQ"
SET ZTDESC="Reset Term Frequencies in file 757.001"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
+4 DO ^%ZTLOAD
DO HOME^%ZIS
+5 QUIT
CHK ; Check frequencies (at site or IRMFO)
+1 NEW LEXI,LEXC
SET (LEXI,LEXC)=0
+2 FOR
SET LEXI=$ORDER(^LEX(757,LEXI))
if +LEXI=0
QUIT
if '$DATA(^LEX(757.001,LEXI))
SET LEXC=LEXC+1
+3 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+4 if LEXC>0
WRITE !!,LEXC," Concepts do not have frequencies set",!!
+5 if LEXC'>0
WRITE !!,"All concepts have frequencies set",!!
End DoDot:1
+6 QUIT
UP ; Update frequencies
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW LEX1,LEX2,LEXU,LEXUC,LEXDC,LEXMA,LEXT,LEXL,LEXH
+3 SET (LEXDC,LEXU,LEXUC,LEXT,LEXL,LEXMA)=0
SET LEXH="."
+4 SET LEX1=$$HACK
+5 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+6 WRITE !!,"Initializing Global",!," Start: ",$PIECE(LEX1,"^",2),!," "
End DoDot:1
+7 FOR
SET LEXMA=$ORDER(^LEX(757,LEXMA))
if +LEXMA=0
QUIT
Begin DoDot:1
+8 if '$DATA(^LEX(757.001,LEXMA,0))
SET LEXH="+"
SET LEXT=LEXT+1
SET LEXL=LEXMA
+9 if '$DATA(ZTQUEUED)&(LEXT#1000=0)
WRITE LEXH
if LEXT#1000=0
SET LEXH="."
SET LEXDC=LEXDC+1
+10 if '$DATA(ZTQUEUED)&(LEXDC#76=0)&(LEXDC>0)&(LEXT#1000=0)
WRITE !," "
+11 IF '$DATA(^LEX(757.001,LEXMA,0))
DO SET
SET LEXUC=LEXUC+1
End DoDot:1
+12 if '$DATA(ZTQUEUED)
WRITE LEXH
+13 if LEXT>0
SET $PIECE(^LEX(757.001,0),"^",4)=LEXT
+14 if LEXL>0
SET $PIECE(^LEX(757.001,0),"^",3)=LEXL
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+15 SET LEX2=$$HACK
+16 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+17 WRITE !," Finished: ",$PIECE(LEX2,"^",2)
+18 WRITE !," Time: ",$$TIME($PIECE(LEX1,"^",1),$PIECE(LEX2,"^",1)),!
End DoDot:1
+19 QUIT
RE ; Reset frequencies
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW LEXMA,LEXT,LEXL
SET (LEXT,LEXL,LEXMA)=0
+3 FOR
SET LEXMA=$ORDER(^LEX(757,LEXMA))
if +LEXMA=0
QUIT
SET LEXT=LEXT+1
SET LEXL=LEXMA
DO SET
+4 if LEXT>0
SET $PIECE(^LEX(757.001,0),"^",4)=LEXT
+5 if LEXL>0
SET $PIECE(^LEX(757.001,0),"^",3)=LEXL
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
SET ; Set frequency
+1 NEW DIK,DIC,DA,LEXFQ
+2 SET LEXMA=+($GET(LEXMA))
+3 if '$DATA(^LEX(757,LEXMA,0))
QUIT
+4 SET DIC="^LEX(757.001,"
SET DA=LEXMA
SET LEXFQ=+($$FQ(LEXMA))
+5 if $DATA(^LEX(757.001,DA))
DO KILL^LEXNDX2
+6 SET ^LEX(757.001,LEXMA,0)=LEXMA_"^"_LEXFQ_"^"_LEXFQ
+7 DO SET^LEXNDX2
+8 QUIT
FQ(LEXX) ; Frequency
+1 ;
+2 ; LEXSAB Source Abbreviation
+3 ; LEXSMC Semantic Class
+4 ; LEXNUR Nursing Class
+5 ; LEXBEH Behavior/Mental Health Class
+6 ; LEXPRO Procedural Class
+7 ; LEXDIA Diagnostic Class
+8 ; LEXSA IEN Source Code (ICD, CPT, DSM, etc)
+9 ; LEXMC IEN Major Concept
+10 ; LEXSO Code
+11 ;
+12 NEW LEXMC
SET LEXMC=+($GET(LEXX))
if '$DATA(^LEX(757,LEXMC,0))
QUIT 0
if LEXMC<3
QUIT 0
+13 NEW LEXSA,LEXSAB,LEXSMC,LEXNUR,LEXBEH,LEXPRO,LEXDIA,LEXSN,LEXSO,LEXSR
+14 SET (LEXSA,LEXNUR,LEXBEH,LEXPRO,LEXDIA)=0
+15 FOR
SET LEXSA=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSA))
if +LEXSA=0
QUIT
Begin DoDot:1
+16 SET LEXSN=$GET(^LEX(757.02,LEXSA,0))
+17 SET LEXSO=$PIECE(LEXSN,"^",2)
SET LEXSR=$PIECE(LEXSN,"^",3)
+18 if +$$STATCHK^LEXSRC2(LEXSO,,,LEXSR)=0
QUIT
+19 SET LEXSAB=+($PIECE($GET(^LEX(757.02,LEXSA,0)),"^",3))
if LEXSAB=0
QUIT
+20 if LEXSAB>15
QUIT
if LEXSAB=1
SET LEXDIA=1
+21 if LEXSAB>1&(LEXSAB<5)
SET LEXPRO=1
+22 if LEXSAB>4&(LEXSAB<7)
SET LEXBEH=1
+23 if LEXSAB>10&(LEXSAB<16)
SET LEXNUR=1
End DoDot:1
+24 SET LEXSMC=$$SM(LEXMC)
SET LEXX=0
IF LEXDIA=1
SET LEXX=4
QUIT LEXX
+25 IF LEXBEH=1!(LEXSMC=1)
SET LEXX=3
QUIT LEXX
+26 IF LEXPRO=1
SET LEXX=2
QUIT LEXX
+27 IF LEXNUR=1
SET LEXX=1
QUIT LEXX
+28 QUIT LEXX
SM(LEXX) ; Semantic Map (757.1)
+1 NEW LEXMC,LEXCL,LEXSA
+2 SET LEXSA=0
SET LEXMC=+($GET(LEXX))
SET LEXX=0
+3 if '$DATA(^LEX(757,LEXMC,0))
QUIT 0
+4 FOR
SET LEXSA=$ORDER(^LEX(757.1,"B",LEXMC,LEXSA))
if +LEXSA=0
QUIT
Begin DoDot:1
+5 SET LEXCL=+($PIECE($GET(^LEX(757.1,LEXSA,0)),"^",2))
+6 IF LEXCL=3!(LEXCL=6)
SET LEXX=1
End DoDot:1
+7 QUIT LEXX
HACK(LEXX) ; Time Hack
+1 NEW X,%,%H,%I
+2 NEW HACK
DO NOW^%DTC
SET HACK=$$FMTE^XLFDT(%,1)
SET HACK=$TRANSLATE(HACK,"@"," ")
+3 SET LEXX=%_"^"_HACK
QUIT LEXX
TIME(LEXBEG,LEXEND) ; Elapsed time from begining to end
+1 SET LEXBEG=+($GET(LEXBEG))
if LEXBEG=0
QUIT ""
SET LEXEND=+($GET(LEXEND))
if LEXBEG=0
QUIT ""
+2 SET LEXBEG=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
if $LENGTH($PIECE(LEXBEG,"
SET $PIECE(LEXBEG,":",1)="0"_$PIECE(LEXBEG,":",1)
SET LEXBEG=$TRANSLATE(LEXBEG," ","0")
+3 QUIT LEXBEG
