LEX2081 ;ISL/KER - LEX*2.0*81 Env Check ;08/17/2011
;;2.0;LEXICON UTILITY;**81**;Sep 23, 1996;Build 1
;
; Global Variables
; None
;
; External References
; DESC^%ZTLOAD ICR 10063
; STAT^%ZTLOAD ICR 10063
; FIND^DIC ICR 2051
; $$IENS^DILF ICR 2054
; EN^DIQ1 ICR 10015
; $$FMTE^XLFDT ICR 10103
; $$PATCH^XPDUTL ICR 10141
; $$VERSION^XPDUTL ICR 10141
; BMES^XPDUTL ICR 10141
; MES^XPDUTL ICR 10141
;
; Local Variables Killed by Kernel after Install
; XPDABORT,XPDDIQ,XPDQUIT
;
; see Kernel Developer Guide
; Chapter 14, KIDS Developer Tools
; Advanced Build Techniques
;
ENV ; Environment Check
;
; General
;
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 LEXSTR=$G(LEXPTYPE) S:$L($G(LEXFY))&($L($G(LEXQTR))) LEXSTR=LEXSTR_" for "_$G(LEXFY)_" "_$G(LEXQTR)_" Quarter"
D BM(LEXSTR),M("")
S U="^"
; No user
D:+($$UR)'>0 ET("User not defined (DUZ)")
; No IO
D:+($$SY)'>0 ET("Undefined IO variable(s)")
I $D(LEXE) D ABRT Q
;
; Load Distribution
;
; XPDENV = 0 Environment Check during Load
;
; Check Version (2.0)
I $$VERSION^XPDUTL("LEX")'="2.0" D D ABRT Q
. D ET("Version 2.0 not found. Please install Lexicon Utility v 2.0")
; Check 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
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
;
N LEXIT S LEXIT=0
; Checking Previous Install Task
D:+($G(XPDENV))=1 TASK I $D(LEXE) D ABRT Q
; Checking Global "Write" Protection
D:+($G(XPDENV))=1 GBLS 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 S:$L($G(LEXBUILD)) XPDQUIT(LEXBUILD)=1
K LEXE,LEXFULL
Q
;
ENV2 ; Environment Check (for testing only)
N XPDENV S XPDENV=1 D ENV
Q
;
; Checks
;
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 for the Lexicon global ^LEX. If you")
D M(" get an ERROR, you will need to change the protection on this global")
D M(" 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) 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) 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
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."))
Q X
RGNF ; Required global not found
N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP
D:$G(LEXGBL)["^LEX" ET(""),ET("Required global "_$P($G(LEXGBL),"(",1)_" not found.")
Q
TASK ; Check for Task
D BM(" Checking to see if a previous post-installation is still running")
N LEXLIST,LEXNAM,LEXRUN,LEXSTA1,LEXSTA2,LEXT1,LEXT2,LEXTSK,ZTSK
S LEXNAM="Lexicon Rebuild AVA Cross-Reference" K LEXLIST D DESC^%ZTLOAD(LEXNAM,"LEXLIST")
S LEXRUN=0,(LEXSTA1,LEXSTA2)="" S LEXTSK=0 F S LEXTSK=$O(LEXLIST(LEXTSK)) Q:+LEXTSK'>0 D Q:+LEXRUN>0
. N ZTSK S ZTSK=LEXTSK Q:+($G(ZTSK))'>0 D STAT^%ZTLOAD Q:+($G(ZTSK(0)))'>0
. I +($G(ZTSK(1)))=1 S LEXRUN=LEXTSK,LEXSTA1="is scheduled",LEXSTA2="Please wait until this task has started and completed"
. I +($G(ZTSK(1)))=2 S LEXRUN=LEXTSK,LEXSTA1="is running",LEXSTA2="Please wait until this task has completed"
I +LEXRUN>0 D
. S:'$L(LEXSTA1) LEXSTA1="is running" S:'$L(LEXSTA2) LEXSTA2="Please wait until this task has completed"
. N LEXT1,LEXT2 S LEXT1=" Task #"_LEXRUN_" "_$G(LEXSTA1)
. S:$L($G(LEXNAM)) LEXT1=" Task #"_LEXRUN_" """_LEXNAM_""" "_$G(LEXSTA1)
. S LEXT2=" "_LEXSTA2 D ET(LEXT1),ET(LEXT2)
S LEXNAM="Lexicon Rebuild AWRD Cross-Reference" K LEXLIST D DESC^%ZTLOAD(LEXNAM,"LEXLIST")
S LEXRUN=0,(LEXSTA1,LEXSTA2)="" S LEXTSK=0 F S LEXTSK=$O(LEXLIST(LEXTSK)) Q:+LEXTSK'>0 D Q:+LEXRUN>0
. N ZTSK S ZTSK=LEXTSK Q:+($G(ZTSK))'>0 D STAT^%ZTLOAD Q:+($G(ZTSK(0)))'>0
. I +($G(ZTSK(1)))=1 S LEXRUN=LEXTSK,LEXSTA1="is scheduled",LEXSTA2="Please wait until this task has started and completed"
. I +($G(ZTSK(1)))=2 S LEXRUN=LEXTSK,LEXSTA1="is running",LEXSTA2="Please wait until this task has completed"
I +LEXRUN>0 D
. S:'$L(LEXSTA1) LEXSTA1="is running" S:'$L(LEXSTA2) LEXSTA2="Please wait until this task has completed"
. N LEXT1,LEXT2 S LEXT1=" Task #"_LEXRUN_" "_$G(LEXSTA1)
. S:$L($G(LEXNAM)) LEXT1=" Task #"_LEXRUN_" """_LEXNAM_""" "_$G(LEXSTA1)
. S LEXT2=" "_LEXSTA2 D:$D(LEXE) ET(" ") D ET(LEXT1),ET(LEXT2)
I '$D(LEXE) W " - OK"
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
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
;
; Miscellaneous
;
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 Emergency patch "_LEXBUILD_" "),1:"")_"is ok"
D BM(LEXT),M(" ")
Q
BM(X) ; Blank Line with Message
S X=$G(X) S:$E(X,1)'=" " X=" "_X D BMES^XPDUTL(X) Q
M(X) ; Message
S X=$G(X) S:$E(X,1)'=" " X=" "_X D MES^XPDUTL(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
; Patch Type
S LEXPTYPE="Code Set Update"
S LEXPTYPE="Emergency Patch (fix Lexicon Cross-References)"
; Revision
S LEXLREV=81
; Required Builds build^released;build^released;build^released
S LEXREQP="LEX*2.0*73^3110628"
; This Build Name
S LEXBUILD="LEX*2.0*81"
; This Build's Export Global Host Filename
S LEXIGHF=""
; Fiscal Year
S LEXFY=""
; Quarter
S LEXQTR=""
Q
EF ; Exported Files
;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
;;^LEXT(757.2);^LEXT(757.2);Lexicon Subsets/Defaults;757.2
;;
;;^ICPT(0);^ICPT(;CPT/HCPCS;81
;;^DIC(81.1,0);^DIC(81.1);CPT Category;81.1
;;^DIC(81.2,0);^DIC(81.2);CPT Copyright;81.2
;;^DIC(81.3,0);^DIC(81.3);CPT Modifier;81.3
;;
;;^ICD9(0);^ICD9(;ICD Diagnosis;80
;;^ICD0(0);^ICD0(;ICD Operation/Procedure;80.1
;;^ICD(0);^ICD(;DRG Grouper;80.2
;;^ICM(0);^ICM(;MAJOR DIAGNOSTIC CATEGORY;80.3
;;^ICPT(0);^ICPT(;CPT/HCPCS;81
;;^DIC(81.1,0);^DIC(81.1);CPT Category;81.1
Q
GD ; Global Data
;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX2081 10680 printed Apr 09, 2024@21:13:30 Page 2
LEX2081 ;ISL/KER - LEX*2.0*81 Env Check ;08/17/2011
+1 ;;2.0;LEXICON UTILITY;**81**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; DESC^%ZTLOAD ICR 10063
+8 ; STAT^%ZTLOAD ICR 10063
+9 ; FIND^DIC ICR 2051
+10 ; $$IENS^DILF ICR 2054
+11 ; EN^DIQ1 ICR 10015
+12 ; $$FMTE^XLFDT ICR 10103
+13 ; $$PATCH^XPDUTL ICR 10141
+14 ; $$VERSION^XPDUTL ICR 10141
+15 ; BMES^XPDUTL ICR 10141
+16 ; MES^XPDUTL ICR 10141
+17 ;
+18 ; Local Variables Killed by Kernel after Install
+19 ; XPDABORT,XPDDIQ,XPDQUIT
+20 ;
+21 ; see Kernel Developer Guide
+22 ; Chapter 14, KIDS Developer Tools
+23 ; Advanced Build Techniques
+24 ;
ENV ; Environment Check
+1 ;
+2 ; General
+3 ;
+4 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXG,LEXE,LEXSTR
DO IMP
+5 KILL XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B")
SET XPDDIQ("XPZ1","B")="NO"
SET XPDDIQ("XPI1","B")="NO"
+6 SET LEXSTR=$GET(LEXPTYPE)
if $LENGTH($GET(LEXFY))&($LENGTH($GET(LEXQTR)))
SET LEXSTR=LEXSTR_" for "_$GET(LEXFY)_" "_$GET(LEXQTR)_" Quarter"
+7 DO BM(LEXSTR)
DO M("")
+8 SET U="^"
+9 ; No user
+10 if +($$UR)'>0
DO ET("User not defined (DUZ)")
+11 ; No IO
+12 if +($$SY)'>0
DO ET("Undefined IO variable(s)")
+13 IF $DATA(LEXE)
DO ABRT
QUIT
+14 ;
+15 ; Load Distribution
+16 ;
+17 ; XPDENV = 0 Environment Check during Load
+18 ;
+19 ; Check Version (2.0)
+20 IF $$VERSION^XPDUTL("LEX")'="2.0"
Begin DoDot:1
+21 DO ET("Version 2.0 not found. Please install Lexicon Utility v 2.0")
End DoDot:1
DO ABRT
QUIT
+22 ; Check Required Patches
+23 if '$LENGTH($GET(LEXREQP))
DO IMP
IF $LENGTH(LEXREQP)
Begin DoDot:1
+24 NEW LEXPAT,LEXI,LEXPN,LEXP,LEXR,LEXC,LEXO,LEXC1,LEXC2,LEXC3
SET (LEXR,LEXC)=0
SET LEXC1=5
SET (LEXC2,LEXC3)=20
+25 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
+26 FOR LEXI=1:1
if '$LENGTH($PIECE(LEXREQP,";",LEXI))
QUIT
SET LEXPAT=$PIECE(LEXREQP,";",LEXI)
Begin DoDot:2
+27 NEW LEXREL,LEXINS,LEXINE
SET LEXREL=$PIECE(LEXPAT,"^",2)
SET LEXPAT=$PIECE(LEXPAT,"^",1)
+28 SET LEXPN=$$PATCH^XPDUTL(LEXPAT)
SET LEXINS=$$INS(LEXPAT)
SET LEXINE=$PIECE(LEXINS,"^",2)
+29 if LEXI=1
WRITE !,?3,"Checking for ",?LEXC2,$SELECT(+($GET(LEXR))>0:"Released",1:"")
+30 WRITE !,?LEXC1,LEXPAT
+31 IF LEXREL?7N
WRITE ?LEXC2,$TRANSLATE($$FMTE^XLFDT(LEXREL,"5DZ"),"@"," ")
+32 IF +LEXPN>0
HANG 1
SET LEXO=+($GET(LEXO))+1
WRITE ?LEXC3,"Installed "
if $LENGTH($GET(LEXINE))
WRITE LEXINE
+33 IF +LEXPN'>0
DO ET((" "_LEXPAT_" not found, please install "_LEXPAT_" before continuing"))
End DoDot:2
+34 if +($GET(LEXO))'=LEXC
WRITE !
End DoDot:1
+35 IF $DATA(LEXE)
DO ABRT
QUIT
+36 SET LEXG=$$RGBL
+37 IF $DATA(LEXE)&(+LEXG=0)
DO ABRT
QUIT
+38 IF $DATA(LEXE)&(+LEXG<0)
DO ABRT
QUIT
+39 IF '$DATA(LEXFULL)&(+($GET(XPDENV))'=1)
DO QUIT
QUIT
+40 ;
+41 ; Install Package(s)
+42 ;
+43 ; XPDENV = 1 Environment Check during Install
+44 ;
+45 NEW LEXIT
SET LEXIT=0
+46 ; Checking Previous Install Task
+47 if +($GET(XPDENV))=1
DO TASK
IF $DATA(LEXE)
DO ABRT
QUIT
+48 ; Checking Global "Write" Protection
+49 if +($GET(XPDENV))=1
DO GBLS
IF $DATA(LEXE)
DO ABRT
QUIT
+50 ;
+51 ; Quit, Exit or Abort
+52 ;
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
if $LENGTH($GET(LEXBUILD))
SET XPDQUIT(LEXBUILD)=1
+2 KILL LEXE,LEXFULL
+3 QUIT
+4 ;
ENV2 ; Environment Check (for testing only)
+1 NEW XPDENV
SET XPDENV=1
DO ENV
+2 QUIT
+3 ;
+4 ; Checks
+5 ;
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 for the Lexicon global ^LEX. If you")
+3 DO M(" get an ERROR, you will need to change the protection on this global")
+4 DO M(" 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)
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)
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
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."))
End DoDot:1
+11 QUIT X
RGNF ; Required global not found
+1 NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR
DO IMP
+2 if $GET(LEXGBL)["^LEX"
DO ET("")
DO ET("Required global "_$PIECE($GET(LEXGBL),"(",1)_" not found.")
+3 QUIT
TASK ; Check for Task
+1 DO BM(" Checking to see if a previous post-installation is still running")
+2 NEW LEXLIST,LEXNAM,LEXRUN,LEXSTA1,LEXSTA2,LEXT1,LEXT2,LEXTSK,ZTSK
+3 SET LEXNAM="Lexicon Rebuild AVA Cross-Reference"
KILL LEXLIST
DO DESC^%ZTLOAD(LEXNAM,"LEXLIST")
+4 SET LEXRUN=0
SET (LEXSTA1,LEXSTA2)=""
SET LEXTSK=0
FOR
SET LEXTSK=$ORDER(LEXLIST(LEXTSK))
if +LEXTSK'>0
QUIT
Begin DoDot:1
+5 NEW ZTSK
SET ZTSK=LEXTSK
if +($GET(ZTSK))'>0
QUIT
DO STAT^%ZTLOAD
if +($GET(ZTSK(0)))'>0
QUIT
+6 IF +($GET(ZTSK(1)))=1
SET LEXRUN=LEXTSK
SET LEXSTA1="is scheduled"
SET LEXSTA2="Please wait until this task has started and completed"
+7 IF +($GET(ZTSK(1)))=2
SET LEXRUN=LEXTSK
SET LEXSTA1="is running"
SET LEXSTA2="Please wait until this task has completed"
End DoDot:1
if +LEXRUN>0
QUIT
+8 IF +LEXRUN>0
Begin DoDot:1
+9 if '$LENGTH(LEXSTA1)
SET LEXSTA1="is running"
if '$LENGTH(LEXSTA2)
SET LEXSTA2="Please wait until this task has completed"
+10 NEW LEXT1,LEXT2
SET LEXT1=" Task #"_LEXRUN_" "_$GET(LEXSTA1)
+11 if $LENGTH($GET(LEXNAM))
SET LEXT1=" Task #"_LEXRUN_" """_LEXNAM_""" "_$GET(LEXSTA1)
+12 SET LEXT2=" "_LEXSTA2
DO ET(LEXT1)
DO ET(LEXT2)
End DoDot:1
+13 SET LEXNAM="Lexicon Rebuild AWRD Cross-Reference"
KILL LEXLIST
DO DESC^%ZTLOAD(LEXNAM,"LEXLIST")
+14 SET LEXRUN=0
SET (LEXSTA1,LEXSTA2)=""
SET LEXTSK=0
FOR
SET LEXTSK=$ORDER(LEXLIST(LEXTSK))
if +LEXTSK'>0
QUIT
Begin DoDot:1
+15 NEW ZTSK
SET ZTSK=LEXTSK
if +($GET(ZTSK))'>0
QUIT
DO STAT^%ZTLOAD
if +($GET(ZTSK(0)))'>0
QUIT
+16 IF +($GET(ZTSK(1)))=1
SET LEXRUN=LEXTSK
SET LEXSTA1="is scheduled"
SET LEXSTA2="Please wait until this task has started and completed"
+17 IF +($GET(ZTSK(1)))=2
SET LEXRUN=LEXTSK
SET LEXSTA1="is running"
SET LEXSTA2="Please wait until this task has completed"
End DoDot:1
if +LEXRUN>0
QUIT
+18 IF +LEXRUN>0
Begin DoDot:1
+19 if '$LENGTH(LEXSTA1)
SET LEXSTA1="is running"
if '$LENGTH(LEXSTA2)
SET LEXSTA2="Please wait until this task has completed"
+20 NEW LEXT1,LEXT2
SET LEXT1=" Task #"_LEXRUN_" "_$GET(LEXSTA1)
+21 if $LENGTH($GET(LEXNAM))
SET LEXT1=" Task #"_LEXRUN_" """_LEXNAM_""" "_$GET(LEXSTA1)
+22 SET LEXT2=" "_LEXSTA2
if $DATA(LEXE)
DO ET(" ")
DO ET(LEXT1)
DO ET(LEXT2)
End DoDot:1
+23 IF '$DATA(LEXE)
WRITE " - OK"
+24 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
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 ;
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
+3 ;
+4 ; Miscellaneous
+5 ;
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 Emergency patch "_LEXBUILD_" "),1:"")_"is ok"
+3 DO BM(LEXT)
DO M(" ")
+4 QUIT
BM(X) ; Blank Line with Message
+1 SET X=$GET(X)
if $EXTRACT(X,1)'=" "
SET X=" "_X
DO BMES^XPDUTL(X)
QUIT
M(X) ; Message
+1 SET X=$GET(X)
if $EXTRACT(X,1)'=" "
SET X=" "_X
DO MES^XPDUTL(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 ; Patch Type
+2 SET LEXPTYPE="Code Set Update"
+3 SET LEXPTYPE="Emergency Patch (fix Lexicon Cross-References)"
+4 ; Revision
+5 SET LEXLREV=81
+6 ; Required Builds build^released;build^released;build^released
+7 SET LEXREQP="LEX*2.0*73^3110628"
+8 ; This Build Name
+9 SET LEXBUILD="LEX*2.0*81"
+10 ; This Build's Export Global Host Filename
+11 SET LEXIGHF=""
+12 ; Fiscal Year
+13 SET LEXFY=""
+14 ; Quarter
+15 SET LEXQTR=""
+16 QUIT
EF ; Exported Files
+1 ;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
+2 ;;^LEXT(757.2);^LEXT(757.2);Lexicon Subsets/Defaults;757.2
+3 ;;
+4 ;;^ICPT(0);^ICPT(;CPT/HCPCS;81
+5 ;;^DIC(81.1,0);^DIC(81.1);CPT Category;81.1
+6 ;;^DIC(81.2,0);^DIC(81.2);CPT Copyright;81.2
+7 ;;^DIC(81.3,0);^DIC(81.3);CPT Modifier;81.3
+8 ;;
+9 ;;^ICD9(0);^ICD9(;ICD Diagnosis;80
+10 ;;^ICD0(0);^ICD0(;ICD Operation/Procedure;80.1
+11 ;;^ICD(0);^ICD(;DRG Grouper;80.2
+12 ;;^ICM(0);^ICM(;MAJOR DIAGNOSTIC CATEGORY;80.3
+13 ;;^ICPT(0);^ICPT(;CPT/HCPCS;81
+14 ;;^DIC(81.1,0);^DIC(81.1);CPT Category;81.1
+15 QUIT
GD ; Global Data
+1 ;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
