LEXRXXM ;ISL/KER - Re-Index Miscellaneous ;08/17/2011
;;2.0;LEXICON UTILITY;**81**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX( SACC 1.3
; ^LEXT( 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") 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
; $$TITLE^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXQ Quiet flag NEWed/KILLed by 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.MED.VA.GOV" D ^DIC Q:+Y>0 LEX
S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="FO-SLC.VA.GOV" D ^DIC Q:+Y>0 LEX
S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 LEX
Q "ISC-SLC.VA.GOV"
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^XLFSTR($P($G(^LEX(X,0)),"^",1))
Q:$D(^LEXT(X,0)) $$TITLE^XLFSTR($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
S:$G(DUZ(0))'["@" DUZ(0)=$G(DUZ(0))_"@"
Q 1
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
LEXRXXM ;ISL/KER - Re-Index Miscellaneous ;08/17/2011
+1 ;;2.0;LEXICON UTILITY;**81**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX( SACC 1.3
+5 ; ^LEXT( SACC 1.3
+6 ; ^LEX(757, SACC 1.3
+7 ; ^LEX(757.001, SACC 1.3
+8 ; ^LEX(757.01, SACC 1.3
+9 ; ^LEX(757.011, SACC 1.3
+10 ; ^LEX(757.02, SACC 1.3
+11 ; ^LEX(757.03, SACC 1.3
+12 ; ^LEX(757.1, SACC 1.3
+13 ; ^TMP("LEXRX") SACC 2.3.2.5.1
+14 ;
+15 ; External References
+16 ; %XY^%RCR ICR 10022
+17 ; HOME^%ZIS ICR 10086
+18 ; ENDR^%ZISS ICR 10088
+19 ; KILL^%ZISS ICR 10088
+20 ; ^DIC ICR 10006
+21 ; $$GET1^DIQ ICR 2056
+22 ; $$DT^XLFDT ICR 10103
+23 ; $$FMDIFF^XLFDT ICR 10103
+24 ; $$FMTE^XLFDT ICR 10103
+25 ; $$NOW^XLFDT ICR 10103
+26 ; $$TITLE^XLFSTR ICR 10104
+27 ;
+28 ; Local Variables NEWed or KILLed Elsewhere
+29 ; LEXQ Quiet flag NEWed/KILLed by LEXRXXT2
+30 ;
+31 QUIT
+32 ; 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.MED.VA.GOV"
DO ^DIC
IF +Y>0
QUIT LEX
+3 SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="FO-SLC.VA.GOV"
DO ^DIC
IF +Y>0
QUIT LEX
+4 SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="ISC-SLC.MED.VA.GOV"
DO ^DIC
IF +Y>0
QUIT LEX
+5 QUIT "ISC-SLC.VA.GOV"
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^XLFSTR($PIECE($GET(^LEX(X,0)),"^",1))
+2 IF $DATA(^LEXT(X,0))
QUIT $$TITLE^XLFSTR($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 IF $GET(DUZ(0))'["@"
SET DUZ(0)=$GET(DUZ(0))_"@"
+6 QUIT 1
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
