source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2053.m@ 785

Last change on this file since 785 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1LEX2053 ;ISL/KER - LEX*2.0*53 Env Check ;06/06/2007
2 ;;2.0;LEXICON UTILITY;**53**;Sep 23, 1996;Build 18
3 ;
4 ; Variables NEWed or KILLed Elsewhere
5 ; XPDABORT
6 ; XPDDIQ("XPI1")
7 ; XPDDIQ("XPZ1")
8 ; XPDENV
9 ; XPDQUIT
10 ;
11 ; Global Variables
12 ; ^LEXM
13 ;
14 ; External References
15 ; DBIA 10015 EN^DIQ1
16 ; DBIA 10141 $$PATCH^XPDUTL
17 ; DBIA 10141 $$VERSION^XPDUTL
18 ; DBIA 10141 BMES^XPDUTL
19 ; DBIA 10141 MES^XPDUTL
20 ;
21ENV ; LEX*2.0*53 Environment Check
22 ;
23 ; General
24 ;
25 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXG,LEXE,LEXSTR,LEXSUBJ D IMP
26 K XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B") S XPDDIQ("XPZ1","B")="NO",XPDDIQ("XPI1","B")="NO"
27 S LEXSTR=$G(LEXPTYPE) S:$L($G(LEXFY))&($L($G(LEXQTR))) LEXSTR=LEXSTR_" for "_$G(LEXFY)_" "_$G(LEXQTR)_" Quarter"
28 D BM(LEXSTR),M("")
29 S U="^"
30 ; No user
31 D:+($$UR)'>0 ET("User not defined (DUZ)")
32 ; No IO
33 D:+($$SY)'>0 ET("Undefined IO variable(s)")
34 I $D(LEXE) D ABRT Q
35 ;
36 ; Load Distribution
37 ;
38 ; XPDENV = 0 Environment Check during Load
39 ;
40 ; Check Version (2.0)
41 I $$VERSION^XPDUTL("LEX")'="2.0" D D ABRT Q
42 . D ET("Version 2.0 not found. Please install Lexicon Utility v 2.0")
43 ;
44 ; Check Required Patches
45 D:'$L($G(LEXREQP)) IMP I $L(LEXREQP) D
46 . N LEXPAT,LEXI,LEXPN
47 . F LEXI=1:1 Q:'$L($P(LEXREQP,";",LEXI)) S LEXPAT=$P(LEXREQP,";",LEXI) D
48 . . S LEXPN=$$PATCH^XPDUTL(LEXPAT) W !," Checking for ",LEXPAT I +LEXPN>0 H 1 W " - installed"
49 . . I +LEXPN'>0 D ET((LEXPAT_" not found, please install "_LEXPAT_" before continuing"))
50 I $D(LEXE) D ABRT Q
51 S LEXG=$$RGBL
52 I $D(LEXE)&(+LEXG=0) D ABRT Q
53 I $D(LEXE)&(+LEXG<0) D ABRT Q
54 I '$D(LEXFULL)&(+($G(XPDENV))'=1) D QUIT Q
55 ;
56 ; Install Package(s)
57 ;
58 ; XPDENV = 1 Environment Check during Install
59 ;
60 ; Checking Global "Write" Protection
61 D:+($G(XPDENV))=1 GBLS I $D(LEXE) D ABRT Q
62 ; Check Import Global Checksum
63 D:+($G(XPDENV))=1 CS I $D(LEXE) D ABRT Q
64 ;
65 ; Quit, Exit or Abort
66 ;
67QUIT ; Quit Passed Environment Check
68 K LEXFULL D OK
69 Q
70EXIT ; Exit Failed Environment Check
71 D:$D(LEXE) ED S XPDQUIT=2 K LEXE,LEXFULL Q
72ABRT ; Abort Failed Environment Check, KILL the distribution
73 D:$D(LEXE) ED S XPDABORT=1,XPDQUIT=1,XPDQUIT("LEX*2.0*53")=1
74 K LEXE,LEXFULL
75 Q
76 ;
77 ; Checks
78 ;
79GBLS ; Check Write access on globals
80 N LEXB1,LEXB2,LEXE,LEXGBL,LEXRT,LEXT,LEXF,LEXI,LEXX,LEXOK,LEXS,X S LEXOK=1
81 D BM(" I will now check the protection on ^LEX, ^ICPT, ^ICD and ^DIC Globals.")
82 D M(" If you get an ERROR, you will need to change the protection on these")
83 D M(" globals to allow read/write as indicated:")
84 D BM(" Owner Group World Network")
85 D M(" Cache systems RWD RW RW RWD")
86 D BM(" Checking:"),M(" ")
87 S LEXS="",X=1 F LEXI=1:1 D Q:'$L(LEXX)
88 . S LEXX="" S LEXE="S LEXX=$T(GD+"_LEXI_")" X LEXE S LEXX=$$TRIM(LEXX) Q:'$L(LEXX) Q:'$L($TR(LEXX,";",""))
89 . S LEXGBL=$P(LEXX,";",3) S LEXRT=$P(LEXX,";",4),LEXT=$P(LEXX,";",5),LEXF=$P(LEXX,";",6)
90 . S (LEXB1,LEXB2)="",$P(LEXB1," ",(19-$L(LEXRT)))="",$P(LEXB2," ",(28-$L(LEXT)))=""
91 . I '$D(@LEXGBL) D RGNF S LEXOK=0 D M((" <"_LEXRT_" not found>")) Q
92 . D M((" "_LEXRT_LEXB1_LEXT_LEXB2_LEXF)) S @LEXGBL=$G(@LEXGBL) H 1
93 D:LEXOK M(" --> ok") D:'LEXOK M(" ??") D M(" ")
94 Q
95RGBL(X) ; Check Write access on globals
96 N LEXS,LEXI,LEXX,LEXEC,LEXGBL,LEXRT,LEXT,LEXF,LEXB1,LEXB2
97 S LEXS="",X=1 F LEXI=1:1 D Q:'$L(LEXX)
98 . S LEXX="" S LEXEC="S LEXX=$T(GD+"_LEXI_")" X LEXEC S LEXX=$$TRIM(LEXX) Q:'$L(LEXX) Q:'$L($TR(LEXX,";",""))
99 . S LEXGBL=$P(LEXX,";",3) S LEXRT=$P(LEXX,";",4),LEXT=$P(LEXX,";",5),LEXF=$P(LEXX,";",6)
100 . S (LEXB1,LEXB2)="",$P(LEXB1," ",(15-$L(LEXRT)))="",$P(LEXB2," ",(28-$L(LEXT)))=""
101 . I '$D(@LEXGBL) S:LEXS'[LEXRT LEXS=LEXS_", "_LEXRT S X=-1 S:LEXGBL["LEXM("&(X=1) X=0
102 I $L(LEXS),X'>0 D
103 . S:LEXS[", " LEXS=$P(LEXS,", ",1,($L(LEXS,", ")-1))_" and "_$P(LEXS,", ",$L(LEXS,", "))
104 . S:$E(LEXS,1,2)=", " LEXS=$E(LEXS,3,$L(LEXS)) S:$E(LEXS,1,7)[" and " LEXS=$P(LEXS," and ",2)
105 . D:X=-1 ET(("Global"_$S(LEXS[", "!(LEXS[" and "):"s",1:"")_" "_LEXS_" either not found or incomplete."))
106 . D:X=0 CM
107 Q X
108RGNF ; Required global not found
109 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP
110 D:$G(LEXGBL)["^LEX"&($G(LEXGBL)'["^LEXM") ET(""),ET("Required global "_$P($G(LEXGBL),"(",1)_" not found.")
111 D:$G(LEXGBL)["^LEX"&($G(LEXGBL)["^LEXM") CM
112 Q
113CHK ; Check the Checksum
114 D CS I $D(LEXE) D ED Q
115 D BM(" OK"),M(" ")
116 Q
117CS ; Checksum for import global
118 K LEXE D BM(" Running checksum routine on the ^LEXM import global, please wait")
119 N LEXCK,LEXND,LEXV S LEXCK=+($G(^LEXM(0,"CHECKSUM")))
120 S LEXND=+($G(^LEXM(0,"NODES"))),LEXV=+($$VC(LEXCK,LEXND))
121 D M(" ") D:LEXV>0 M(" Checksum is ok"),M(" ")
122 D:LEXV=0 CM D:LEXV=-1 CW D:LEXV=-2 CU D:LEXV=-3 CF
123 Q
124VC(X,Y) ; Verify Checksum for import global
125 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR Q:'$D(^LEXM) 0
126 D IMP I $G(^LEXM(0,"BUILD"))'=$G(LEXBUILD) Q -1
127 N LEXCK,LEXND,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
128 S LEXCK=+($G(X)),LEXND=+($G(Y))
129 Q:LEXCK'>0!(LEXND'>0) -2
130 S LEXL=64,(LEXCNT,LEXLC)=0,LEXS=(+(LEXND\LEXL))
131 S:LEXS=0 LEXS=1 D:+($O(^LEXM(0)))>0 M("")
132 S (LEXC,LEXN)="^LEXM",(LEXNC,LEXGCS)=0 W " "
133 F S LEXN=$Q(@LEXN) Q:LEXN=""!(LEXN'[LEXC) D
134 . Q:LEXN="^LEXM(0,""CHECKSUM"")"
135 . Q:LEXN="^LEXM(0,""NODES"")"
136 . S LEXCNT=LEXCNT+1
137 . I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0
138 . S LEXNC=LEXNC+1,LEXD=@LEXN,LEXT=LEXN_"="_LEXD
139 . F LEXP=1:1:$L(LEXT) S LEXGCS=$A(LEXT,LEXP)*LEXP+LEXGCS
140 Q:LEXNC'=LEXND -3
141 Q:LEXGCS'=LEXCK -3
142 Q 1
143SY(X) ; Check System variables
144 Q:'$D(IO)!('$D(IOF))!('$D(IOM))!('$D(ION))!('$D(IOSL))!('$D(IOST)) 0
145 Q 1
146UR(X) ; Check User variables
147 Q:'$L($G(DUZ(0))) 0
148 Q:+($G(DUZ))=0!($$NOTDEF(+$G(DUZ))) 0
149 Q 1
150 ;
151 ; Error messages
152 ;
153CM ; Missing ^LEXM
154 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP D ET(""),ET("Missing import global ^LEXM.") D CO
155 Q
156CW ; Wrong ^LEXM
157 N LEXB,LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP S LEXB=$G(^LEXM(0,"BUILD")) D ET("")
158 I $L(LEXBUILD),$L(LEXB),LEXBUILD'=LEXB D Q
159 . D ET(("Incorrect import global ^LEXM found ("_LEXB_" global).")) D CKO
160 D ET("Incorrect import global ^LEXM found.") D CKO
161 Q
162CU ; Unable to verify
163 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
164 Q
165CF ; Failed checksum
166 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP D ET("") D ET("Import global ^LEXM failed checksum.") D CKO
167 Q
168CO ; Obtain new global
169 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP
170 D ET(""),ET(" Please obtain a copy of the import global ^LEXM contained in the ")
171 D ET((" global host file "_LEXIGHF_" before continuing with the "_LEXBUILD))
172 D ET((" installation."))
173 Q
174CKO ; Kill and Obtain new global
175 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR D IMP
176 D ET(""),ET(" Please KILL the existing import global ^LEXM from your system")
177 D ET((" and obtain a new copy of ^LEXM contained in the global host file"))
178 D ET((" "_LEXIGHF_" before continuing with the "_LEXBUILD_" installation."))
179 Q
180ET(X) ; Error Text
181 N LEXI S LEXI=+($G(LEXE(0))),LEXI=LEXI+1,LEXE(LEXI)=" "_$G(X),LEXE(0)=LEXI
182 Q
183ED ; Error Display
184 N LEXI S LEXI=0 F S LEXI=$O(LEXE(LEXI)) Q:+LEXI=0 D M(LEXE(LEXI))
185 D M(" ") K LEXE Q
186 ;
187 ; Miscellaneous
188 ;
189NOTDEF(IEN) ; Check to see if user is defined
190 N DA,DR,DIQ,LEX,DIC S DA=IEN,DR=.01,DIC=200,DIQ="LEX" D EN^DIQ1 Q '$D(LEX)
191OK ; Environment is OK
192 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXT
193 D IMP S LEXT=" Environment "_$S($L(LEXBUILD):("for patch/build "_LEXBUILD_" "),1:"")_"is ok"
194 D BM(LEXT),M(" ")
195 Q
196BM(X) ; Blank Line with Message
197 D BMES^XPDUTL($G(X)) Q
198M(X) ; Message
199 D MES^XPDUTL($G(X)) Q
200TRIM(X) ; Trim Spaces
201 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
202 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
203 Q X
204IMP ; Import names
205 K LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXSUBJ
206 ; Patch Type
207 S LEXPTYPE="Code Set Remedy Ticket Fixes"
208 S LEXPTYPE="Code Set Update"
209 ; Revision
210 S LEXLREV=53
211 ; Required Builds
212 S LEXREQP="LEX*2.0*50"
213 ; This Build Name
214 S LEXBUILD="LEX*2.0*53"
215 ; This Build's Export Global Host Filename
216 S LEXIGHF="LEX_2_53.GBL"
217 ; Fiscal Year
218 S LEXFY="FY08"
219 ; Quarter
220 S LEXQTR="1st"
221 ; LEXSUBJ
222 S LEXSUBJ=$G(LEXPTYPE) S:$L($G(LEXFY))&($L($G(LEXQTR))) LEXSUBJ=LEXSUBJ_" for "_$G(LEXFY)_" "_$G(LEXQTR)_" Quarter"
223 Q
224EF ; Exported Files
225 ;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
226 ;;^LEXT(757.2);^LEXT(757.2);Lexicon Subsets/Defaults;757.2
227 ;;^ICPT(0);^ICPT(;CPT/HCPCS;81
228 ;;^DIC(81.1,0);^DIC(81.1);CPT Category;81.1
229 ;;^DIC(81.2,0);^DIC(81.2);CPT Copyright;81.2
230 ;;^DIC(81.3,0);^DIC(81.3);CPT Modifier;81.3
231 ;;^ICD9(0);^ICD9(;ICD Diagnosis;80
232 ;;^ICD0(0);^ICD0(;ICD Operation/Procedure;80.1
233 ;;^ICD(0);^ICD(;DRG Grouper;80.2
234 ;;^ICM(0);^ICM(;MAJOR DIAGNOSTIC CATEGORY;80.3
235 ;;^ICD9(0);^ICD9(;ICD Diagnosis;80
236 ;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
237 ;;^ICPT(0);^ICPT(;CPT/HCPCS;81
238 ;;^DIC(81.1,0);^DIC(81.1);CPT Category;81.1
239 ;;^DIC(81.3,0);^DIC(81.3);CPT Modifier;81.3
240 Q
241GD ; Global Data
242 ;;^LEX(757.01);^LEX(*;Lexicon;757-757.41
243 ;;^ICD9(0);^ICD9(;ICD Diagnosis;80
244 ;;^ICD0(0);^ICD0(;ICD Operation/Procedure;80.1
245 ;;^ICPT(0);^ICPT(;CPT/HCPCS;81
246 ;;^DIC(81.1,0);^DIC(81.1);CPT Category;81.1
247 ;;^DIC(81.3,0);^DIC(81.3);CPT Modifier;81.3
Note: See TracBrowser for help on using the repository browser.