LEX2073 ;ISL/KER - LEX*2.0*73 Env Check ;01/03/2011
;;2.0;LEXICON UTILITY;**73**;Sep 23, 1996;Build 10
;
; Global Variables
; ^TMP("LEXKID",$J) SACC 2.3.2.5.1
; ^TMP("LEXMSG",$J) SACC 2.3.2.5.1
;
; External References
; ^DIC ICR 10006
; $$GET1^DIQ ICR 2056
; EN^DIQ1 ICR 10015
; ^XMD ICR 10070
; $$PATCH^XPDUTL ICR 10141
; $$VERSION^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*73 Environment Check
; Checks
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:'$L($G(LEXREQP)) IMP I $L(LEXREQP) D
. N LEXPAT,LEXI,LEXPN,LEXP,LEXR,LEXC,LEXO,LEXC1,LEXC2,LEXC3 S (LEXR,LEXC)=0 S LEXC1=5,(LEXC2,LEXC3)=20
. F LEXI=1:1 Q:'$L($P(LEXREQP,";",LEXI)) S LEXC=LEXC+1,LEXPAT=$P(LEXREQP,";",LEXI) S:$P(LEXPAT,"^",2)?7N LEXR=LEXR+1,LEXC3=LEXC2+13
. F LEXI=1:1 Q:'$L($P(LEXREQP,";",LEXI)) S LEXPAT=$P(LEXREQP,";",LEXI) D
. . N LEXREL,LEXINS,LEXINE S LEXREL=$P(LEXPAT,"^",2),LEXPAT=$P(LEXPAT,"^",1)
. . S LEXPN=$$PATCH^XPDUTL(LEXPAT),LEXINS=$$INS(LEXPAT),LEXINE=$P(LEXINS,"^",2)
. . W:LEXI=1 !,?3,"Checking for ",?LEXC2,$S(+($G(LEXR))>0:"Released",1:"")
. . W !,?LEXC1,LEXPAT
. . I LEXREL?7N W ?LEXC2,$TR($$FMTE^XLFDT(LEXREL,"5DZ"),"@"," ")
. . I +LEXPN>0 H 1 S LEXO=+($G(LEXO))+1 W ?LEXC3,"Installed " W:$L($G(LEXINE)) LEXINE
. . I +LEXPN'>0 D ET((" "_LEXPAT_" not found, please install "_LEXPAT_" before continuing"))
. W:+($G(LEXO))'=LEXC !
I $D(LEXE) D ABRT Q
I '$D(LEXFULL)&(+($G(XPDENV))'=1) D QUIT 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*73")=1,XPDQUIT("ICD*18.0*40")=1,XPDQUIT("ICPT*6.0*46")=1
K LEXE,LEXFULL
Q
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
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,LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
D IMP K ^TMP("LEXMSG",$J) S LEXSUB="Lexicon/ICD/CPT 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,^TMP("LEXMSG",$J,LEXM,0)=$E($G(^TMP("LEXKID",$J,LEXI)),1,79),^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.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"
KILL ; Kill all ^TMP(
K ^TMP("LEXMSG",$J),^TMP("LEXKID",$J)
Q
INS(X) ; Installed on
N DA,LEXDA,LEXE,LEXI,LEXMSG,LEXNS,LEXOUT,LEXPI,LEXPN,LEXSCR,LEXVI,LEXVR S LEXNS=$P(X,"*",1),LEXVR=$P(X,"*",2),LEXPN=$P(X,"*",3)
Q:'$L(LEXNS) "" S LEXVR=+LEXVR Q:LEXVR'>0 "" S LEXPN=+LEXPN Q:+LEXPN'>0 "" 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,"O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")
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)) 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 LEXPTYPE="Code Set Field Deletions",LEXLREV="73"
;S LEXREL=3101006
S LEXREQP="LEX*2.0*72^3101006"
S LEXBUILD="LEX*2.0*73",LEXIGHF="",LEXFY="",LEXQTR=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX2073 6092 printed Sep 23, 2025@19:40:26 Page 2
LEX2073 ;ISL/KER - LEX*2.0*73 Env Check ;01/03/2011
+1 ;;2.0;LEXICON UTILITY;**73**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXKID",$J) SACC 2.3.2.5.1
+5 ; ^TMP("LEXMSG",$J) SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; ^DIC ICR 10006
+9 ; $$GET1^DIQ ICR 2056
+10 ; EN^DIQ1 ICR 10015
+11 ; ^XMD ICR 10070
+12 ; $$PATCH^XPDUTL ICR 10141
+13 ; $$VERSION^XPDUTL ICR 10141
+14 ; BMES^XPDUTL ICR 10141
+15 ; MES^XPDUTL ICR 10141
+16 ;
+17 ; Local Variables NEWed or KILLed Elsewhere
+18 ; XPDABORT,XPDDIQ,XPDENV,XPDQUIT
+19 ;
ENV ; LEX*2.0*73 Environment Check
+1 ; Checks
+2 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 '$LENGTH($GET(LEXREQP))
DO IMP
IF $LENGTH(LEXREQP)
Begin DoDot:1
+15 NEW LEXPAT,LEXI,LEXPN,LEXP,LEXR,LEXC,LEXO,LEXC1,LEXC2,LEXC3
SET (LEXR,LEXC)=0
SET LEXC1=5
SET (LEXC2,LEXC3)=20
+16 FOR LEXI=1:1
if '$LENGTH($PIECE(LEXREQP,";",LEXI))
QUIT
SET LEXC=LEXC+1
SET LEXPAT=$PIECE(LEXREQP,";",LEXI)
if $PIECE(LEXPAT,"^",2)?7N
SET LEXR=LEXR+1
SET LEXC3=LEXC2+13
+17 FOR LEXI=1:1
if '$LENGTH($PIECE(LEXREQP,";",LEXI))
QUIT
SET LEXPAT=$PIECE(LEXREQP,";",LEXI)
Begin DoDot:2
+18 NEW LEXREL,LEXINS,LEXINE
SET LEXREL=$PIECE(LEXPAT,"^",2)
SET LEXPAT=$PIECE(LEXPAT,"^",1)
+19 SET LEXPN=$$PATCH^XPDUTL(LEXPAT)
SET LEXINS=$$INS(LEXPAT)
SET LEXINE=$PIECE(LEXINS,"^",2)
+20 if LEXI=1
WRITE !,?3,"Checking for ",?LEXC2,$SELECT(+($GET(LEXR))>0:"Released",1:"")
+21 WRITE !,?LEXC1,LEXPAT
+22 IF LEXREL?7N
WRITE ?LEXC2,$TRANSLATE($$FMTE^XLFDT(LEXREL,"5DZ"),"@"," ")
+23 IF +LEXPN>0
HANG 1
SET LEXO=+($GET(LEXO))+1
WRITE ?LEXC3,"Installed "
if $LENGTH($GET(LEXINE))
WRITE LEXINE
+24 IF +LEXPN'>0
DO ET((" "_LEXPAT_" not found, please install "_LEXPAT_" before continuing"))
End DoDot:2
+25 if +($GET(LEXO))'=LEXC
WRITE !
End DoDot:1
+26 IF $DATA(LEXE)
DO ABRT
QUIT
+27 IF '$DATA(LEXFULL)&(+($GET(XPDENV))'=1)
DO QUIT
QUIT
+28 ; 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*73")=1
SET XPDQUIT("ICD*18.0*40")=1
SET XPDQUIT("ICPT*6.0*46")=1
+2 KILL LEXE,LEXFULL
+3 QUIT
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
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,LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
+2 DO IMP
KILL ^TMP("LEXMSG",$JOB)
SET LEXSUB="Lexicon/ICD/CPT Installation"
if $LENGTH($GET(LEXBUILD))
SET LEXSUB=$GET(LEXBUILD)_" Installation"
+3 SET LEXPRI=$$ADR
if '$LENGTH(LEXPRI)
GOTO MAILQ
SET LEXPRI="G.LEXINS@"_LEXPRI
SET LEXADR=$$GET1^DIQ(200,+($GET(DUZ)),.01)
if '$LENGTH(LEXADR)
GOTO MAILQ
+4 SET XMSUB=LEXSUB
SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXKID",$JOB,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+5 SET LEXM=+($ORDER(^TMP("LEXMSG",$JOB," "),-1))+1
SET ^TMP("LEXMSG",$JOB,LEXM,0)=$EXTRACT($GET(^TMP("LEXKID",$JOB,LEXI)),1,79)
SET ^TMP("LEXMSG",$JOB,0)=LEXM
End DoDot:1
+6 KILL ^TMP("LEXKID",$JOB)
if '$DATA(^TMP("LEXMSG",$JOB))
GOTO MAILQ
if +($GET(^TMP("LEXMSG",$JOB,0)))'>0
GOTO MAILQ
SET XMY(LEXPRI)=""
SET XMY(LEXADR)=""
+7 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.DOMAIN.EXT"
DO ^DIC
if +Y>0
QUIT LEX
+2 SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="ISC-SLC.DOMAIN.EXT"
DO ^DIC
if +Y>0
QUIT LEX
+3 QUIT "ISC-SLC.DOMAIN.EXT"
KILL ; Kill all ^TMP(
+1 KILL ^TMP("LEXMSG",$JOB),^TMP("LEXKID",$JOB)
+2 QUIT
INS(X) ; Installed on
+1 NEW DA,LEXDA,LEXE,LEXI,LEXMSG,LEXNS,LEXOUT,LEXPI,LEXPN,LEXSCR,LEXVI,LEXVR
SET LEXNS=$PIECE(X,"*",1)
SET LEXVR=$PIECE(X,"*",2)
SET LEXPN=$PIECE(X,"*",3)
+2 if '$LENGTH(LEXNS)
QUIT ""
SET LEXVR=+LEXVR
if LEXVR'>0
QUIT ""
SET LEXPN=+LEXPN
if +LEXPN'>0
QUIT ""
if LEXVR'["."
SET LEXVR=LEXVR_".0"
+3 SET LEXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_LEXVR_""""
+4 DO FIND^DIC(9.4,,.01,"O",LEXNS,10,"C",LEXSCR,,"LEXOUT","LEXMSG")
+5 SET LEXPI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
if +LEXPI'>0
QUIT ""
if '$DATA(@("^DIC(9.4,"_LEXPI_",22)"))
QUIT ""
+6 KILL DA
SET DA(1)=LEXPI
SET LEXDA=$$IENS^DILF(.DA)
+7 DO FIND^DIC(9.49,LEXDA,.01,"O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")
+8 SET LEXVI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
if +LEXVI'>0
QUIT ""
if '$DATA(@("^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"")"))
QUIT ""
+9 KILL DA
SET DA(2)=LEXPI
SET DA(1)=LEXVI
SET LEXDA=$$IENS^DILF(.DA)
+10 SET LEXSCR="I $G(^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
+11 DO FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
+12 SET LEXI=$GET(LEXOUT("DILIST","ID",1,.02))
if '$LENGTH(LEXI)
QUIT ""
if $PIECE(LEXI,".",1)'?7N
QUIT ""
+13 SET LEXE=$TRANSLATE($$FMTE^XLFDT(LEXI,"5DZ"),"@"," ")
if '$LENGTH(LEXE)
QUIT ""
SET X=LEXI_"^"_LEXE
+14 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 LEXPTYPE="Code Set Field Deletions"
SET LEXLREV="73"
+2 ;S LEXREL=3101006
+3 SET LEXREQP="LEX*2.0*72^3101006"
+4 SET LEXBUILD="LEX*2.0*73"
SET LEXIGHF=""
SET LEXFY=""
SET LEXQTR=""
+5 QUIT
