source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI2.m@ 1717

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1LEXXGI2 ; ISL/KER - Global Import (Update Change File w/^LEXM) ; 02/22/2007
2 ;;2.0;LEXICON UTILITY;**25,26,28,29,46,49**;Sep 23, 1996;Build 3
3 ;
4 ; Global Variables
5 ; ^LEXM(
6 ; DBIA 10011 ^UTILITY($J
7 ;
8 ; External References
9 ; DBIA 10011 ^DIWP
10 ; DBIA 10103 $$NOW^XLFDT
11 ; DBIA 10103 $$FMDIFF^XLFDT
12 ; DBIA 10141 BMES^XPDUTL
13 ; DBIA 10141 MES^XPDUTL
14 ;
15 ; XPDNM Newed by KIDS during Install
16 Q
17NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
18 ; Uses LEXSCHG() from the Post-Install
19 ; Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
20 W !!,"NOTIFY^LEXXGI1",!
21 N X,LEXU,LEXT,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP D:$O(LEXSCHG(0))'>0 SCHG
22 S LEXUP="" S:$D(LEXSCHG("C","ICD"))!($D(LEXSCHG(80)))!($D(LEXSCHG(80.1))) LEXUP=$G(LEXUP)_"ICD"
23 S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG(81)))!($D(LEXSCHG(81.3))) LEXUP=$G(LEXUP)_"/CPT"
24 S:$E(LEXUP,1)="/" LEXUP=$E(LEXUP,2,$L(LEXUP)) S:$L(LEXUP) LEXUP=LEXUP_" "
25 S LEXI=756.999999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="757") S LEXT=$G(LEXT)_", "_LEXI
26 S LEXI=79.9990999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="80") S LEXT=$G(LEXT)_", "_LEXI
27 S LEXI=80.9990999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="81") S LEXT=$G(LEXT)_", "_LEXI
28 S:$E($G(LEXT),1,2)=", " LEXT=$E($G(LEXT),3,$L($G(LEXT))),LEXT=$$TRIM(LEXT)
29 I $L(LEXT) D
30 . S:$L(LEXT,", ")>1 LEXT=$P($G(LEXT),", ",1,($L($G(LEXT),", ")-1))_" and "_$P($G(LEXT),", ",$L($G(LEXT),", "))
31 S:$P($O(LEXSCHG(756.999999)),".",1)="757" LEXF="Lexicon" S:$P($O(LEXSCHG(79.999999)),".",1)=80 LEXF=$G(LEXF)_", ICD"
32 S:$P($O(LEXSCHG(80.999999)),".",1)=81 LEXF=$G(LEXF)_", CPT"
33 S:$E($G(LEXF),1,2)=", " LEXF=$E($G(LEXF),3,$L($G(LEXF))),LEXF=$$TRIM(LEXF)
34 I $L(LEXF) D
35 . S:$L(LEXF,", ")>1 LEXF=$P($G(LEXF),", ",1,($L($G(LEXF),", ")-1))_" and "_$P($G(LEXF),", ",$L($G(LEXF),", "))
36 . S:$L($P(LEXF,", ",1)) LEXF=$G(LEXF)_" File"_$S(LEXF[", ":"s",LEXF[" and ":"s",1:"")_" Updated"
37 S LEXL=78-($L(LEXF)+4),LEXU="Lexical Files Updated" I $L(LEXT)&($L(LEXF))&(LEXL>30) D
38 . S LEXU=LEXF N LEX S LEX=LEXT K LEXT S LEXT(1)=LEX D WP(.LEXT,LEXL)
39 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
40 Q:+($G(^LEXM(0,"PRO")))'>0
41 I $L($G(LEXU)) D
42 . N LEXI S LEXI=$L($G(LEXU))+3
43 . S X=$G(LEXU) D:$O(LEXT(0))'>0 BL,TL(X),BL I $O(LEXT(0))>0 D
44 . . D BL S X=$G(LEXU)_": " N LEX S LEX=0 F S LEX=$O(LEXT(LEX)) Q:+LEX'>0 D
45 . . . N LEXX S LEXX=$$TRIM($G(LEXT(LEX))) S:$L(LEXX) X=X_LEXX D TL(X) S X="",$P(X," ",+LEXI)=" "
46 . . D BL
47 S X="Protocol 'LEXICAL SERVICES UPDATE' was invoked" D TL(X)
48 S X="Subscribing applications were notified of the "_LEXUP_"update" D TL(X),BL
49 Q
50UPCHG ;
51 Q:+LEXFI'>0 N LEXID S LEXID=$S($P(LEXFI,".",1)="757":"LEX",$P(LEXFI,".",1)="80":"ICD",$P(LEXFI,".",1)="81":"CPT",1:"UNK")
52 I $D(LEXSCHG) S LEXSCHG(LEXFI,0)="",LEXSCHG("B",LEXFI)="",LEXSCHG("C",LEXID,LEXFI)=""
53 Q
54SCHG ; Change Array LEXSCHG (Some or all, but never nothing)
55 N FI,ID K LEXSCHG S LEXCHG=0
56 N FI S FI=0 F S FI=$O(^LEXM(FI)) Q:+FI'>0 D
57 . 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")
58 . S LEXSCHG(FI,0)=+($G(^LEXM(FI,0))),LEXSCHG("B",FI)="" S LEXSCHG("C",ID,FI)=""
59 S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
60 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
61 D:$O(LEXSCHG(0))'>0 SALL S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
62 Q
63SALL ; Set All (ICD/CPT/Lexicon)
64 D SICD,SCPT,SLEX
65 Q
66SICD ; Set ICD
67 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
68 Q
69SCPT ; Set CPT
70 S (LEXSCHG("81",0),LEXSCHG("B","81"),LEXSCHG("C","CPT","81"))="",(LEXSCHG("81.1",0),LEXSCHG("B","81.1"),LEXSCHG("C","CPT","81.1"))=""
71 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
72 Q
73SLEX ; Set Lexicon
74 S (LEXSCHG("757",0),LEXSCHG("B","757"),LEXSCHG("C","LEX","757"))="",(LEXSCHG("757.001",0),LEXSCHG("B","757.001"),LEXSCHG("C","LEX","757.001"))=""
75 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"))=""
76 S (LEXSCHG("757.1",0),LEXSCHG("B","757.1"),LEXSCHG("C","LEX","757.1"))=""
77 Q
78 ; Miscellaneous
79NF ; Import Global Not Found
80 D PB(" Import Global ^LEXM not found, consult the installation instructions")
81 D TL(" to install this global")
82 Q
83IG ; Invalid Import Global
84 D PB(" Invalid Import Global ^LEXM, please consult the installation")
85 D TL(" instructions to reload this global")
86 Q
87BL ; Blank Line
88 N X S X="" W:'$D(XPDNM) ! D:$D(XPDNM) MES^XPDUTL(X) Q
89PB(X) ; Preceeding Blank Line
90 S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !!,X D:$D(XPDNM) BMES^XPDUTL(X) Q
91TL(X) ; Text Line
92 S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !,X D:$D(XPDNM) MES^XPDUTL(X) Q
93HACK(X) ; Time
94 S X=$$NOW^XLFDT Q X
95ELAP(X1,X2) ; Elapsed Time
96 N X S X=$$FMDIFF^XLFDT(+($G(X2)),+($G(X1)),3)
97 S:X="" X="00:00:00" S X=$TR(X," ","0") S X1=X Q X1
98 Q
99KLEXM ; Subscripted Kill of ^LEXM - files only
100 N LEX S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
101 Q
102KALL ; Subscripted Kill of ^LEXM - all
103 K LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST
104 K %,%DT,C,D,D0,D1,D2,DG,DIC,DICR,DILOCKTM,DIW,IREC,J,XMDUN,XMZ,ZTSK N LEX
105 S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
106 K ^LEXM(0)
107 Q
108 ; Error Text
109ET(X) ; Save Text
110 N LEXI S LEXI=+($G(LEXE(0))),LEXI=LEXI+1,LEXE(LEXI)=$G(X),LEXE(0)=LEXI Q
111ED ; Display Text
112 N LEXI S LEXI=0 F S LEXI=$O(LEXE(LEXI)) Q:+LEXI=0 W !,LEXE(LEXI)
113 W ! K LEXE
114 Q
115 ; Case
116MIX(X) ; Mixed Case
117 S X=$G(X) N LEXT,LEXI S LEXT=""
118 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))))
119 F Q:$E(LEXT,1)'=" " S LEXT=$E(LEXT,2,$L(LEXT))
120 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
121 Q X
122UP(X) ; Uppercase
123 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
124LO(X) ; Lowercase
125 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
126WP(LEX,L) ; Wrap Text LEX with Length L
127 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
128 S TI=0,LENGTH=+($G(L)) F S TI=$O(LEX(TI)) Q:+TI'>0 D
129 . 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
130 K LEX S (CT,I)=0 F S I=$O(^UTILITY($J,"W",1,I)) Q:+I=0 D
131 . S X=$G(^UTILITY($J,"W",1,I,0)),CT=CT+1,LEX(CT)=$$TRIM(X)
132 K ^UTILITY($J,"W")
133 Q
134TRIM(X) ; Trim Spaces
135 S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
136 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
137 F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
138 Q X
Note: See TracBrowser for help on using the repository browser.