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