- 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
