LEX2080 ;ISL/KER - LEX*2.0*80 Env Check ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^%ZOSF("UCI" ICR 10096
; ^%ZOSF("UCICHECK" ICR 10096
; ^LEXM( N/A
; ^TMP("LEXKID") SACC 2.3.2.5.1
; ^TMP("LEXMSG") SACC 2.3.2.5.1
;
; External References
; ^DIC ICR 10006
; FIND^DIC ICR 2051
; $$IENS^DILF ICR 2054
; $$GET1^DIQ ICR 2056
; EN^DIQ1 ICR 10015
; $$FMTE^XLFDT ICR 10103
; ^XMD ICR 10070
; $$NETNAME^XMXUTIL ICR 2734
; $$PATCH^XPDUTL ICR 10141
; $$PKG^XPDUTL ICR 10141
; $$VERSION^XPDUTL ICR 10141
; $$VER^XPDUTL ICR 10141
; BMES^XPDUTL ICR 10141
; MES^XPDUTL ICR 10141
;
; Local Variables NEWed or KILLed Elsewhere
; XPDABORT,XPDDIQ,XPDENV,XPDQUIT
;
ENV ; LEX*2.0*80 Environment Check
; Checks
S XPDNOQUE=1 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXG,LEXE,LEXSTR D IMP
K XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B") S XPDDIQ("XPZ1","B")="NO",XPDDIQ("XPI1","B")="NO"
S U="^"
; User Variables
D:+($$UR)'>0 ET("User not defined (DUZ)")
; System Variables
D:+($$SY)'>0 ET("Undefined IO variable(s)")
I $D(LEXE) D ABRT Q
; Version Number
I $$VERSION^XPDUTL("LEX")'="2.0" D D ABRT Q
. D ET("Version 2.0 not found. Please install Lexicon Utility v 2.0")
; Required Patches
D:$O(LEXREQP(0))'>0 IMP I $O(LEXREQP(0))>0 D
. W ! N LEXPAT,LEXI,LEXPN,LEXP,LEXR,LEXC,LEXO,LEXC1,LEXC2,LEXC3,LEXC4,LEX
. S (LEXR,LEXC)=0 S LEXC1=3,(LEXC2,LEXC3,LEXC4)=20,LEXC2=18
. S LEXI=0 F S LEXI=$O(LEXREQP(LEXI)) Q:+LEXI'>0 D
. . S LEXC=LEXC+1,LEXPAT=$G(LEXREQP(LEXI))
. . S:$P(LEXPAT,"^",2)?7N LEXR=LEXR+1,LEXC3=LEXC2+13,LEXC4=LEXC2+36
. S LEXI=0 F S LEXI=$O(LEXREQP(LEXI)) Q:+LEXI'>0 D
. . N LEXPAT,LEXREL,LEXINS,LEXCOM,LEXINE,LEXREQ,LEXTX S LEXREQ=$G(LEXREQP(LEXI))
. . S LEXPAT=$P(LEXREQ,"^",1),LEXREL=$P(LEXREQ,"^",2),LEXCOM=$P(LEXREQ,"^",3)
. . S LEXPN=$$INS(LEXPAT) S LEXINS=$$INSD(LEXPAT),LEXINE=$P(LEXINS,"^",2)
. . W:LEXI=1 !,?3,"Checking for ",?LEXC2,$S(+($G(LEXR))>0:"Released",1:"")
. . S LEXTX=$J(" ",LEXC1)_LEXPAT
. . S:LEXREL?7N LEXTX=LEXTX_$J(" ",(LEXC2-$L(LEXTX)))_$TR($$FMTE^XLFDT(LEXREL,"5DZ"),"@"," ")
. . I +LEXPN>0 D
. . . S LEXO=+($G(LEXO))+1 S LEXTX=LEXTX_$J(" ",(LEXC3-$L(LEXTX)))_"Installed "
. . . S:$L($G(LEXINE)) LEXTX=LEXTX_LEXINE
. . . S:+LEXC4>0&(+LEXC4>LEXC3)&($L(LEXCOM)) LEXTX=LEXTX_$J(" ",(LEXC4-$L(LEXTX)))_LEXCOM
. . D M(LEXTX)
. . I +LEXPN'>0 D ET((" "_LEXPAT_" not found, please install "_LEXPAT_" before continuing"))
. W:+($G(LEXO))'=LEXC !
I $D(LEXE) D M(),ABRT Q
D IG I $D(LEXE) D M(),ABRT Q
I '$D(LEXFULL)&(+($G(XPDENV))'=1) D QUIT Q
I $D(LEXE) D ABRT Q
S LEXG=$$RGBL
I $D(LEXE)&(+LEXG=0) D ABRT Q
I $D(LEXE)&(+LEXG<0) D ABRT Q
I '$D(LEXFULL)&(+($G(XPDENV))'=1) D QUIT Q
;
; Install Package(s)
;
; XPDENV = 1 Environment Check during Install
;
; Check Data "is installed" or "is translated"
N LEXIT S LEXIT=0 I '$D(LEXFULL)&(LEXIT) D QUIT Q
; Checking Global "Write" Protection
D:+($G(XPDENV))=1 GBLS I $D(LEXE) D ABRT Q
; Check Import Global Checksum
D:+($G(XPDENV))=1 CS I $D(LEXE) D ABRT Q
; Quit, Exit or Abort
QUIT ; Quit Passed Environment Check
K LEXFULL D OK
Q
EXIT ; Exit Failed Environment Check
D:$D(LEXE) ED S XPDQUIT=2 K LEXE,LEXFULL Q
ABRT ; Abort Failed Environment Check, KILL the distribution
D:$D(LEXE) ED S XPDABORT=1,XPDQUIT=1,XPDQUIT("LEX*2.0*80")=1,XPDQUIT("ICD*18.0*57")=1
K LEXE,LEXFULL
Q
ENV2 ; Environment Check #2 - XPDENV=1
N XPDENV S XPDENV=1 D ENV
Q
GBLS ; Check Write access on globals
N LEXB1,LEXB2,LEXE,LEXGBL,LEXRT,LEXT,LEXF,LEXI,LEXX,LEXOK,LEXS,X S LEXOK=1
D BM(" I will now check the protection on ^LEX, ^ICD9 and ^ICD0 Globals.")
D M(" If you get an ERROR, you will need to change the protection on ")
D M(" these globals to allow read/write as indicated:")
D BM(" Owner Group World Network")
D M(" Cache systems RWD RW RW RWD")
D BM(" Checking:"),M(" ")
S LEXS="",X=1 F LEXI=1:1 D Q:'$L(LEXX)
. S LEXX="" S LEXE="S LEXX=$T(GD+"_LEXI_")" X LEXE S LEXX=$$TRIM(LEXX) Q:'$L(LEXX) Q:'$L($TR(LEXX,";",""))
. S LEXGBL=$P(LEXX,";",3) Q:LEXGBL["^LEXM" S LEXRT=$P(LEXX,";",4),LEXT=$P(LEXX,";",5),LEXF=$P(LEXX,";",6)
. S (LEXB1,LEXB2)="",$P(LEXB1," ",(19-$L(LEXRT)))="",$P(LEXB2," ",(28-$L(LEXT)))=""
. I '$D(@LEXGBL) D RGNF S LEXOK=0 D M((" <"_LEXRT_" not found>")) Q
. D M((" "_LEXRT_LEXB1_LEXT_LEXB2_LEXF)) S @LEXGBL=$G(@LEXGBL) H 1
D:LEXOK M(" --> ok") D:'LEXOK M(" ??") D M(" ")
Q
RGBL(X) ; Check Write access on globals
N LEXS,LEXI,LEXX,LEXEC,LEXGBL,LEXRT,LEXT,LEXF,LEXB1,LEXB2
S LEXS="",X=1 F LEXI=1:1 D Q:'$L(LEXX)
. S LEXX="" S LEXEC="S LEXX=$T(GD+"_LEXI_")" X LEXEC S LEXX=$$TRIM(LEXX) Q:'$L(LEXX) Q:'$L($TR(LEXX,";",""))
. S LEXGBL=$P(LEXX,";",3) Q:LEXGBL["^LEXM" S LEXRT=$P(LEXX,";",4),LEXT=$P(LEXX,";",5),LEXF=$P(LEXX,";",6)
. S (LEXB1,LEXB2)="",$P(LEXB1," ",(15-$L(LEXRT)))="",$P(LEXB2," ",(28-$L(LEXT)))=""
. I '$D(@LEXGBL) S:LEXS'[LEXRT LEXS=LEXS_", "_LEXRT S X=-1 S:LEXGBL["LEXM("&(X=1) X=0
I $L(LEXS),X'>0 D
. S:LEXS[", " LEXS=$P(LEXS,", ",1,($L(LEXS,", ")-1))_" and "_$P(LEXS,", ",$L(LEXS,", "))
. S:$E(LEXS,1,2)=", " LEXS=$E(LEXS,3,$L(LEXS)) S:$E(LEXS,1,7)[" and " LEXS=$P(LEXS," and ",2)
. D:X=-1 ET(("Global"_$S(LEXS[", "!(LEXS[" and "):"s",1:"")_" "_LEXS_" either not found or incomplete."))
. D:X=0 CM
Q X
RGNF ; Required global not found
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP Q:'$L(LEXBUILD) Q:$D(^TMP("LEX*2.0*80",$J,"NODATA"))
D:$G(LEXGBL)["^LEX"&($G(LEXGBL)'["^LEXM") ET(""),ET("Required global "_$P($G(LEXGBL),"(",1)_" not found.")
D:$G(LEXGBL)["^LEX"&($G(LEXGBL)["^LEXM") CM
Q
UOK(X) ; UCI Ok for Install
N X,Y S X=$$NETNAME^XMXUTIL(.5) Q:X["LEXDEV1.FO-BAYPINES" 0
X ^%ZOSF("UCI") Q:$G(Y)["LEXDEV1" 0 S X="LEXDEV1" X ^%ZOSF("UCICHECK") Q:$G(X)=$G(Y) 0
Q 1
GOK(X) ; Input Global Ok for Install
D IMP Q:'$L(LEXBUILD) 0 Q:$D(^TMP("LEX*2.0*80",$J,"NODATA")) 1
Q:'$D(^LEXM) 0 Q:'$D(^LEXM(80)) 0 Q:'$D(^LEXM(80.1)) 0 Q:'$D(^LEXM(80.4)) 0
Q:$G(^LEXM(0,"BUILD"))'=$G(LEXBUILD) 0
Q 1
CS ; Checksum for import global
K LEXE D IMP Q:'$L(LEXBUILD) Q:$D(^TMP("LEX*2.0*80",$J,"NODATA"))
D BM(" Running checksum routine on the ^LEXM import global, please wait")
N LEXCK,LEXND,LEXV S LEXCK=+($G(^LEXM(0,"CHECKSUM")))
S LEXND=+($G(^LEXM(0,"NODES"))),LEXV=+($$VC(LEXCK,LEXND))
D M(" ") D:LEXV>0 M(" Checksum is ok"),M(" ")
D:LEXV=0 CM D:LEXV=-1 CW D:LEXV=-2 CU D:LEXV=-3 CF
Q
VC(X,Y) ; Verify Checksum for import global
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
D IMP Q:'$L(LEXBUILD) 0 Q:$D(^TMP("LEX*2.0*80",$J,"NODATA")) -4
I $G(^LEXM(0,"BUILD"))'=$G(LEXBUILD) Q -1
N LEXCK,LEXND,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
S LEXCK=+($G(X)),LEXND=+($G(Y))
Q:LEXCK'>0!(LEXND'>0) -2
S LEXL=64,(LEXCNT,LEXLC)=0,LEXS=(+(LEXND\LEXL))
S:LEXS=0 LEXS=1 D:+($O(^LEXM(0)))>0 M("")
S (LEXC,LEXN)="^LEXM",(LEXNC,LEXGCS)=0 W " "
F S LEXN=$Q(@LEXN) Q:LEXN=""!(LEXN'[LEXC) D
. Q:LEXN="^LEXM(0,""CHECKSUM"")"
. Q:LEXN="^LEXM(0,""NODES"")"
. S LEXCNT=LEXCNT+1
. I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0
. S LEXNC=LEXNC+1,LEXD=@LEXN,LEXT=LEXN_"="_LEXD
. F LEXP=1:1:$L(LEXT) S LEXGCS=$A(LEXT,LEXP)*LEXP+LEXGCS
Q:LEXNC'=LEXND -3
Q:LEXGCS'=LEXCK -3
Q 1
SY(X) ; Check System variables
Q:'$D(IO)!('$D(IOF))!('$D(IOM))!('$D(ION))!('$D(IOSL))!('$D(IOST)) 0
Q 1
UR(X) ; Check User variables
Q:'$L($G(DUZ(0))) 0
Q:+($G(DUZ))=0!($$NOTDEF(+$G(DUZ))) 0
Q 1
; Error messages
;
CM ; Missing ^LEXM
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP D ET(""),ET("Missing import global ^LEXM.") D CO
Q
CW ; Wrong ^LEXM
N LEXB,LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP S LEXB=$G(^LEXM(0,"BUILD")) D ET("")
I $L(LEXBUILD),$L(LEXB),LEXBUILD'=LEXB D Q
. D ET(("Incorrect import global ^LEXM found ("_LEXB_" global).")) D CKO
D ET("Incorrect import global ^LEXM found.") D CKO
Q
CU ; Unable to verify
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP D ET(""),ET("Unable to verify checksum for import global ^LEXM (possibly corrupt).") D CKO
Q
CF ; Failed checksum
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP D ET("") D ET("Import global ^LEXM failed checksum.") D CKO
Q
CO ; Obtain new global
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP
D ET(""),ET(" Please obtain a copy of the import global ^LEXM contained in the ")
D ET((" global host file "_LEXIGHF_" before continuing with the "_LEXBUILD))
D ET((" installation."))
Q
CKO ; Kill and Obtain new global
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP D ET("")
D ET((" Use the entry point KALL^LEXXGI2 to safely KILL the existing "))
D ET((" import global ^LEXM from your system. Then obtain a new copy"))
D ET((" of ^LEXM contained in the global host file "_LEXIGHF_" before"))
D ET((" continuing with the "_LEXBUILD_" installation."))
Q
IG ; Import Global
D IMP Q:'$L($G(LEXBUILD)) Q:$D(^TMP("LEX*2.0*80",$J,"NODATA")) N CT S CT=0
D:+($G(^LEXM(80,0)))'>0 IGT("ICD Diagnosis data") D:+($G(^LEXM(80.1,0)))'>0 IGT("ICD Procedure data")
D:+($G(^LEXM(757,0)))'>0 IGT("Lexicon Major Concept data") D:+($G(^LEXM(757.001,0)))'>0 IGT("Lexicon Frequency data")
D:+($G(^LEXM(757.01,0)))'>0 IGT("Lexicon Expressions data") D:+($G(^LEXM(757.02,0)))'>0 IGT("Lexicon Code data")
D:+($G(^LEXM(757.03,0)))'>0 IGT("Lexicon Coding System data") D:+($G(^LEXM(757.033,0)))'>0 IGT("Lexicon Coding Character data")
D:+($G(^LEXM(757.1,0)))'>0 IGT("Lexicon Semantic Map data") D:+($G(^LEXM(757.2,0)))'>0 IGT("Lexicon Subset Definition data")
D:+($G(^LEXM(757.3,0)))'>0 IGT("Lexicon Screen data") D:+($G(^LEXM(757.31,0)))'>0 IGT("Lexicon Display data")
I $D(LEXE) D
. N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP D ET(" ")
. D ET(("Obtain a copy of the data import global ^LEXM contiained in"))
. D ET(("the global host file "_LEXIGHF_" before continuing with"))
. D ET(("the installation."))
Q
IGT(X) ; Import Global Error Text
N TXT S TXT=$G(X) Q:'$L(TXT) S CT=+($G(CT))+1 D:CT=1 ET("Import Global ^LEXM Missing:"),ET(" ") D ET((" "_TXT))
Q
ET(X) ; Error Text
N LEXI S LEXI=+($G(LEXE(0))),LEXI=LEXI+1,LEXE(LEXI)=" "_$G(X),LEXE(0)=LEXI
Q
ED ; Error Display
N LEXI S LEXI=0 F S LEXI=$O(LEXE(LEXI)) Q:+LEXI=0 D M(LEXE(LEXI))
D M(" ") K LEXE Q
NOTDEF(IEN) ; Check to see if user is defined
N DA,DR,DIQ,LEX,DIC S DA=IEN,DR=.01,DIC=200,DIQ="LEX" D EN^DIQ1 Q '$D(LEX)
OK ; Environment is OK
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXT
D IMP S LEXT=" Environment "_$S($L(LEXBUILD):("for patch/build "_LEXBUILD_" "),1:"")_"is ok"
D BM(LEXT),M(" ")
Q
MAIL ; Mail global array in message
N DIFROM,LEXPRI,LEXADR,LEXI,LEXM,LEXSUB,XCNP,XMDUZ,XMSCR,XMSUB,XMTEXT,XMY,XMZ
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP Q:'$L(LEXBUILD)
H:$D(^TMP("LEX*2.0*80",$J,"NODATA")) 2 K ^TMP("LEXMSG",$J) S LEXSUB="Lexicon/ICD-10 Installation"
S:$L($G(LEXBUILD)) LEXSUB=$G(LEXBUILD)_" Installation" S LEXPRI=$$ADR G:'$L(LEXPRI) MAILQ
S LEXPRI="G.LEXINS@"_LEXPRI S LEXADR=$$GET1^DIQ(200,+($G(DUZ)),.01) G:'$L(LEXADR) MAILQ
S XMSUB=LEXSUB S LEXI=0 F S LEXI=$O(^TMP("LEXKID",$J,LEXI)) Q:+LEXI=0 D
. S LEXM=+($O(^TMP("LEXMSG",$J," "),-1))+1
. S ^TMP("LEXMSG",$J,LEXM,0)=$E($G(^TMP("LEXKID",$J,LEXI)),1,79)
. S ^TMP("LEXMSG",$J,0)=LEXM
K ^TMP("LEXKID",$J) G:'$D(^TMP("LEXMSG",$J)) MAILQ
G:+($G(^TMP("LEXMSG",$J,0)))'>0 MAILQ S XMY(LEXPRI)="",XMY(LEXADR)=""
S XMTEXT="^TMP(""LEXMSG"",$J,",XMDUZ=.5 D ^XMD
MAILQ ; Quit Mail
D KILL K XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMY,XMTEXT,XMDUZ
Q
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)="ISC-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 LEX
Q "ISC-SLC.VA.GOV"
KILL ; Kill all ^TMP(
K ^TMP("LEXMSG",$J),^TMP("LEXKID",$J)
Q
INS(X) ;
N LEX,LEXP,LEXV,LEXI S LEX=$G(X) I $L(LEX,"*")=3 S X=$$PATCH^XPDUTL(LEX) Q X
S LEXP=$$PKG^XPDUTL(LEX),LEXV=$$VER^XPDUTL(LEX),LEXI=$$VERSION^XPDUTL(LEXP)
Q:+LEXV>0&(LEXV=LEXI) 1
Q 0
INSD(X) ; Installed on
N DA,LEX,LEXDA,LEXE,LEXI,LEXMSG,LEXNS,LEXOUT,LEXPI,LEXPN,LEXSCR,LEXVI,LEXVD,LEXVI,LEXVR S LEX=$G(X)
S LEXNS=$$PKG^XPDUTL(LEX),LEXVR=$$VER^XPDUTL(LEX),LEXPN=$P(X,"*",3)
Q:'$L(LEXNS) "" S LEXVR=+LEXVR Q:LEXVR'>0 "" S LEXPN=+LEXPN S:LEXVR'["." LEXVR=LEXVR_".0"
S LEXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_LEXVR_""""
D FIND^DIC(9.4,,.01,"O",LEXNS,10,"C",LEXSCR,,"LEXOUT","LEXMSG")
S LEXPI=$G(LEXOUT("DILIST",2,1)) K LEXOUT,LEXMSG Q:+LEXPI'>0 "" Q:'$D(@("^DIC(9.4,"_LEXPI_",22)")) ""
K DA S DA(1)=LEXPI S LEXDA=$$IENS^DILF(.DA)
D FIND^DIC(9.49,LEXDA,".01;1I;2I","O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")
S LEXVD=$G(LEXOUT("DILIST","ID",1,2)) I $E(LEXVD,1,7)?7N&(+LEXPN'>0) D Q X
. S X=$E(LEXVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(LEXVD,1,7),"5DZ"),"@"," ")
S:$E(LEXVD,1,7)'?7N LEXVD=$G(LEXOUT("DILIST","ID",1,1)) I $E(LEXVD,1,7)?7N&(+LEXPN'>0) D Q X
. S X=$E(LEXVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(LEXVD,1,7),"5DZ"),"@"," ")
Q:+LEXPN'>0 "" S LEXVI=$G(LEXOUT("DILIST",2,1)) K LEXOUT,LEXMSG
Q:+LEXVI'>0 "" Q:'$D(@("^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"")")) ""
K DA S DA(2)=LEXPI,DA(1)=LEXVI S LEXDA=$$IENS^DILF(.DA)
S LEXSCR="I $G(^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
D FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
S LEXI=$G(LEXOUT("DILIST","ID",1,.02)) I '$L(LEXI) D
. S LEXSCR="" D FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
. S LEXI=$G(LEXOUT("DILIST","ID",1,.02))
Q:'$L(LEXI) "" Q:$P(LEXI,".",1)'?7N "" S LEXE=$TR($$FMTE^XLFDT(LEXI,"5DZ"),"@"," ")
Q:'$L(LEXE) "" S X=LEXI_"^"_LEXE
Q X
BM(X) ; Blank Line with Message
D BMES^XPDUTL($G(X)) Q
M(X) ; Message
D MES^XPDUTL($G(X)) Q
TRIM(X) ; Trim Spaces
S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
IMP ; Import names
S LEXREQP(1)="LEX*2.0*25^3030924^CSV"
S LEXREQP(2)="LEX*2.0*30^3041008^CTD"
S LEXREQP(3)="LEX*2.0*62^3090506^Queries"
S LEXREQP(4)="LEX*2.0*81^3120214^Fix Cross-Reference"
;S LEXREQP(5)="PSO*7.0*404^3120814^Global Read of ICD files"
;S LEXREQP(6)="ONC*2.11*56^3120927^Global Read of ICD files"
;S LEXREQP(7)="RA*5.0*112^3130417^Global Read of ICD files"
S LEXREQP(5)="ICD*18.0*62^3130501^DRG Grouper Fixes"
;S LEXREQP(9)="GMPL*2.0*43^3130514^Global Read of ICD files"
;S LEXREQP(10)="TIU*1.0*267^3130514^Global Read of ICD files"
S LEXREQP(6)="ICD*18.0*69^3130621^DRG Grouper Fixes"
;S LEXREQP(12)="DG*5.3*870^3130715^Global Read of ICD files"
;S LEXREQP(13)="IBD*3.0*64^3130903^Global Read of ICD files"
;S LEXREQP(14)="LR*5.2*429^3130918^Global Read of ICD files"
;S LEXREQP(15)="ACKQ*3.0*22^3131212^Global Read of ICD files"
S LEXREQP(7)="LEX*2.0*94^3140114^FY14 2nd Qtr Update"
S LEXPTYPE="ICD-10 Implementation",LEXLREV="80"
S LEXBUILD="LEX*2.0*80",LEXIGHF="ICD_18_57.GBL",LEXFY="",LEXQTR=""
Q
GD ; Global Data
;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
;;^ICD9(0);^ICD9(;ICD Diagnosis;80
;;^ICD0(0);^ICD0(;ICD Operation/Procedure;80.1
LEX2080 ;ISL/KER - LEX*2.0*80 Env Check ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^%ZOSF("UCI" ICR 10096
+5 ; ^%ZOSF("UCICHECK" ICR 10096
+6 ; ^LEXM( N/A
+7 ; ^TMP("LEXKID") SACC 2.3.2.5.1
+8 ; ^TMP("LEXMSG") SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; ^DIC ICR 10006
+12 ; FIND^DIC ICR 2051
+13 ; $$IENS^DILF ICR 2054
+14 ; $$GET1^DIQ ICR 2056
+15 ; EN^DIQ1 ICR 10015
+16 ; $$FMTE^XLFDT ICR 10103
+17 ; ^XMD ICR 10070
+18 ; $$NETNAME^XMXUTIL ICR 2734
+19 ; $$PATCH^XPDUTL ICR 10141
+20 ; $$PKG^XPDUTL ICR 10141
+21 ; $$VERSION^XPDUTL ICR 10141
+22 ; $$VER^XPDUTL ICR 10141
+23 ; BMES^XPDUTL ICR 10141
+24 ; MES^XPDUTL ICR 10141
+25 ;
+26 ; Local Variables NEWed or KILLed Elsewhere
+27 ; XPDABORT,XPDDIQ,XPDENV,XPDQUIT
+28 ;
ENV ; LEX*2.0*80 Environment Check
+1 ; Checks
+2 SET XPDNOQUE=1
NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXG,LEXE,LEXSTR
DO IMP
+3 KILL XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B")
SET XPDDIQ("XPZ1","B")="NO"
SET XPDDIQ("XPI1","B")="NO"
+4 SET U="^"
+5 ; User Variables
+6 IF +($$UR)'>0
DO ET("User not defined (DUZ)")
+7 ; System Variables
+8 IF +($$SY)'>0
DO ET("Undefined IO variable(s)")
+9 IF $DATA(LEXE)
DO ABRT
QUIT
+10 ; Version Number
+11 IF $$VERSION^XPDUTL("LEX")'="2.0"
Begin DoDot:1
+12 DO ET("Version 2.0 not found. Please install Lexicon Utility v 2.0")
End DoDot:1
DO ABRT
QUIT
+13 ; Required Patches
+14 IF $ORDER(LEXREQP(0))'>0
DO IMP
IF $ORDER(LEXREQP(0))>0
Begin DoDot:1
+15 WRITE !
NEW LEXPAT,LEXI,LEXPN,LEXP,LEXR,LEXC,LEXO,LEXC1,LEXC2,LEXC3,LEXC4,LEX
+16 SET (LEXR,LEXC)=0
SET LEXC1=3
SET (LEXC2,LEXC3,LEXC4)=20
SET LEXC2=18
+17 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXREQP(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:2
+18 SET LEXC=LEXC+1
SET LEXPAT=$GET(LEXREQP(LEXI))
+19 IF $PIECE(LEXPAT,"^",2)?7N
SET LEXR=LEXR+1
SET LEXC3=LEXC2+13
SET LEXC4=LEXC2+36
End DoDot:2
+20 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXREQP(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:2
+21 NEW LEXPAT,LEXREL,LEXINS,LEXCOM,LEXINE,LEXREQ,LEXTX
SET LEXREQ=$GET(LEXREQP(LEXI))
+22 SET LEXPAT=$PIECE(LEXREQ,"^",1)
SET LEXREL=$PIECE(LEXREQ,"^",2)
SET LEXCOM=$PIECE(LEXREQ,"^",3)
+23 SET LEXPN=$$INS(LEXPAT)
SET LEXINS=$$INSD(LEXPAT)
SET LEXINE=$PIECE(LEXINS,"^",2)
+24 IF LEXI=1
WRITE !,?3,"Checking for ",?LEXC2,$SELECT(+($GET(LEXR))>0:"Released",1:"")
+25 SET LEXTX=$JUSTIFY(" ",LEXC1)_LEXPAT
+26 IF LEXREL?7N
SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXC2-$LENGTH(LEXTX)))_$TRANSLATE($$FMTE^XLFDT(LEXREL,"5DZ"),"@"," ")
+27 IF +LEXPN>0
Begin DoDot:3
+28 SET LEXO=+($GET(LEXO))+1
SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXC3-$LENGTH(LEXTX)))_"Installed "
+29 IF $LENGTH($GET(LEXINE))
SET LEXTX=LEXTX_LEXINE
+30 IF +LEXC4>0&(+LEXC4>LEXC3)&($LENGTH(LEXCOM))
SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXC4-$LENGTH(LEXTX)))_LEXCOM
End DoDot:3
+31 DO M(LEXTX)
+32 IF +LEXPN'>0
DO ET((" "_LEXPAT_" not found, please install "_LEXPAT_" before continuing"))
End DoDot:2
+33 IF +($GET(LEXO))'=LEXC
WRITE !
End DoDot:1
+34 IF $DATA(LEXE)
DO M()
DO ABRT
QUIT
+35 DO IG
IF $DATA(LEXE)
DO M()
DO ABRT
QUIT
+36 IF '$DATA(LEXFULL)&(+($GET(XPDENV))'=1)
DO QUIT
QUIT
+37 IF $DATA(LEXE)
DO ABRT
QUIT
+38 SET LEXG=$$RGBL
+39 IF $DATA(LEXE)&(+LEXG=0)
DO ABRT
QUIT
+40 IF $DATA(LEXE)&(+LEXG<0)
DO ABRT
QUIT
+41 IF '$DATA(LEXFULL)&(+($GET(XPDENV))'=1)
DO QUIT
QUIT
+42 ;
+43 ; Install Package(s)
+44 ;
+45 ; XPDENV = 1 Environment Check during Install
+46 ;
+47 ; Check Data "is installed" or "is translated"
+48 NEW LEXIT
SET LEXIT=0
IF '$DATA(LEXFULL)&(LEXIT)
DO QUIT
QUIT
+49 ; Checking Global "Write" Protection
+50 IF +($GET(XPDENV))=1
DO GBLS
IF $DATA(LEXE)
DO ABRT
QUIT
+51 ; Check Import Global Checksum
+52 IF +($GET(XPDENV))=1
DO CS
IF $DATA(LEXE)
DO ABRT
QUIT
+53 ; Quit, Exit or Abort
QUIT ; Quit Passed Environment Check
+1 KILL LEXFULL
DO OK
+2 QUIT
EXIT ; Exit Failed Environment Check
+1 IF $DATA(LEXE)
DO ED
SET XPDQUIT=2
KILL LEXE,LEXFULL
QUIT
ABRT ; Abort Failed Environment Check, KILL the distribution
+1 IF $DATA(LEXE)
DO ED
SET XPDABORT=1
SET XPDQUIT=1
SET XPDQUIT("LEX*2.0*80")=1
SET XPDQUIT("ICD*18.0*57")=1
+2 KILL LEXE,LEXFULL
+3 QUIT
ENV2 ; Environment Check #2 - XPDENV=1
+1 NEW XPDENV
SET XPDENV=1
DO ENV
+2 QUIT
GBLS ; Check Write access on globals
+1 NEW LEXB1,LEXB2,LEXE,LEXGBL,LEXRT,LEXT,LEXF,LEXI,LEXX,LEXOK,LEXS,X
SET LEXOK=1
+2 DO BM(" I will now check the protection on ^LEX, ^ICD9 and ^ICD0 Globals.")
+3 DO M(" If you get an ERROR, you will need to change the protection on ")
+4 DO M(" these globals to allow read/write as indicated:")
+5 DO BM(" Owner Group World Network")
+6 DO M(" Cache systems RWD RW RW RWD")
+7 DO BM(" Checking:")
DO M(" ")
+8 SET LEXS=""
SET X=1
FOR LEXI=1:1
Begin DoDot:1
+9 SET LEXX=""
SET LEXE="S LEXX=$T(GD+"_LEXI_")"
XECUTE LEXE
SET LEXX=$$TRIM(LEXX)
IF '$LENGTH(LEXX)
QUIT
IF '$LENGTH($TRANSLATE(LEXX,";",""))
QUIT
+10 SET LEXGBL=$PIECE(LEXX,";",3)
IF LEXGBL["^LEXM"
QUIT
SET LEXRT=$PIECE(LEXX,";",4)
SET LEXT=$PIECE(LEXX,";",5)
SET LEXF=$PIECE(LEXX,";",6)
+11 SET (LEXB1,LEXB2)=""
SET $PIECE(LEXB1," ",(19-$LENGTH(LEXRT)))=""
SET $PIECE(LEXB2," ",(28-$LENGTH(LEXT)))=""
+12 IF '$DATA(@LEXGBL)
DO RGNF
SET LEXOK=0
DO M((" <"_LEXRT_" not found>"))
QUIT
+13 DO M((" "_LEXRT_LEXB1_LEXT_LEXB2_LEXF))
SET @LEXGBL=$GET(@LEXGBL)
HANG 1
End DoDot:1
IF '$LENGTH(LEXX)
QUIT
+14 IF LEXOK
DO M(" --> ok")
IF 'LEXOK
DO M(" ??")
DO M(" ")
+15 QUIT
RGBL(X) ; Check Write access on globals
+1 NEW LEXS,LEXI,LEXX,LEXEC,LEXGBL,LEXRT,LEXT,LEXF,LEXB1,LEXB2
+2 SET LEXS=""
SET X=1
FOR LEXI=1:1
Begin DoDot:1
+3 SET LEXX=""
SET LEXEC="S LEXX=$T(GD+"_LEXI_")"
XECUTE LEXEC
SET LEXX=$$TRIM(LEXX)
IF '$LENGTH(LEXX)
QUIT
IF '$LENGTH($TRANSLATE(LEXX,";",""))
QUIT
+4 SET LEXGBL=$PIECE(LEXX,";",3)
IF LEXGBL["^LEXM"
QUIT
SET LEXRT=$PIECE(LEXX,";",4)
SET LEXT=$PIECE(LEXX,";",5)
SET LEXF=$PIECE(LEXX,";",6)
+5 SET (LEXB1,LEXB2)=""
SET $PIECE(LEXB1," ",(15-$LENGTH(LEXRT)))=""
SET $PIECE(LEXB2," ",(28-$LENGTH(LEXT)))=""
+6 IF '$DATA(@LEXGBL)
IF LEXS'[LEXRT
SET LEXS=LEXS_", "_LEXRT
SET X=-1
IF LEXGBL["LEXM("&(X=1)
SET X=0
End DoDot:1
IF '$LENGTH(LEXX)
QUIT
+7 IF $LENGTH(LEXS)
IF X'>0
Begin DoDot:1
+8 IF LEXS[", "
SET LEXS=$PIECE(LEXS,", ",1,($LENGTH(LEXS,", ")-1))_" and "_$PIECE(LEXS,", ",$LENGTH(LEXS,", "))
+9 IF $EXTRACT(LEXS,1,2)=", "
SET LEXS=$EXTRACT(LEXS,3,$LENGTH(LEXS))
IF $EXTRACT(LEXS,1,7)[" and "
SET LEXS=$PIECE(LEXS," and ",2)
+10 IF X=-1
DO ET(("Global"_$SELECT(LEXS[", "!(LEXS[" and "):"s",1:"")_" "_LEXS_" either not found or incomplete."))
+11 IF X=0
DO CM
End DoDot:1
+12 QUIT X
RGNF ; Required global not found
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
IF '$LENGTH(LEXBUILD)
QUIT
IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
QUIT
+2 IF $GET(LEXGBL)["^LEX"&($GET(LEXGBL)'["^LEXM")
DO ET("")
DO ET("Required global "_$PIECE($GET(LEXGBL),"(",1)_" not found.")
+3 IF $GET(LEXGBL)["^LEX"&($GET(LEXGBL)["^LEXM")
DO CM
+4 QUIT
UOK(X) ; UCI Ok for Install
+1 NEW X,Y
SET X=$$NETNAME^XMXUTIL(.5)
IF X["LEXDEV1.FO-BAYPINES"
QUIT 0
+2 XECUTE ^%ZOSF("UCI")
IF $GET(Y)["LEXDEV1"
QUIT 0
SET X="LEXDEV1"
XECUTE ^%ZOSF("UCICHECK")
IF $GET(X)=$GET(Y)
QUIT 0
+3 QUIT 1
GOK(X) ; Input Global Ok for Install
+1 DO IMP
IF '$LENGTH(LEXBUILD)
QUIT 0
IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
QUIT 1
+2 IF '$DATA(^LEXM)
QUIT 0
IF '$DATA(^LEXM(80))
QUIT 0
IF '$DATA(^LEXM(80.1))
QUIT 0
IF '$DATA(^LEXM(80.4))
QUIT 0
+3 IF $GET(^LEXM(0,"BUILD"))'=$GET(LEXBUILD)
QUIT 0
+4 QUIT 1
CS ; Checksum for import global
+1 KILL LEXE
DO IMP
IF '$LENGTH(LEXBUILD)
QUIT
IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
QUIT
+2 DO BM(" Running checksum routine on the ^LEXM import global, please wait")
+3 NEW LEXCK,LEXND,LEXV
SET LEXCK=+($GET(^LEXM(0,"CHECKSUM")))
+4 SET LEXND=+($GET(^LEXM(0,"NODES")))
SET LEXV=+($$VC(LEXCK,LEXND))
+5 DO M(" ")
IF LEXV>0
DO M(" Checksum is ok")
DO M(" ")
+6 IF LEXV=0
DO CM
IF LEXV=-1
DO CW
IF LEXV=-2
DO CU
IF LEXV=-3
DO CF
+7 QUIT
VC(X,Y) ; Verify Checksum for import global
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
+2 DO IMP
IF '$LENGTH(LEXBUILD)
QUIT 0
IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
QUIT -4
+3 IF $GET(^LEXM(0,"BUILD"))'=$GET(LEXBUILD)
QUIT -1
+4 NEW LEXCK,LEXND,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
+5 SET LEXCK=+($GET(X))
SET LEXND=+($GET(Y))
+6 IF LEXCK'>0!(LEXND'>0)
QUIT -2
+7 SET LEXL=64
SET (LEXCNT,LEXLC)=0
SET LEXS=(+(LEXND\LEXL))
+8 IF LEXS=0
SET LEXS=1
IF +($ORDER(^LEXM(0)))>0
DO M("")
+9 SET (LEXC,LEXN)="^LEXM"
SET (LEXNC,LEXGCS)=0
WRITE " "
+10 FOR
SET LEXN=$QUERY(@LEXN)
IF LEXN=""!(LEXN'[LEXC)
QUIT
Begin DoDot:1
+11 IF LEXN="^LEXM(0,""CHECKSUM"")"
QUIT
+12 IF LEXN="^LEXM(0,""NODES"")"
QUIT
+13 SET LEXCNT=LEXCNT+1
+14 IF LEXCNT'<LEXS
SET LEXLC=LEXLC+1
IF LEXLC'>LEXL
WRITE "."
SET LEXCNT=0
+15 SET LEXNC=LEXNC+1
SET LEXD=@LEXN
SET LEXT=LEXN_"="_LEXD
+16 FOR LEXP=1:1:$LENGTH(LEXT)
SET LEXGCS=$ASCII(LEXT,LEXP)*LEXP+LEXGCS
End DoDot:1
+17 IF LEXNC'=LEXND
QUIT -3
+18 IF LEXGCS'=LEXCK
QUIT -3
+19 QUIT 1
SY(X) ; Check System variables
+1 IF '$DATA(IO)!('$DATA(IOF))!('$DATA(IOM))!('$DATA(ION))!('$DATA(IOSL))!('$DATA(IOST))
QUIT 0
+2 QUIT 1
UR(X) ; Check User variables
+1 IF '$LENGTH($GET(DUZ(0)))
QUIT 0
+2 IF +($GET(DUZ))=0!($$NOTDEF(+$GET(DUZ)))
QUIT 0
+3 QUIT 1
+4 ; Error messages
+5 ;
CM ; Missing ^LEXM
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
DO ET("")
DO ET("Missing import global ^LEXM.")
DO CO
+2 QUIT
CW ; Wrong ^LEXM
+1 NEW LEXB,LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
SET LEXB=$GET(^LEXM(0,"BUILD"))
DO ET("")
+2 IF $LENGTH(LEXBUILD)
IF $LENGTH(LEXB)
IF LEXBUILD'=LEXB
Begin DoDot:1
+3 DO ET(("Incorrect import global ^LEXM found ("_LEXB_" global)."))
DO CKO
End DoDot:1
QUIT
+4 DO ET("Incorrect import global ^LEXM found.")
DO CKO
+5 QUIT
CU ; Unable to verify
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
DO ET("")
DO ET("Unable to verify checksum for import global ^LEXM (possibly corrupt).")
DO CKO
+2 QUIT
CF ; Failed checksum
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
DO ET("")
DO ET("Import global ^LEXM failed checksum.")
DO CKO
+2 QUIT
CO ; Obtain new global
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
+2 DO ET("")
DO ET(" Please obtain a copy of the import global ^LEXM contained in the ")
+3 DO ET((" global host file "_LEXIGHF_" before continuing with the "_LEXBUILD))
+4 DO ET((" installation."))
+5 QUIT
CKO ; Kill and Obtain new global
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
DO ET("")
+2 DO ET((" Use the entry point KALL^LEXXGI2 to safely KILL the existing "))
+3 DO ET((" import global ^LEXM from your system. Then obtain a new copy"))
+4 DO ET((" of ^LEXM contained in the global host file "_LEXIGHF_" before"))
+5 DO ET((" continuing with the "_LEXBUILD_" installation."))
+6 QUIT
IG ; Import Global
+1 DO IMP
IF '$LENGTH($GET(LEXBUILD))
QUIT
IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
QUIT
NEW CT
SET CT=0
+2 IF +($GET(^LEXM(80,0)))'>0
DO IGT("ICD Diagnosis data")
IF +($GET(^LEXM(80.1,0)))'>0
DO IGT("ICD Procedure data")
+3 IF +($GET(^LEXM(757,0)))'>0
DO IGT("Lexicon Major Concept data")
IF +($GET(^LEXM(757.001,0)))'>0
DO IGT("Lexicon Frequency data")
+4 IF +($GET(^LEXM(757.01,0)))'>0
DO IGT("Lexicon Expressions data")
IF +($GET(^LEXM(757.02,0)))'>0
DO IGT("Lexicon Code data")
+5 IF +($GET(^LEXM(757.03,0)))'>0
DO IGT("Lexicon Coding System data")
IF +($GET(^LEXM(757.033,0)))'>0
DO IGT("Lexicon Coding Character data")
+6 IF +($GET(^LEXM(757.1,0)))'>0
DO IGT("Lexicon Semantic Map data")
IF +($GET(^LEXM(757.2,0)))'>0
DO IGT("Lexicon Subset Definition data")
+7 IF +($GET(^LEXM(757.3,0)))'>0
DO IGT("Lexicon Screen data")
IF +($GET(^LEXM(757.31,0)))'>0
DO IGT("Lexicon Display data")
+8 IF $DATA(LEXE)
Begin DoDot:1
+9 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
DO ET(" ")
+10 DO ET(("Obtain a copy of the data import global ^LEXM contiained in"))
+11 DO ET(("the global host file "_LEXIGHF_" before continuing with"))
+12 DO ET(("the installation."))
End DoDot:1
+13 QUIT
IGT(X) ; Import Global Error Text
+1 NEW TXT
SET TXT=$GET(X)
IF '$LENGTH(TXT)
QUIT
SET CT=+($GET(CT))+1
IF CT=1
DO ET("Import Global ^LEXM Missing:")
DO ET(" ")
DO ET((" "_TXT))
+2 QUIT
ET(X) ; Error Text
+1 NEW LEXI
SET LEXI=+($GET(LEXE(0)))
SET LEXI=LEXI+1
SET LEXE(LEXI)=" "_$GET(X)
SET LEXE(0)=LEXI
+2 QUIT
ED ; Error Display
+1 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXE(LEXI))
IF +LEXI=0
QUIT
DO M(LEXE(LEXI))
+2 DO M(" ")
KILL LEXE
QUIT
NOTDEF(IEN) ; Check to see if user is defined
+1 NEW DA,DR,DIQ,LEX,DIC
SET DA=IEN
SET DR=.01
SET DIC=200
SET DIQ="LEX"
DO EN^DIQ1
QUIT '$DATA(LEX)
OK ; Environment is OK
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXT
+2 DO IMP
SET LEXT=" Environment "_$SELECT($LENGTH(LEXBUILD):("for patch/build "_LEXBUILD_" "),1:"")_"is ok"
+3 DO BM(LEXT)
DO M(" ")
+4 QUIT
MAIL ; Mail global array in message
+1 NEW DIFROM,LEXPRI,LEXADR,LEXI,LEXM,LEXSUB,XCNP,XMDUZ,XMSCR,XMSUB,XMTEXT,XMY,XMZ
+2 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
IF '$LENGTH(LEXBUILD)
QUIT
+3 IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
HANG 2
KILL ^TMP("LEXMSG",$JOB)
SET LEXSUB="Lexicon/ICD-10 Installation"
+4 IF $LENGTH($GET(LEXBUILD))
SET LEXSUB=$GET(LEXBUILD)_" Installation"
SET LEXPRI=$$ADR
IF '$LENGTH(LEXPRI)
GOTO MAILQ
+5 SET LEXPRI="G.LEXINS@"_LEXPRI
SET LEXADR=$$GET1^DIQ(200,+($GET(DUZ)),.01)
IF '$LENGTH(LEXADR)
GOTO MAILQ
+6 SET XMSUB=LEXSUB
SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXKID",$JOB,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+7 SET LEXM=+($ORDER(^TMP("LEXMSG",$JOB," "),-1))+1
+8 SET ^TMP("LEXMSG",$JOB,LEXM,0)=$EXTRACT($GET(^TMP("LEXKID",$JOB,LEXI)),1,79)
+9 SET ^TMP("LEXMSG",$JOB,0)=LEXM
End DoDot:1
+10 KILL ^TMP("LEXKID",$JOB)
IF '$DATA(^TMP("LEXMSG",$JOB))
GOTO MAILQ
+11 IF +($GET(^TMP("LEXMSG",$JOB,0)))'>0
GOTO MAILQ
SET XMY(LEXPRI)=""
SET XMY(LEXADR)=""
+12 SET XMTEXT="^TMP(""LEXMSG"",$J,"
SET XMDUZ=.5
DO ^XMD
MAILQ ; Quit Mail
+1 DO KILL
KILL XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMY,XMTEXT,XMDUZ
+2 QUIT
ADR(LEX) ; Mailing Address
+1 NEW DIC,DTOUT,DUOUT,X,Y
SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="FO-SLC.MED.VA.GOV"
DO ^DIC
IF +Y>0
QUIT LEX
+2 SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="ISC-SLC.MED.VA.GOV"
DO ^DIC
IF +Y>0
QUIT LEX
+3 QUIT "ISC-SLC.VA.GOV"
KILL ; Kill all ^TMP(
+1 KILL ^TMP("LEXMSG",$JOB),^TMP("LEXKID",$JOB)
+2 QUIT
INS(X) ;
+1 NEW LEX,LEXP,LEXV,LEXI
SET LEX=$GET(X)
IF $LENGTH(LEX,"*")=3
SET X=$$PATCH^XPDUTL(LEX)
QUIT X
+2 SET LEXP=$$PKG^XPDUTL(LEX)
SET LEXV=$$VER^XPDUTL(LEX)
SET LEXI=$$VERSION^XPDUTL(LEXP)
+3 IF +LEXV>0&(LEXV=LEXI)
QUIT 1
+4 QUIT 0
INSD(X) ; Installed on
+1 NEW DA,LEX,LEXDA,LEXE,LEXI,LEXMSG,LEXNS,LEXOUT,LEXPI,LEXPN,LEXSCR,LEXVI,LEXVD,LEXVI,LEXVR
SET LEX=$GET(X)
+2 SET LEXNS=$$PKG^XPDUTL(LEX)
SET LEXVR=$$VER^XPDUTL(LEX)
SET LEXPN=$PIECE(X,"*",3)
+3 IF '$LENGTH(LEXNS)
QUIT ""
SET LEXVR=+LEXVR
IF LEXVR'>0
QUIT ""
SET LEXPN=+LEXPN
IF LEXVR'["."
SET LEXVR=LEXVR_".0"
+4 SET LEXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_LEXVR_""""
+5 DO FIND^DIC(9.4,,.01,"O",LEXNS,10,"C",LEXSCR,,"LEXOUT","LEXMSG")
+6 SET LEXPI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
IF +LEXPI'>0
QUIT ""
IF '$DATA(@("^DIC(9.4,"_LEXPI_",22)"))
QUIT ""
+7 KILL DA
SET DA(1)=LEXPI
SET LEXDA=$$IENS^DILF(.DA)
+8 DO FIND^DIC(9.49,LEXDA,".01;1I;2I","O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")
+9 SET LEXVD=$GET(LEXOUT("DILIST","ID",1,2))
IF $EXTRACT(LEXVD,1,7)?7N&(+LEXPN'>0)
Begin DoDot:1
+10 SET X=$EXTRACT(LEXVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(LEXVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+11 IF $EXTRACT(LEXVD,1,7)'?7N
SET LEXVD=$GET(LEXOUT("DILIST","ID",1,1))
IF $EXTRACT(LEXVD,1,7)?7N&(+LEXPN'>0)
Begin DoDot:1
+12 SET X=$EXTRACT(LEXVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(LEXVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+13 IF +LEXPN'>0
QUIT ""
SET LEXVI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
+14 IF +LEXVI'>0
QUIT ""
IF '$DATA(@("^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"")"))
QUIT ""
+15 KILL DA
SET DA(2)=LEXPI
SET DA(1)=LEXVI
SET LEXDA=$$IENS^DILF(.DA)
+16 SET LEXSCR="I $G(^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
+17 DO FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
+18 SET LEXI=$GET(LEXOUT("DILIST","ID",1,.02))
IF '$LENGTH(LEXI)
Begin DoDot:1
+19 SET LEXSCR=""
DO FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
+20 SET LEXI=$GET(LEXOUT("DILIST","ID",1,.02))
End DoDot:1
+21 IF '$LENGTH(LEXI)
QUIT ""
IF $PIECE(LEXI,".",1)'?7N
QUIT ""
SET LEXE=$TRANSLATE($$FMTE^XLFDT(LEXI,"5DZ"),"@"," ")
+22 IF '$LENGTH(LEXE)
QUIT ""
SET X=LEXI_"^"_LEXE
+23 QUIT X
BM(X) ; Blank Line with Message
+1 DO BMES^XPDUTL($GET(X))
QUIT
M(X) ; Message
+1 DO MES^XPDUTL($GET(X))
QUIT
TRIM(X) ; Trim Spaces
+1 SET X=$GET(X)
FOR
IF $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
IMP ; Import names
+1 SET LEXREQP(1)="LEX*2.0*25^3030924^CSV"
+2 SET LEXREQP(2)="LEX*2.0*30^3041008^CTD"
+3 SET LEXREQP(3)="LEX*2.0*62^3090506^Queries"
+4 SET LEXREQP(4)="LEX*2.0*81^3120214^Fix Cross-Reference"
+5 ;S LEXREQP(5)="PSO*7.0*404^3120814^Global Read of ICD files"
+6 ;S LEXREQP(6)="ONC*2.11*56^3120927^Global Read of ICD files"
+7 ;S LEXREQP(7)="RA*5.0*112^3130417^Global Read of ICD files"
+8 SET LEXREQP(5)="ICD*18.0*62^3130501^DRG Grouper Fixes"
+9 ;S LEXREQP(9)="GMPL*2.0*43^3130514^Global Read of ICD files"
+10 ;S LEXREQP(10)="TIU*1.0*267^3130514^Global Read of ICD files"
+11 SET LEXREQP(6)="ICD*18.0*69^3130621^DRG Grouper Fixes"
+12 ;S LEXREQP(12)="DG*5.3*870^3130715^Global Read of ICD files"
+13 ;S LEXREQP(13)="IBD*3.0*64^3130903^Global Read of ICD files"
+14 ;S LEXREQP(14)="LR*5.2*429^3130918^Global Read of ICD files"
+15 ;S LEXREQP(15)="ACKQ*3.0*22^3131212^Global Read of ICD files"
+16 SET LEXREQP(7)="LEX*2.0*94^3140114^FY14 2nd Qtr Update"
+17 SET LEXPTYPE="ICD-10 Implementation"
SET LEXLREV="80"
+18 SET LEXBUILD="LEX*2.0*80"
SET LEXIGHF="ICD_18_57.GBL"
SET LEXFY=""
SET LEXQTR=""
+19 QUIT
GD ; Global Data
+1 ;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
+2 ;;^ICD9(0);^ICD9(;ICD Diagnosis;80
+3 ;;^ICD0(0);^ICD0(;ICD Operation/Procedure;80.1
