LEXRXB ;ISL/KER - Re-Index 757.001 B/AF ;04/21/2014
;;2.0;LEXICON UTILITY;**81,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX( SACC 1.3
; ^LEX(757.001) SACC 1.3
; ^LEX(757.02) SACC 1.3
; ^LEX(757.1) SACC 1.3
; ^TMP("LEXRX") SACC 2.3.2.5.1
;
; External References
; $$FMDIFF^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; FILE^DID ICR 2052
; IX1^DIK ICR 10013
; IX2^DIK ICR 10013
;
; Local Variables NEWed or KILLed Elsewhere
; LEXFIX Fix Flag NEWed/KILLed by LEXRXXT
; LEXNAM Task name NEWed/KILLed by LEXRXXT
; LEXSET Re-Index flag NEWed/KILLed by LEXRXXT
; LEXQ Quiet flat NEWed/KILLed by LEXRXXT2
; LEXTEST Test variable NEWed/KILLed by Developer
; ZTQUEUED Task flag NEWed/KILLed by Taskman
;
Q
EN ; Main Entry Point
R757001 ; Repair file 757.001
D RB,RAF,SET Q
RB ; Index ^LEX(757.001,"B",MC,IEN)
W:'$D(ZTQUEUED) ! N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR,X
S LEXFI="757.001"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.001 ""B""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXSTR="",LEXIDX="B",LEXIDXT="^LEX(757.001,""B"",MC,IEN)"
F S LEXSTR=$O(^LEX(LEXFI,LEXIDX,LEXSTR)) Q:'$L(LEXSTR) D
. N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)) Q:+LEXIEN'>0 D
. . S LEXNDS=LEXNDS+1 I '$D(^LEX(LEXFI,LEXIEN,0)) D Q
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
. . Q:+LEXSTR>0&(LEXSTR=LEXIEN) N LEXOK,LEXMC S LEXMC=$P($G(^LEX(LEXFI,LEXIEN,0)),"^",1)
. . S LEXOK=0 S:LEXMC=LEXSTR LEXOK=1 I 'LEXOK D
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN) S:$L(LEXMC) ^LEX(LEXFI,LEXIDX,LEXMC,LEXIEN)=""
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N DA,DIK,X S DA=LEXIEN,X=$P($G(^LEX(LEXFI,DA,0)),"^",1) Q:'$L(X)
. I '$D(^LEX(LEXFI,"B",X,DA)) D
. . S LEXERR=LEXERR+1 I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Missing",?58," ",DA
. S:$L(X) ^LEX(LEXFI,"B",X,DA)=""
S LEXERR=$S(+LEXERR>0:LEXERR,1:"") I '$D(ZTQUEUED) W !,$J(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
S:$E(LEXELP,1)=" "&($E(LEXELP,3)=":") LEXELP=$TR(LEXELP," ","0")
D REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
Q
RAF ; Index ^LEX(757.001,"AF",FREQ,IEN)
W:'$D(ZTQUEUED) ! N DA,DIK,LEXAF,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXFQ,LEXIEN,LEXNDS,LEXOF,LEXOK,LEXSTR,X
S LEXFI="757.001"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.001 ""AF""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXSTR="",LEXIDX="AF",LEXIDXT="^LEX(757.001,""AF"",FREQ,IEN)"
F S LEXSTR=$O(^LEX(LEXFI,LEXIDX,LEXSTR)) Q:'$L(LEXSTR) D
. N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)) Q:+LEXIEN'>0 D
. . S LEXNDS=LEXNDS+1
. . I '$D(^LEX(LEXFI,LEXIEN,0)) D Q
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
. . N LEXOK,LEXFQ,LEXOF,LEXAF,LEXF S LEXFQ=+($P($G(^LEX(LEXFI,LEXIEN,0)),"^",3))
. . S LEXOF=+($P($G(^LEX(LEXFI,LEXIEN,0)),"^",2)) I LEXOF>LEXFQ D
. . . S LEXF=$$FREQ^LEXRXXM(LEXIEN) S:LEXF'>LEXFQ $P(^LEX(LEXFI,LEXIEN,0),"^",2)=LEXF,LEXOF=LEXF
. . . S:LEXF>LEXFQ $P(^LEX(LEXFI,LEXIEN,0),"^",2)=LEXF,$P(^LEX(LEXFI,LEXIEN,0),"^",3)=LEXF,(LEXOF,LEXFQ)=LEXF
. . S LEXAF=LEXFQ-LEXOF S:LEXAF>0 LEXAF=LEXAF*(-1)
. . S LEXOK=0 S:LEXAF=LEXSTR LEXOK=1 I 'LEXOK D
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN) S:$L(LEXAF) ^LEX(LEXFI,LEXIDX,LEXAF,LEXIEN)=""
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N DA,DIK,X,LEXF S DA=LEXIEN,X=+($P($G(^LEX(LEXFI,DA,0)),"^",3)),LEXF=-(X-(+($P(^LEX(LEXFI,DA,0),"^",2))))
. I '$D(^LEX(LEXFI,"AF",LEXF,DA)) D
. . S LEXERR=LEXERR+1 I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Missing",?58," ",DA
. S:$L(LEXF) ^LEX(LEXFI,"AF",LEXF,DA)=""
S LEXERR=$S(+LEXERR>0:LEXERR,1:"") I '$D(ZTQUEUED) W !,$J(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
S:$E(LEXELP,1)=" "&($E(LEXELP,3)=":") LEXELP=$TR(LEXELP," ","0")
D REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
Q
;
; Miscellaneous
SET ; Re-Index Concept Usage file 757.001 (Set logic only)
Q:'$D(LEXSET) N LEXTC,LEXPRE,LEXBEG,LEXEND,LEXELP,LEXNM,LEXFI,LEXRT
N LEXOUT,LEXMSG S LEXFI=757.001
D FILE^DID(LEXFI,"N","GLOBAL NAME","LEXOUT","LEXMSG")
S LEXRT=$G(LEXOUT("GLOBAL NAME")) Q:LEXRT'["^LEX"
S LEXPRE=$G(^TMP("LEXRX",$J,"T",1,"ELAP"))
S LEXBEG=$$NOW^XLFDT,LEXNM=$$FN^LEXRXXM(LEXFI)
S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,("Re-Indexing File #"_LEXFI))
Q:LEXTC=1 I '$D(ZTQUEUED) W !,?8,"Re-Indexing",!
N LEXIEN,LEXP3,LEXP4 S (LEXP3,LEXP4,LEXIEN)=0
F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. S LEXP3=LEXIEN,LEXP4=LEXP4+1
. N DA,DIK,LEXCFQ,LEXCMC,LEXCND,LEXCOV,LEXNFQ,LEXNND,LEXNOV
. S LEXCND=$G(^LEX(LEXFI,LEXIEN,0)),LEXCMC=+LEXCND,LEXCOV=$P(LEXCND,"^",2)
. S (LEXCFQ,LEXNFQ)=$P(LEXCND,"^",3),LEXNOV=$$FREQ(LEXIEN)
. S:LEXNOV>LEXNFQ LEXNFQ=LEXNOV S:LEXNOV'=LEXCOV LEXNFQ=LEXNOV
. I $D(LEXFIX) D Q
. . Q:LEXCOV=LEXNOV&(LEXCFQ=LEXNFQ)
. . S DA=+($G(LEXIEN)),DIK=LEXRT D IX2^DIK
. . S ^LEX(LEXFI,LEXIEN,0)=LEXCMC_"^"_LEXNOV_"^"_LEXNFQ
. . D IX1^DIK
. S DA=+($G(LEXIEN)),DIK=LEXRT D IX1^DIK
S $P(^LEX(LEXFI,0),"^",3)=LEXP3,$P(^LEX(LEXFI,0),"^",4)=LEXP4
Q:$D(LEXQ) S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
S:$E(LEXELP,1)=" "&($E(LEXELP,3)=":") LEXELP=$TR(LEXELP," ","0")
D REP^LEXRXXS(LEXFI,LEXFI,"ALLIX",,,"Re-Index",LEXELP)
S LEXELP=$$ADDT^LEXRXXM(LEXELP,LEXPRE)
S ^TMP("LEXRX",$J,"T",1,"ELAP")=LEXELP
Q
FREQ(X) ; Get frequency based on codes and semantics
N LEXMC,LEXMCE,LEXND,LEXOF,LEXNF S LEXMC=+($G(X)),X=0 Q:'$D(^LEX(757,LEXMC,0)) X
S LEXMCE=$P($G(^LEX(757,+LEXMC,0)),"^",1)
S LEXOF=$P($G(^LEX(757.001,LEXMC,0)),"^",2)
N LEXSA,LEXSAB,LEXACT,LEXSMC,LEXNUR,LEXBEH,LEXI10,LEXPRO,LEXDIA
S (LEXSA,LEXNUR,LEXBEH,LEXPRO,LEXDIA,LEXI10,LEXSMC)=0 D SO,SM S X=0
S LEXNF="",X=0
; ICD-10-CM 6
S:+LEXI10=1&(+LEXDIA=1) (LEXNF,X)=6 Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
; ICD-10-PCS 5
S:+LEXI10=1&(+LEXDIA'=1) (LEXNF,X)=5 Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
; ICD-9 coded Diagnosis 4
S:LEXI10=0&(+LEXDIA=1)&(X=0) (LEXNF,X)=4 Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
; Behavior or non-ICD Diagnosis 3
S:'$L(LEXNF)&(+($G(LEXBEH))=1)&($G(LEXSMC)>0) (LEXNF,X)=3 Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
; Procedures 2
S:'$L(LEXNF)&(+($G(LEXPRO))=1) (LEXNF,X)=2 Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
; Nursing 1
S:'$L(LEXNF)&(+($G(LEXNUR))=1) (LEXNF,X)=1 Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
; Diseases 3
S:'$L(LEXNF)&(+($G(LEXSMC))>1) (LEXNF,X)=3 Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
; Non-Critical 0
S:'$L(LEXNF) (LEXNF,X)=0
Q X
SO ; Codes
N LEXSA S LEXSA=0 F S LEXSA=$O(^LEX(757.02,"AMC",LEXMC,LEXSA)) Q:+LEXSA=0 D SOC
Q
SOC ; Code Type
N LEXCOD,LEXEFF,LEXHIS,LEXND,LEXSAB
S LEXEFF=$O(^LEX(757.02,LEXSA,4,"B"," "),-1) Q:LEXEFF'?7N
S LEXHIS=$O(^LEX(757.02,LEXSA,4,"B",LEXEFF," "),-1) Q:+LEXHIS'>0
S LEXND=$G(^LEX(757.02,LEXSA,4,+LEXHIS,0)) Q:+($P(LEXND,"^",2))'>0
S LEXND=$G(^LEX(757.02,LEXSA,0)),LEXSAB=+($P(LEXND,U,3)),LEXCOD=$P(LEXND,U,2)
Q:LEXSAB=0
; ICD-10 CM/PCS
S:LEXSAB=30!(LEXSAB=31) LEXI10=1_"^"_LEXCOD
; Diagnosis ICD-9 and ICD-10
S:LEXSAB=1!(LEXSAB=30) LEXDIA=1_"^"_LEXCOD
; Procedures ICD-9, ICD-10, CPT and HCPCS
S:LEXSAB=2!(LEXSAB=31)!(LEXSAB=3)!(LEXSAB=4) LEXPRO=1_"^"_LEXCOD
; Behaviors DSM-III and DSM-IV
S:LEXSAB=5!(LEXSAB=6) LEXBEH=1_"^"_LEXCOD
; Nursing NANDA, NIC, NOC, HHC and Omaha
S:LEXSAB>10&(LEXSAB<16) LEXNUR=1_"^"_LEXCOD
Q
SM ; Semantics - BEH Behavior and DIS Disorders
N LEXBD,LEXCLA,LEXSM S LEXSMC=0,LEXMC=+($G(LEXMC)) Q:'$D(^LEX(757,LEXMC,0))
S (LEXBD,LEXSM)=0 F S LEXSM=$O(^LEX(757.1,"B",LEXMC,LEXSM)) Q:+LEXSM=0 D SMC
S LEXSMC=LEXBD
Q
SMC ; Semantic Class
S LEXCLA=+($P($G(^LEX(757.1,LEXSM,0)),U,2))
; Behavior
S:LEXCLA=3&(LEXBD'>0) LEXBD=1
; Disease
S:LEXCLA=6 LEXBD=2
Q
CLR ; Clear
K LEXFIX,LEXNAM,LEXSET,LEXTEST,ZTQUEUED,LEXQ
Q
LEXRXB ;ISL/KER - Re-Index 757.001 B/AF ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**81,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX( SACC 1.3
+5 ; ^LEX(757.001) SACC 1.3
+6 ; ^LEX(757.02) SACC 1.3
+7 ; ^LEX(757.1) SACC 1.3
+8 ; ^TMP("LEXRX") SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; $$FMDIFF^XLFDT ICR 10103
+12 ; $$NOW^XLFDT ICR 10103
+13 ; FILE^DID ICR 2052
+14 ; IX1^DIK ICR 10013
+15 ; IX2^DIK ICR 10013
+16 ;
+17 ; Local Variables NEWed or KILLed Elsewhere
+18 ; LEXFIX Fix Flag NEWed/KILLed by LEXRXXT
+19 ; LEXNAM Task name NEWed/KILLed by LEXRXXT
+20 ; LEXSET Re-Index flag NEWed/KILLed by LEXRXXT
+21 ; LEXQ Quiet flat NEWed/KILLed by LEXRXXT2
+22 ; LEXTEST Test variable NEWed/KILLed by Developer
+23 ; ZTQUEUED Task flag NEWed/KILLed by Taskman
+24 ;
+25 QUIT
EN ; Main Entry Point
R757001 ; Repair file 757.001
+1 DO RB
DO RAF
DO SET
QUIT
RB ; Index ^LEX(757.001,"B",MC,IEN)
+1 IF '$DATA(ZTQUEUED)
WRITE !
NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR,X
+2 SET LEXFI="757.001"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.001 ""B""")
IF LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXSTR=""
SET LEXIDX="B"
SET LEXIDXT="^LEX(757.001,""B"",MC,IEN)"
+5 FOR
SET LEXSTR=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR))
IF '$LENGTH(LEXSTR)
QUIT
Begin DoDot:1
+6 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:2
+7 SET LEXNDS=LEXNDS+1
IF '$DATA(^LEX(LEXFI,LEXIEN,0))
Begin DoDot:3
+8 SET LEXERR=LEXERR+1
IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
+9 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
QUIT
+10 IF +LEXSTR>0&(LEXSTR=LEXIEN)
QUIT
NEW LEXOK,LEXMC
SET LEXMC=$PIECE($GET(^LEX(LEXFI,LEXIEN,0)),"^",1)
+11 SET LEXOK=0
IF LEXMC=LEXSTR
SET LEXOK=1
IF 'LEXOK
Begin DoDot:3
+12 SET LEXERR=LEXERR+1
IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
IF $LENGTH(LEXMC)
SET ^LEX(LEXFI,LEXIDX,LEXMC,LEXIEN)=""
+13 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:1
+15 NEW DA,DIK,X
SET DA=LEXIEN
SET X=$PIECE($GET(^LEX(LEXFI,DA,0)),"^",1)
IF '$LENGTH(X)
QUIT
+16 IF '$DATA(^LEX(LEXFI,"B",X,DA))
Begin DoDot:2
+17 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing",?58," ",DA
End DoDot:2
+18 IF $LENGTH(X)
SET ^LEX(LEXFI,"B",X,DA)=""
End DoDot:1
+19 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+20 SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+21 IF $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+22 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+23 QUIT
RAF ; Index ^LEX(757.001,"AF",FREQ,IEN)
+1 IF '$DATA(ZTQUEUED)
WRITE !
NEW DA,DIK,LEXAF,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXFQ,LEXIEN,LEXNDS,LEXOF,LEXOK,LEXSTR,X
+2 SET LEXFI="757.001"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.001 ""AF""")
IF LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXSTR=""
SET LEXIDX="AF"
SET LEXIDXT="^LEX(757.001,""AF"",FREQ,IEN)"
+5 FOR
SET LEXSTR=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR))
IF '$LENGTH(LEXSTR)
QUIT
Begin DoDot:1
+6 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:2
+7 SET LEXNDS=LEXNDS+1
+8 IF '$DATA(^LEX(LEXFI,LEXIEN,0))
Begin DoDot:3
+9 SET LEXERR=LEXERR+1
IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
+10 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
QUIT
+11 NEW LEXOK,LEXFQ,LEXOF,LEXAF,LEXF
SET LEXFQ=+($PIECE($GET(^LEX(LEXFI,LEXIEN,0)),"^",3))
+12 SET LEXOF=+($PIECE($GET(^LEX(LEXFI,LEXIEN,0)),"^",2))
IF LEXOF>LEXFQ
Begin DoDot:3
+13 SET LEXF=$$FREQ^LEXRXXM(LEXIEN)
IF LEXF'>LEXFQ
SET $PIECE(^LEX(LEXFI,LEXIEN,0),"^",2)=LEXF
SET LEXOF=LEXF
+14 IF LEXF>LEXFQ
SET $PIECE(^LEX(LEXFI,LEXIEN,0),"^",2)=LEXF
SET $PIECE(^LEX(LEXFI,LEXIEN,0),"^",3)=LEXF
SET (LEXOF,LEXFQ)=LEXF
End DoDot:3
+15 SET LEXAF=LEXFQ-LEXOF
IF LEXAF>0
SET LEXAF=LEXAF*(-1)
+16 SET LEXOK=0
IF LEXAF=LEXSTR
SET LEXOK=1
IF 'LEXOK
Begin DoDot:3
+17 SET LEXERR=LEXERR+1
IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
IF $LENGTH(LEXAF)
SET ^LEX(LEXFI,LEXIDX,LEXAF,LEXIEN)=""
+18 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:1
+20 NEW DA,DIK,X,LEXF
SET DA=LEXIEN
SET X=+($PIECE($GET(^LEX(LEXFI,DA,0)),"^",3))
SET LEXF=-(X-(+($PIECE(^LEX(LEXFI,DA,0),"^",2))))
+21 IF '$DATA(^LEX(LEXFI,"AF",LEXF,DA))
Begin DoDot:2
+22 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing",?58," ",DA
End DoDot:2
+23 IF $LENGTH(LEXF)
SET ^LEX(LEXFI,"AF",LEXF,DA)=""
End DoDot:1
+24 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+25 SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+26 IF $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+27 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+28 QUIT
+29 ;
+30 ; Miscellaneous
SET ; Re-Index Concept Usage file 757.001 (Set logic only)
+1 IF '$DATA(LEXSET)
QUIT
NEW LEXTC,LEXPRE,LEXBEG,LEXEND,LEXELP,LEXNM,LEXFI,LEXRT
+2 NEW LEXOUT,LEXMSG
SET LEXFI=757.001
+3 DO FILE^DID(LEXFI,"N","GLOBAL NAME","LEXOUT","LEXMSG")
+4 SET LEXRT=$GET(LEXOUT("GLOBAL NAME"))
IF LEXRT'["^LEX"
QUIT
+5 SET LEXPRE=$GET(^TMP("LEXRX",$JOB,"T",1,"ELAP"))
+6 SET LEXBEG=$$NOW^XLFDT
SET LEXNM=$$FN^LEXRXXM(LEXFI)
+7 SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,("Re-Indexing File #"_LEXFI))
+8 IF LEXTC=1
QUIT
IF '$DATA(ZTQUEUED)
WRITE !,?8,"Re-Indexing",!
+9 NEW LEXIEN,LEXP3,LEXP4
SET (LEXP3,LEXP4,LEXIEN)=0
+10 FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:1
+11 SET LEXP3=LEXIEN
SET LEXP4=LEXP4+1
+12 NEW DA,DIK,LEXCFQ,LEXCMC,LEXCND,LEXCOV,LEXNFQ,LEXNND,LEXNOV
+13 SET LEXCND=$GET(^LEX(LEXFI,LEXIEN,0))
SET LEXCMC=+LEXCND
SET LEXCOV=$PIECE(LEXCND,"^",2)
+14 SET (LEXCFQ,LEXNFQ)=$PIECE(LEXCND,"^",3)
SET LEXNOV=$$FREQ(LEXIEN)
+15 IF LEXNOV>LEXNFQ
SET LEXNFQ=LEXNOV
IF LEXNOV'=LEXCOV
SET LEXNFQ=LEXNOV
+16 IF $DATA(LEXFIX)
Begin DoDot:2
+17 IF LEXCOV=LEXNOV&(LEXCFQ=LEXNFQ)
QUIT
+18 SET DA=+($GET(LEXIEN))
SET DIK=LEXRT
DO IX2^DIK
+19 SET ^LEX(LEXFI,LEXIEN,0)=LEXCMC_"^"_LEXNOV_"^"_LEXNFQ
+20 DO IX1^DIK
End DoDot:2
QUIT
+21 SET DA=+($GET(LEXIEN))
SET DIK=LEXRT
DO IX1^DIK
End DoDot:1
+22 SET $PIECE(^LEX(LEXFI,0),"^",3)=LEXP3
SET $PIECE(^LEX(LEXFI,0),"^",4)=LEXP4
+23 IF $DATA(LEXQ)
QUIT
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+24 IF $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+25 DO REP^LEXRXXS(LEXFI,LEXFI,"ALLIX",,,"Re-Index",LEXELP)
+26 SET LEXELP=$$ADDT^LEXRXXM(LEXELP,LEXPRE)
+27 SET ^TMP("LEXRX",$JOB,"T",1,"ELAP")=LEXELP
+28 QUIT
FREQ(X) ; Get frequency based on codes and semantics
+1 NEW LEXMC,LEXMCE,LEXND,LEXOF,LEXNF
SET LEXMC=+($GET(X))
SET X=0
IF '$DATA(^LEX(757,LEXMC,0))
QUIT X
+2 SET LEXMCE=$PIECE($GET(^LEX(757,+LEXMC,0)),"^",1)
+3 SET LEXOF=$PIECE($GET(^LEX(757.001,LEXMC,0)),"^",2)
+4 NEW LEXSA,LEXSAB,LEXACT,LEXSMC,LEXNUR,LEXBEH,LEXI10,LEXPRO,LEXDIA
+5 SET (LEXSA,LEXNUR,LEXBEH,LEXPRO,LEXDIA,LEXI10,LEXSMC)=0
DO SO
DO SM
SET X=0
+6 SET LEXNF=""
SET X=0
+7 ; ICD-10-CM 6
+8 IF +LEXI10=1&(+LEXDIA=1)
SET (LEXNF,X)=6
IF $LENGTH(LEXNF)&(LEXNF'=LEXOF)&(X>0)
QUIT X
+9 ; ICD-10-PCS 5
+10 IF +LEXI10=1&(+LEXDIA'=1)
SET (LEXNF,X)=5
IF $LENGTH(LEXNF)&(LEXNF'=LEXOF)&(X>0)
QUIT X
+11 ; ICD-9 coded Diagnosis 4
+12 IF LEXI10=0&(+LEXDIA=1)&(X=0)
SET (LEXNF,X)=4
IF $LENGTH(LEXNF)&(LEXNF'=LEXOF)&(X>0)
QUIT X
+13 ; Behavior or non-ICD Diagnosis 3
+14 IF '$LENGTH(LEXNF)&(+($GET(LEXBEH))=1)&($GET(LEXSMC)>0)
SET (LEXNF,X)=3
IF $LENGTH(LEXNF)&(LEXNF'=LEXOF)&(X>0)
QUIT X
+15 ; Procedures 2
+16 IF '$LENGTH(LEXNF)&(+($GET(LEXPRO))=1)
SET (LEXNF,X)=2
IF $LENGTH(LEXNF)&(LEXNF'=LEXOF)&(X>0)
QUIT X
+17 ; Nursing 1
+18 IF '$LENGTH(LEXNF)&(+($GET(LEXNUR))=1)
SET (LEXNF,X)=1
IF $LENGTH(LEXNF)&(LEXNF'=LEXOF)&(X>0)
QUIT X
+19 ; Diseases 3
+20 IF '$LENGTH(LEXNF)&(+($GET(LEXSMC))>1)
SET (LEXNF,X)=3
IF $LENGTH(LEXNF)&(LEXNF'=LEXOF)&(X>0)
QUIT X
+21 ; Non-Critical 0
+22 IF '$LENGTH(LEXNF)
SET (LEXNF,X)=0
+23 QUIT X
SO ; Codes
+1 NEW LEXSA
SET LEXSA=0
FOR
SET LEXSA=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSA))
IF +LEXSA=0
QUIT
DO SOC
+2 QUIT
SOC ; Code Type
+1 NEW LEXCOD,LEXEFF,LEXHIS,LEXND,LEXSAB
+2 SET LEXEFF=$ORDER(^LEX(757.02,LEXSA,4,"B"," "),-1)
IF LEXEFF'?7N
QUIT
+3 SET LEXHIS=$ORDER(^LEX(757.02,LEXSA,4,"B",LEXEFF," "),-1)
IF +LEXHIS'>0
QUIT
+4 SET LEXND=$GET(^LEX(757.02,LEXSA,4,+LEXHIS,0))
IF +($PIECE(LEXND,"^",2))'>0
QUIT
+5 SET LEXND=$GET(^LEX(757.02,LEXSA,0))
SET LEXSAB=+($PIECE(LEXND,U,3))
SET LEXCOD=$PIECE(LEXND,U,2)
+6 IF LEXSAB=0
QUIT
+7 ; ICD-10 CM/PCS
+8 IF LEXSAB=30!(LEXSAB=31)
SET LEXI10=1_"^"_LEXCOD
+9 ; Diagnosis ICD-9 and ICD-10
+10 IF LEXSAB=1!(LEXSAB=30)
SET LEXDIA=1_"^"_LEXCOD
+11 ; Procedures ICD-9, ICD-10, CPT and HCPCS
+12 IF LEXSAB=2!(LEXSAB=31)!(LEXSAB=3)!(LEXSAB=4)
SET LEXPRO=1_"^"_LEXCOD
+13 ; Behaviors DSM-III and DSM-IV
+14 IF LEXSAB=5!(LEXSAB=6)
SET LEXBEH=1_"^"_LEXCOD
+15 ; Nursing NANDA, NIC, NOC, HHC and Omaha
+16 IF LEXSAB>10&(LEXSAB<16)
SET LEXNUR=1_"^"_LEXCOD
+17 QUIT
SM ; Semantics - BEH Behavior and DIS Disorders
+1 NEW LEXBD,LEXCLA,LEXSM
SET LEXSMC=0
SET LEXMC=+($GET(LEXMC))
IF '$DATA(^LEX(757,LEXMC,0))
QUIT
+2 SET (LEXBD,LEXSM)=0
FOR
SET LEXSM=$ORDER(^LEX(757.1,"B",LEXMC,LEXSM))
IF +LEXSM=0
QUIT
DO SMC
+3 SET LEXSMC=LEXBD
+4 QUIT
SMC ; Semantic Class
+1 SET LEXCLA=+($PIECE($GET(^LEX(757.1,LEXSM,0)),U,2))
+2 ; Behavior
+3 IF LEXCLA=3&(LEXBD'>0)
SET LEXBD=1
+4 ; Disease
+5 IF LEXCLA=6
SET LEXBD=2
+6 QUIT
CLR ; Clear
+1 KILL LEXFIX,LEXNAM,LEXSET,LEXTEST,ZTQUEUED,LEXQ
+2 QUIT
