Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXRXB

LEXRXB.m

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