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

LEXRXXM.m

Go to the documentation of this file.
  1. LEXRXXM ;ISL/KER - Re-Index Miscellaneous ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**81,103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^LEXT(757.2) SACC 1.3
  1. ; ^LEX(757) SACC 1.3
  1. ; ^LEX(757.001) SACC 1.3
  1. ; ^LEX(757.01) SACC 1.3
  1. ; ^LEX(757.011) SACC 1.3
  1. ; ^LEX(757.02) SACC 1.3
  1. ; ^LEX(757.03) SACC 1.3
  1. ; ^LEX(757.1) SACC 1.3
  1. ; ^TMP("LEXRX",$J) SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; %XY^%RCR ICR 10022
  1. ; HOME^%ZIS ICR 10086
  1. ; ENDR^%ZISS ICR 10088
  1. ; KILL^%ZISS ICR 10088
  1. ; ^DIC ICR 10006
  1. ; $$GET1^DIQ ICR 2056
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMDIFF^XLFDT ICR 10103
  1. ; $$FMTE^XLFDT ICR 10103
  1. ; $$NOW^XLFDT ICR 10103
  1. ;
  1. ; Local Variables NEWed or KILLed Elsewhere
  1. ; LEXQ Quiet flag (LEXRXXT2)
  1. ;
  1. Q
  1. ; Miscellaneous
  1. FREQ(X) ; Get frequency based on codes and semantics
  1. N LEXMC,LEXMCE,LEXND,LEXOF,LEXNF,LEXSA,LEXSAB,LEXACT,LEXSMC,LEXNUR
  1. N LEXBEH,LEXI10,LEXPRO,LEXDIA S LEXMC=+($G(X)),X=0
  1. Q:'$D(^LEX(757,LEXMC,0)) X S LEXMCE=$P($G(^LEX(757,+LEXMC,0)),"^",1)
  1. S LEXOF=$P($G(^LEX(757.001,LEXMC,0)),"^",2)
  1. S (LEXSA,LEXNUR,LEXBEH,LEXPRO,LEXDIA,LEXI10,LEXSMC)=0
  1. D SO,SM S X=0 S LEXNF="",X=0
  1. S:+LEXI10=1&(+LEXDIA=1) (LEXNF,X)=6
  1. Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
  1. S:+LEXI10=1&(+LEXDIA'=1) (LEXNF,X)=5
  1. Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
  1. S:LEXI10=0&(+LEXDIA=1)&(X=0) (LEXNF,X)=4
  1. Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
  1. S:'$L(LEXNF)&(+($G(LEXBEH))=1)&($G(LEXSMC)>0) (LEXNF,X)=3
  1. Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
  1. S:'$L(LEXNF)&(+($G(LEXPRO))=1) (LEXNF,X)=2
  1. Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
  1. S:'$L(LEXNF)&(+($G(LEXNUR))=1) (LEXNF,X)=1
  1. Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
  1. S:'$L(LEXNF)&(+($G(LEXSMC))>1) (LEXNF,X)=3
  1. Q:$L(LEXNF)&(LEXNF'=LEXOF)&(X>0) X
  1. S:'$L(LEXNF) (LEXNF,X)=0
  1. Q X
  1. SO ; Codes
  1. N LEXSA S LEXSA=0
  1. 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))
  1. S LEXCOD=$P(LEXND,U,2) Q:LEXSAB=0
  1. S:LEXSAB=30!(LEXSAB=31) LEXI10=1_"^"_LEXCOD
  1. S:LEXSAB=1!(LEXSAB=30) LEXDIA=1_"^"_LEXCOD
  1. S:LEXSAB=2!(LEXSAB=31)!(LEXSAB=3)!(LEXSAB=4) LEXPRO=1_"^"_LEXCOD
  1. S:LEXSAB=5!(LEXSAB=6) LEXBEH=1_"^"_LEXCOD
  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))
  1. Q:'$D(^LEX(757,LEXMC,0)) S (LEXBD,LEXSM)=0
  1. 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. S:LEXCLA=3&(LEXBD'>0) LEXBD=1
  1. S:LEXCLA=6 LEXBD=2
  1. Q
  1. SABS(X) ; AVA Source Abbreviations
  1. N LEXOUT,LEXSABS,%Y,%X K LEXOUT,LEXSABS
  1. S %Y="LEXOUT(" S %X="^DD(757.02,2,1,2," D %XY^%RCR
  1. S LEXSABS=LEXOUT(1),LEXSABS=$P(LEXSABS," S:""",2)
  1. S LEXSABS=$P(LEXSABS,"""[SAB ^LEX",1),X=LEXSABS
  1. S:'$L(X) X="^ICD^10D^ICP^10P^CPT^CPC^BIR^DS4^NAN^HHC^NIC^SNM^OMA^SCC^SCT^"
  1. Q X
  1. XREF(X) ; Set Expression Indexes
  1. N LEXEX,LEXT S LEXEX=+($G(X)) Q:+LEXEX'>0 0 Q:'$D(^LEX(757.01,LEXEX,0)) 0
  1. S LEXT=+($P($G(^LEX(757.01,LEXEX,1)),U,2)) Q:LEXT'>0 0
  1. S LEXT=+($P($G(^LEX(757.011,LEXT,0)),"^",2)) Q:+LEXT=0 0 S X=LEXT
  1. Q X
  1. MCE(X) ; Major Concept Expression
  1. S X=+($G(^LEX(757,+($G(^LEX(757.01,+($G(X)),1))),0)))
  1. Q X
  1. TIME(X) ; Time
  1. N LEXDIF,LEXD,LEXH,LEXM,LEXS,LEXT S LEXDIF=$G(X) S LEXD=LEXDIF\86400 S:+LEXD'>0 LEXD="" S LEXDIF=LEXDIF-(86400*LEXD)
  1. S LEXH=LEXDIF\3600 S:+LEXH'>0 LEXH="00" S LEXDIF=LEXDIF-(3600*LEXH) S:$L(LEXH)=1 LEXH="0"_LEXH
  1. S LEXM=LEXDIF\60 S:+LEXM'>0 LEXM="00" S LEXDIF=LEXDIF-(60*LEXM) S:$L(LEXM)=1 LEXM="0"_LEXM
  1. S LEXS=LEXDIF S:+LEXS'>0 LEXS="00" S:$L(LEXS)=1 LEXS="0"_LEXS
  1. S LEXT=LEXH_":"_LEXM_":"_LEXS S X=LEXT
  1. Q X
  1. AND(X) ; Substitute 'and'
  1. S X=$G(X) Q:$L(X,", ")'>1 X
  1. S X=$P(X,", ",1,($L(X,", ")-1))_" and "_$P(X,", ",$L(X,", "))
  1. Q X
  1. CS(X) ; Trim Comma/Space
  1. S X=$$TM($G(X),","),X=$$TM($G(X)," "),X=$$TM($G(X),","),X=$$TM($G(X)," ")
  1. Q X
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
  1. F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X
  1. ML(X) ; Maximum Length of Counter
  1. N LEX,LEXM,LEXL S (LEX,LEXM)=0 F S LEX=$O(^LEX(LEX)) Q:+LEX'>0 D
  1. . S LEXL=$O(^LEX(LEX," "),-1) S:$L(LEXL)>LEXM LEXM=$L(LEXL)
  1. S X=LEXM
  1. Q X
  1. ADDT(X,Y) ; Add Time X to Time Y
  1. N LEXT,LEXT1,LEXT2,LEXH,LEXM,LEXS S LEXT1=$G(X),LEXT2=$G(Y),LEXH=+($P(LEXT1,":",1)),LEXM=+($P(LEXT1,":",2)),LEXS=+($P(LEXT1,":",3))
  1. S LEXH=LEXH+($P(LEXT2,":",1)),LEXM=LEXM+($P(LEXT2,":",2)),LEXS=LEXS+($P(LEXT2,":",3)) S LEXT=LEXS\60 S:LEXT>0 LEXM=LEXM+LEXT,LEXS=LEXS-(LEXT*60)
  1. S LEXT=LEXM\60 S:LEXT>0 LEXH=LEXH+LEXT,LEXM=LEXM-(LEXT*60) S:+LEXS'>0 LEXS="00" S:$L(LEXS)=1 LEXS="0"_LEXS S:+LEXM'>0 LEXM="00" S:$L(LEXM)=1 LEXM="0"_LEXM
  1. S:+LEXH'>0 LEXH="00" S:$L(LEXH)=1 LEXH="0"_LEXH S X=LEXH_":"_LEXM_":"_LEXS
  1. Q X
  1. ADD(X,Y) ; Increment Time X by Y
  1. N LEX,LEXA,LEXE,LEXH,LEXM,LEXS S LEX=$G(X),LEXA=+($G(Y)),LEXE="" S:+LEXA'>0 LEXA=1 I $L(LEX),$L(LEX,":")=3 D
  1. . S LEXH=+($P(LEX,":",1)),LEXM=+($P(LEX,":",2)),LEXS=+($P(LEX,":",3))+LEXA S:LEXS>60 LEXM=LEXM+1,LEXS=LEXS-60 S:LEXM>60 LEXH=LEXH+1,LEXM=LEXM-60
  1. . S:$L(LEXH)=1 LEXH="0"_LEXH S:$L(LEXH)=1 LEXH="0"_LEXH S:$L(LEXM)=1 LEXM="0"_LEXM S:$L(LEXM)=1 LEXM="0"_LEXM S:$L(LEXS)=1 LEXS="0"_LEXS S:$L(LEXS)=1 LEXS="0"_LEXS
  1. . S LEXE=LEXH_":"_LEXM_":"_LEXS
  1. S:$L(LEXE) LEX=LEXE Q:'$L(LEX)!($L(LEX,":")'=3) "00:00:00"
  1. S X=LEX
  1. Q X
  1. TOT(X) ; Total Time
  1. N LEXE1,LEXE2,LEXE,LEXP S LEXE1=$G(^TMP("LEXRX",$J,"T",2,"ELAP")),LEXE2=$G(^TMP("LEXRX",$J,"T",1,"ELAP"))
  1. I $L(LEXE1),$L(LEXE1,":")=3,LEXE1'="00:00:00" S LEXE1=$$ADD(LEXE1,1)
  1. I $L(LEXE2),$L(LEXE2,":")=3,LEXE2'="00:00:00" S LEXE2=$$ADD(LEXE2,1)
  1. S:'$L(LEXE1)&('$L(LEXE2)) LEXE="00:00:00"
  1. S:$L(LEXE1)&('$L(LEXE2)) LEXE=LEXE1 S:'$L(LEXE1)&($L(LEXE2)) LEXE=LEXE2
  1. S:$L(LEXE1)&($L(LEXE2)) LEXE=$$ADD($$ADDT^LEXRXXM(LEXE1,LEXE2),2)
  1. S X=LEXE
  1. Q X
  1. ADR(LEX) ; Mailing Address
  1. N DIC,DTOUT,DUOUT,X,Y
  1. S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="FO-SLC.DOMAIN.EXT" D ^DIC Q:+Y>0 LEX
  1. S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="FO-SLC.DOMAIN.EXT" D ^DIC Q:+Y>0 LEX
  1. S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.DOMAIN.EXT" D ^DIC Q:+Y>0 LEX
  1. Q "ISC-SLC.DOMAIN.EXT"
  1. BEG ; Begin
  1. Q:$D(LEXQ) K ^TMP("LEXRX",$J,"P")
  1. S ^TMP("LEXRX",$J,"P",1)=$$NOW^XLFDT
  1. Q
  1. END ; End
  1. Q:$D(LEXQ) N LEXB,LEXE,LEXL S LEXB=$G(^TMP("LEXRX",$J,"P",1)) Q:+LEXB'>0
  1. S LEXE=$$NOW^XLFDT Q:+LEXE'>0 S ^TMP("LEXRX",$J,"P",2)=LEXE
  1. S LEXL=$$FMDIFF^XLFDT(LEXE,LEXB,3) Q:LEXL'[":"
  1. S:$E(LEXL,1)=" "&($E(LEXL,3)=":") LEXL=$TR(LEXL," ","0")
  1. S ^TMP("LEXRX",$J,"P",3)=LEXL
  1. Q
  1. FV(X) ; File Number is Valid
  1. N LEXFI S LEXFI=+($G(X)) Q:+LEXFI'>0 0 Q:$E(LEXFI,1,3)'="757" 0
  1. Q:'$D(^LEX(+LEXFI))&('$D(^LEXT(+LEXFI))) 0
  1. Q 1
  1. FN(X) ; Filename
  1. S X=+($G(X)) Q:$D(^LEX(X,0)) $$TITLE($P($G(^LEX(X,0)),"^",1))
  1. Q:$D(^LEXT(X,0)) $$TITLE($P($G(^LEXT(X,0)),"^",1))
  1. Q ""
  1. ED(X) ; External Date
  1. N LEXI,LEXO S LEXI=$G(X),LEXO="" Q:$E(X,1,7)'?7N ""
  1. S:$L($P(LEXI,".",2)) LEXO=$TR($$FMTE^XLFDT(LEXI,"5Z"),"@"," ")
  1. S:'$L($P(LEXI,".",2)) LEXO=$TR($$FMTE^XLFDT(LEXI,"5DZ"),"@"," ")
  1. S X=LEXO
  1. Q X
  1. ENV(X) ; Check environment
  1. N LEXNM S DT=$$DT^XLFDT D HOME^%ZIS S U="^"
  1. I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
  1. S LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
  1. I '$L(LEXNM) W !!,?5,"DUZ not valid" Q 0
  1. Q 1
  1. TITLE(X) ; Mix Case
  1. N LEXI,LEXCHR,LEXSTR,LEXSPC S LEXSTR=$$LOW^XLFSTR(X),LEXSPC=1 F LEXI=1:1:$L(LEXSTR) D
  1. . S LEXCHR=$E(LEXSTR,LEXI) I LEXSPC,LEXCHR?1L S $E(LEXSTR,LEXI)=$$UP^XLFSTR(LEXCHR),LEXSPC=0
  1. . S:LEXCHR=" " LEXSPC=1 S:LEXCHR="/" LEXSPC=1 S:LEXCHR="-" LEXSPC=1
  1. S X=LEXSTR
  1. Q X
  1. BOLD(X) ; Bold
  1. N LEXNRM,LEXBLD D ATTR S X="" S:$L($G(LEXBLD)) X=LEXBLD D KATTR Q X
  1. NORM(X) ; Norm
  1. N LEXNRM,LEXBLD D ATTR S X="" S:$L($G(LEXNRM)) X=LEXNRM D KATTR Q X
  1. ATTR ; Screen Attributes
  1. K LEXNRM,LEXBLD,IOINHI,IOINORM N X S X="IOINHI;IOINORM" D ENDR^%ZISS S LEXNRM=$G(IOINORM),LEXBLD=$G(IOINHI) Q
  1. KATTR ; Kill Screen Attributes
  1. D KILL^%ZISS K LEXNRM,LEXBLD,IOINHI,IOINORM Q
  1. CLR ; Clear
  1. K LEXQ
  1. Q