source: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI2.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1LEXXGI2 ;ISL/KER - Global Import (Update Change File w/^LEXM) ;06/06/2007
2 ;;2.0;LEXICON UTILITY;**25,26,28,29,46,49,50**;Sep 23, 1996
3 ;
4 ; Variables NEWed or KILLed Elsewhere
5 ; XPDNM NEWed by KIDS during Install
6 ;
7 ; Global Variables
8 ; ^LEXM
9 ; DBIA 872 ^ORD(101
10 ; DBIA 10011 ^UTILITY($J
11 ;
12 ; External References
13 ; DBIA 10011 ^DIWP
14 ; DBIA 10103 $$FMDIFF^XLFDT
15 ; DBIA 10103 $$NOW^XLFDT
16 ; DBIA 10141 BMES^XPDUTL
17 ; DBIA 10141 MES^XPDUTL
18 ; DBIA 10101 EN^XQOR
19 ;
20 Q
21NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
22 ; Uses LEXSCHG() from the Post-Install
23 ; Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
24 N X,LEXU,LEXT,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP D:$O(LEXSCHG(0))'>0 SCHG
25 S LEXUP="" S:$D(LEXSCHG("C","ICD"))!($D(LEXSCHG(80)))!($D(LEXSCHG(80.1))) LEXUP=$G(LEXUP)_"ICD"
26 S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG(81)))!($D(LEXSCHG(81.3))) LEXUP=$G(LEXUP)_"/CPT"
27 S:$E(LEXUP,1)="/" LEXUP=$E(LEXUP,2,$L(LEXUP)) S:$L(LEXUP) LEXUP=LEXUP_" "
28 S LEXI=756.999999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="757") S LEXT=$G(LEXT)_", "_LEXI
29 S LEXI=79.9990999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="80") S LEXT=$G(LEXT)_", "_LEXI
30 S LEXI=80.9990999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="81") S LEXT=$G(LEXT)_", "_LEXI
31 S:$E($G(LEXT),1,2)=", " LEXT=$E($G(LEXT),3,$L($G(LEXT))),LEXT=$$TRIM(LEXT)
32 I $L(LEXT) D
33 . S:$L(LEXT,", ")>1 LEXT=$P($G(LEXT),", ",1,($L($G(LEXT),", ")-1))_" and "_$P($G(LEXT),", ",$L($G(LEXT),", "))
34 S:$P($O(LEXSCHG(756.999999)),".",1)="757" LEXF="Lexicon" S:$P($O(LEXSCHG(79.999999)),".",1)=80 LEXF=$G(LEXF)_", ICD"
35 S:$P($O(LEXSCHG(80.999999)),".",1)=81 LEXF=$G(LEXF)_", CPT"
36 S:$E($G(LEXF),1,2)=", " LEXF=$E($G(LEXF),3,$L($G(LEXF))),LEXF=$$TRIM(LEXF)
37 I $L(LEXF) D
38 . S:$L(LEXF,", ")>1 LEXF=$P($G(LEXF),", ",1,($L($G(LEXF),", ")-1))_" and "_$P($G(LEXF),", ",$L($G(LEXF),", "))
39 . S:$L($P(LEXF,", ",1)) LEXF=$G(LEXF)_" File"_$S(LEXF[", ":"s",LEXF[" and ":"s",1:"")_" Updated"
40 S LEXL=78-($L(LEXF)+4),LEXU="Lexical Files Updated" I $L(LEXT)&($L(LEXF))&(LEXL>30) D
41 . S LEXU=LEXF N LEX S LEX=LEXT K LEXT S LEXT(1)=LEX D WP(.LEXT,LEXL)
42 S LEXP=+($O(^ORD(101,"B","LEXICAL SERVICES UPDATE",0))) Q:LEXP=0 S X=LEXP_";ORD(101," D EN^XQOR S:'$D(LEXSCHG) ^LEXM(0,"PRO")=$$NOW^XLFDT
43 Q:+($G(^LEXM(0,"PRO")))'>0
44 I $L($G(LEXU)) D
45 . N LEXI S LEXI=$L($G(LEXU))+3
46 . S X=$G(LEXU) D:$O(LEXT(0))'>0 BL,TL(X),BL I $O(LEXT(0))>0 D
47 . . D BL S X=$G(LEXU)_": " N LEX S LEX=0 F S LEX=$O(LEXT(LEX)) Q:+LEX'>0 D
48 . . . N LEXX S LEXX=$$TRIM($G(LEXT(LEX))) S:$L(LEXX) X=X_LEXX D TL(X) S X="",$P(X," ",+LEXI)=" "
49 . . D BL
50 S X="Protocol 'LEXICAL SERVICES UPDATE' was invoked" D TL(X)
51 S X="Subscribing applications were notified of the "_LEXUP_"update" D TL(X),BL
52 Q
53UPCHG ;
54 Q:+($G(LEXFI))'>0 N LEXID S LEXID=$S($P(LEXFI,".",1)="757":"LEX",$P(LEXFI,".",1)="80":"ICD",$P(LEXFI,".",1)="81":"CPT",1:"UNK")
55 I $D(LEXSCHG) S LEXSCHG(LEXFI,0)="",LEXSCHG("B",LEXFI)="",LEXSCHG("C",LEXID,LEXFI)=""
56 Q
57SCHG ; Change Array LEXSCHG (Some or all, but never nothing)
58 N FI,ID K LEXSCHG S LEXCHG=0
59 N FI S FI=0 F S FI=$O(^LEXM(FI)) Q:+FI'>0 D
60 . S ID=$S(FI=80!(FI=80.1):"ICD",FI=81!(FI=81.1)!(FI=81.2)!(FI=81.3):"CPT",$P(FI,".",1)=757:"LEX",1:"UNK")
61 . S LEXSCHG(FI,0)=+($G(^LEXM(FI,0))),LEXSCHG("B",FI)="" S LEXSCHG("C",ID,FI)=""
62 S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
63 S:$D(^LEXM(80))!($D(^LEXM(80.1)))!($D(^LEXM(81)))!($D(^LEXM(81.2)))!($D(^LEXM(81.3)))!($D(LEXSCHG("D","PRO"))) LEXCHG=1,LEXSCHG(0)=1
64 D:$O(LEXSCHG(0))'>0 SALL S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
65 Q
66SALL ; Set All (ICD/CPT/Lexicon)
67 D SICD,SCPT,SLEX
68 Q
69SICD ; Set ICD
70 S (LEXSCHG("80",0),LEXSCHG("B","80"),LEXSCHG("C","ICD","80"))="",(LEXSCHG("80.1",0),LEXSCHG("B","80.1"),LEXSCHG("C","ICD","80.1"))="" D SLEX
71 Q
72SCPT ; Set CPT
73 S (LEXSCHG("81",0),LEXSCHG("B","81"),LEXSCHG("C","CPT","81"))="",(LEXSCHG("81.1",0),LEXSCHG("B","81.1"),LEXSCHG("C","CPT","81.1"))=""
74 S (LEXSCHG("81.2",0),LEXSCHG("B","81.2"),LEXSCHG("C","CPT","81.2"))="",(LEXSCHG("81.3",0),LEXSCHG("B","81.3"),LEXSCHG("C","CPT","81.3"))="" D SLEX
75 Q
76SLEX ; Set Lexicon
77 S (LEXSCHG("757",0),LEXSCHG("B","757"),LEXSCHG("C","LEX","757"))="",(LEXSCHG("757.001",0),LEXSCHG("B","757.001"),LEXSCHG("C","LEX","757.001"))=""
78 S (LEXSCHG("757.01",0),LEXSCHG("B","757.01"),LEXSCHG("C","LEX","757.01"))="",(LEXSCHG("757.02",0),LEXSCHG("B","757.02"),LEXSCHG("C","LEX","757.02"))=""
79 S (LEXSCHG("757.1",0),LEXSCHG("B","757.1"),LEXSCHG("C","LEX","757.1"))=""
80 Q
81CS ; Checksum for import global
82 N LEXCHK,LEXNDS,LEXVER S LEXCHK=+($G(^LEXM(0,"CHECKSUM")))
83 W !," Running checksum routine on the ^LEXM import global, please wait"
84 S LEXNDS=+($G(^LEXM(0,"NODES"))),LEXVER=+($$VC(LEXCHK,LEXNDS)) W !
85 W:LEXVER>0 !," Checksum is ok",! Q:LEXVER>0
86 I LEXVER=0 W !!," Import global ^LEXM is missing. Please obtain a copy of ^LEXM before",!," continuing." Q
87 I LEXVER<0 D Q
88 . I LEXVER'=-3 W !," Unable to verify checksum for import global ^LEXM (possibly corrupt)"
89 . I LEXVER=-3 W !," Import global ^LEXM failed checksum"
90 . W !!," Please KILL the existing import global ^LEXM from your system and"
91 . W !," obtain a new copy of ^LEXM before continuing with the installation."
92 Q
93VC(X,Y) ; Verify Checksum for import global
94 Q:'$D(^LEXM)!('$D(^LEXM(0)))!($O(^LEXM(0))'>0) 0 N LEXCHK,LEXNDS,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
95 S LEXCHK=+($G(X)),LEXNDS=+($G(Y)) Q:LEXCHK'>0!(LEXNDS'>0) -2 S LEXL=64,(LEXCNT,LEXLC)=0,LEXS=(+(LEXNDS\LEXL))
96 S:LEXS=0 LEXS=1 W:+($O(^LEXM(0)))>0 ! S (LEXC,LEXN)="^LEXM",(LEXNC,LEXGCS)=0 W " "
97 F S LEXN=$Q(@LEXN) Q:LEXN=""!(LEXN'[LEXC) D
98 . Q:LEXN="^LEXM(0,""CHECKSUM"")" Q:LEXN="^LEXM(0,""NODES"")" S LEXCNT=LEXCNT+1
99 . I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0
100 . S LEXNC=LEXNC+1,LEXD=@LEXN,LEXT=LEXN_"="_LEXD F LEXP=1:1:$L(LEXT) S LEXGCS=$A(LEXT,LEXP)*LEXP+LEXGCS
101 Q:LEXNC'=LEXNDS -3 Q:LEXGCS'=LEXCHK -3
102 Q 1
103 ; Miscellaneous
104NF ; Import Global Not Found
105 D PB(" Import Global ^LEXM not found, consult the installation instructions")
106 D TL(" to install this global")
107 Q
108IG ; Invalid Import Global
109 D PB(" Invalid Import Global ^LEXM, please consult the installation")
110 D TL(" instructions to reload this global")
111 Q
112BL ; Blank Line
113 N X S X="" W:'$D(XPDNM) ! D:$D(XPDNM) MES^XPDUTL(X) Q
114PB(X) ; Preceeding Blank Line
115 S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !!,X D:$D(XPDNM) BMES^XPDUTL(X) Q
116TL(X) ; Text Line
117 S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !,X D:$D(XPDNM) MES^XPDUTL(X) Q
118HACK(X) ; Time
119 S X=$$NOW^XLFDT Q X
120ELAP(X1,X2) ; Elapsed Time
121 N X S X=$$FMDIFF^XLFDT(+($G(X2)),+($G(X1)),3)
122 S:X="" X="00:00:00" S X=$TR(X," ","0") S X1=X Q X1
123 Q
124KLEXM ; Subscripted Kill of ^LEXM - files only
125 N LEX S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
126 Q
127KALL ; Subscripted Kill of ^LEXM - all
128 K LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST
129 K %,%DT,C,D,D0,D1,D2,DG,DIC,DICR,DILOCKTM,DIW,IREC,J,XMDUN,XMZ,ZTSK N LEX
130 S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
131 K ^LEXM(0)
132 Q
133 ; Error Text
134ET(X) ; Save Text
135 N LEXI S LEXI=+($G(LEXE(0))),LEXI=LEXI+1,LEXE(LEXI)=$G(X),LEXE(0)=LEXI Q
136ED ; Display Text
137 N LEXI S LEXI=0 F S LEXI=$O(LEXE(LEXI)) Q:+LEXI=0 W !,LEXE(LEXI)
138 W ! K LEXE
139 Q
140 ; Case
141MIX(X) ; Mixed Case
142 S X=$G(X) N LEXT,LEXI S LEXT=""
143 F LEXI=1:1:$L(X," ") S LEXT=LEXT_" "_$$UP($E($P(X," ",LEXI),1))_$$LO($E($P(X," ",LEXI),2,$L($P(X," ",LEXI))))
144 F Q:$E(LEXT,1)'=" " S LEXT=$E(LEXT,2,$L(LEXT))
145 S:$E(LEXT,1,3)="Cpt" LEXT="CPT"_$E(LEXT,4,$L(LEXT)) S:$E(LEXT,1,3)="Icd" LEXT="ICD"_$E(LEXT,4,$L(LEXT)) S X=LEXT
146 Q X
147UP(X) ; Uppercase
148 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
149LO(X) ; Lowercase
150 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
151WP(LEX,L) ; Wrap Text LEX with Length L
152 K ^UTILITY($J,"W") N %,CT,DA,DIC,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LENGTH,TI,X,Z,END,I
153 S TI=0,LENGTH=+($G(L)) F S TI=$O(LEX(TI)) Q:+TI'>0 D
154 . N X,DIWX,DN,DTOUT,DUOUT S X=$G(LEX(TI)),DIWL=1,DIWF="C78" S:+($G(LENGTH))>0 DIWF="C"_+($G(LENGTH)) D ^DIWP
155 K LEX S (CT,I)=0 F S I=$O(^UTILITY($J,"W",1,I)) Q:+I=0 D
156 . S X=$G(^UTILITY($J,"W",1,I,0)),CT=CT+1,LEX(CT)=$$TRIM(X)
157 K ^UTILITY($J,"W")
158 Q
159CLR ; Clear
160 K %,%DT,C,CT,D,D0,D1,D2,DA,DG,DIC,DICR,DILOCKTM,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT
161 K DUOUT,END,FI,I,ID,IREC,J,L,LENGTH,LEX,LEX1,LEX2,LEX3,LEXB,LEXBUILD,LEXC,LEXCD,LEXCHG,LEXCHK,LEXCNT
162 K LEXD,LEXE,LEXF,LEXFI,LEXFY,LEXGCS,LEXI,LEXID,LEXIGHF,LEXL,LEXLAST,LEXLC,LEXLREV,LEXN,LEXNC,LEXNDS,LEXP
163 K LEXPTYPE,LEXQTR,LEXREQP,LEXS,LEXSCHG,LEXSTR,LEXT,LEXU,LEXUP,LEXVER,LEXX,TI,X,X1,X2,XMDUN,XMZ,Y,Z,ZTSK
164 Q
165TRIM(X) ; Trim Spaces
166 S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
167 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
168 F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
169 Q X
Note: See TracBrowser for help on using the repository browser.