139 lines
6.9 KiB
Mathematica
139 lines
6.9 KiB
Mathematica
LEXXGI2 ; ISL/KER - Global Import (Update Change File w/^LEXM) ; 02/22/2007
|
|
;;2.0;LEXICON UTILITY;**25,26,28,29,46,49**;Sep 23, 1996;Build 3
|
|
;
|
|
; Global Variables
|
|
; ^LEXM(
|
|
; DBIA 10011 ^UTILITY($J
|
|
;
|
|
; External References
|
|
; DBIA 10011 ^DIWP
|
|
; DBIA 10103 $$NOW^XLFDT
|
|
; DBIA 10103 $$FMDIFF^XLFDT
|
|
; DBIA 10141 BMES^XPDUTL
|
|
; DBIA 10141 MES^XPDUTL
|
|
;
|
|
; XPDNM Newed by KIDS during Install
|
|
Q
|
|
NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
|
|
; Uses LEXSCHG() from the Post-Install
|
|
; Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
|
|
W !!,"NOTIFY^LEXXGI1",!
|
|
N X,LEXU,LEXT,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP D:$O(LEXSCHG(0))'>0 SCHG
|
|
S LEXUP="" S:$D(LEXSCHG("C","ICD"))!($D(LEXSCHG(80)))!($D(LEXSCHG(80.1))) LEXUP=$G(LEXUP)_"ICD"
|
|
S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG(81)))!($D(LEXSCHG(81.3))) LEXUP=$G(LEXUP)_"/CPT"
|
|
S:$E(LEXUP,1)="/" LEXUP=$E(LEXUP,2,$L(LEXUP)) S:$L(LEXUP) LEXUP=LEXUP_" "
|
|
S LEXI=756.999999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="757") S LEXT=$G(LEXT)_", "_LEXI
|
|
S LEXI=79.9990999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="80") S LEXT=$G(LEXT)_", "_LEXI
|
|
S LEXI=80.9990999 F S LEXI=$O(LEXSCHG(LEXI)) Q:+LEXI'>0!($P(LEXI,".",1)'="81") S LEXT=$G(LEXT)_", "_LEXI
|
|
S:$E($G(LEXT),1,2)=", " LEXT=$E($G(LEXT),3,$L($G(LEXT))),LEXT=$$TRIM(LEXT)
|
|
I $L(LEXT) D
|
|
. S:$L(LEXT,", ")>1 LEXT=$P($G(LEXT),", ",1,($L($G(LEXT),", ")-1))_" and "_$P($G(LEXT),", ",$L($G(LEXT),", "))
|
|
S:$P($O(LEXSCHG(756.999999)),".",1)="757" LEXF="Lexicon" S:$P($O(LEXSCHG(79.999999)),".",1)=80 LEXF=$G(LEXF)_", ICD"
|
|
S:$P($O(LEXSCHG(80.999999)),".",1)=81 LEXF=$G(LEXF)_", CPT"
|
|
S:$E($G(LEXF),1,2)=", " LEXF=$E($G(LEXF),3,$L($G(LEXF))),LEXF=$$TRIM(LEXF)
|
|
I $L(LEXF) D
|
|
. S:$L(LEXF,", ")>1 LEXF=$P($G(LEXF),", ",1,($L($G(LEXF),", ")-1))_" and "_$P($G(LEXF),", ",$L($G(LEXF),", "))
|
|
. S:$L($P(LEXF,", ",1)) LEXF=$G(LEXF)_" File"_$S(LEXF[", ":"s",LEXF[" and ":"s",1:"")_" Updated"
|
|
S LEXL=78-($L(LEXF)+4),LEXU="Lexical Files Updated" I $L(LEXT)&($L(LEXF))&(LEXL>30) D
|
|
. S LEXU=LEXF N LEX S LEX=LEXT K LEXT S LEXT(1)=LEX D WP(.LEXT,LEXL)
|
|
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
|
|
Q:+($G(^LEXM(0,"PRO")))'>0
|
|
I $L($G(LEXU)) D
|
|
. N LEXI S LEXI=$L($G(LEXU))+3
|
|
. S X=$G(LEXU) D:$O(LEXT(0))'>0 BL,TL(X),BL I $O(LEXT(0))>0 D
|
|
. . D BL S X=$G(LEXU)_": " N LEX S LEX=0 F S LEX=$O(LEXT(LEX)) Q:+LEX'>0 D
|
|
. . . N LEXX S LEXX=$$TRIM($G(LEXT(LEX))) S:$L(LEXX) X=X_LEXX D TL(X) S X="",$P(X," ",+LEXI)=" "
|
|
. . D BL
|
|
S X="Protocol 'LEXICAL SERVICES UPDATE' was invoked" D TL(X)
|
|
S X="Subscribing applications were notified of the "_LEXUP_"update" D TL(X),BL
|
|
Q
|
|
UPCHG ;
|
|
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")
|
|
I $D(LEXSCHG) S LEXSCHG(LEXFI,0)="",LEXSCHG("B",LEXFI)="",LEXSCHG("C",LEXID,LEXFI)=""
|
|
Q
|
|
SCHG ; Change Array LEXSCHG (Some or all, but never nothing)
|
|
N FI,ID K LEXSCHG S LEXCHG=0
|
|
N FI S FI=0 F S FI=$O(^LEXM(FI)) Q:+FI'>0 D
|
|
. 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")
|
|
. S LEXSCHG(FI,0)=+($G(^LEXM(FI,0))),LEXSCHG("B",FI)="" S LEXSCHG("C",ID,FI)=""
|
|
S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
|
|
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
|
|
D:$O(LEXSCHG(0))'>0 SALL S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
|
|
Q
|
|
SALL ; Set All (ICD/CPT/Lexicon)
|
|
D SICD,SCPT,SLEX
|
|
Q
|
|
SICD ; Set ICD
|
|
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
|
|
Q
|
|
SCPT ; Set CPT
|
|
S (LEXSCHG("81",0),LEXSCHG("B","81"),LEXSCHG("C","CPT","81"))="",(LEXSCHG("81.1",0),LEXSCHG("B","81.1"),LEXSCHG("C","CPT","81.1"))=""
|
|
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
|
|
Q
|
|
SLEX ; Set Lexicon
|
|
S (LEXSCHG("757",0),LEXSCHG("B","757"),LEXSCHG("C","LEX","757"))="",(LEXSCHG("757.001",0),LEXSCHG("B","757.001"),LEXSCHG("C","LEX","757.001"))=""
|
|
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"))=""
|
|
S (LEXSCHG("757.1",0),LEXSCHG("B","757.1"),LEXSCHG("C","LEX","757.1"))=""
|
|
Q
|
|
; Miscellaneous
|
|
NF ; Import Global Not Found
|
|
D PB(" Import Global ^LEXM not found, consult the installation instructions")
|
|
D TL(" to install this global")
|
|
Q
|
|
IG ; Invalid Import Global
|
|
D PB(" Invalid Import Global ^LEXM, please consult the installation")
|
|
D TL(" instructions to reload this global")
|
|
Q
|
|
BL ; Blank Line
|
|
N X S X="" W:'$D(XPDNM) ! D:$D(XPDNM) MES^XPDUTL(X) Q
|
|
PB(X) ; Preceeding Blank Line
|
|
S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !!,X D:$D(XPDNM) BMES^XPDUTL(X) Q
|
|
TL(X) ; Text Line
|
|
S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !,X D:$D(XPDNM) MES^XPDUTL(X) Q
|
|
HACK(X) ; Time
|
|
S X=$$NOW^XLFDT Q X
|
|
ELAP(X1,X2) ; Elapsed Time
|
|
N X S X=$$FMDIFF^XLFDT(+($G(X2)),+($G(X1)),3)
|
|
S:X="" X="00:00:00" S X=$TR(X," ","0") S X1=X Q X1
|
|
Q
|
|
KLEXM ; Subscripted Kill of ^LEXM - files only
|
|
N LEX S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
|
|
Q
|
|
KALL ; Subscripted Kill of ^LEXM - all
|
|
K LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST
|
|
K %,%DT,C,D,D0,D1,D2,DG,DIC,DICR,DILOCKTM,DIW,IREC,J,XMDUN,XMZ,ZTSK N LEX
|
|
S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
|
|
K ^LEXM(0)
|
|
Q
|
|
; Error Text
|
|
ET(X) ; Save Text
|
|
N LEXI S LEXI=+($G(LEXE(0))),LEXI=LEXI+1,LEXE(LEXI)=$G(X),LEXE(0)=LEXI Q
|
|
ED ; Display Text
|
|
N LEXI S LEXI=0 F S LEXI=$O(LEXE(LEXI)) Q:+LEXI=0 W !,LEXE(LEXI)
|
|
W ! K LEXE
|
|
Q
|
|
; Case
|
|
MIX(X) ; Mixed Case
|
|
S X=$G(X) N LEXT,LEXI S LEXT=""
|
|
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))))
|
|
F Q:$E(LEXT,1)'=" " S LEXT=$E(LEXT,2,$L(LEXT))
|
|
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
|
|
Q X
|
|
UP(X) ; Uppercase
|
|
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|
LO(X) ; Lowercase
|
|
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|
|
WP(LEX,L) ; Wrap Text LEX with Length L
|
|
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
|
|
S TI=0,LENGTH=+($G(L)) F S TI=$O(LEX(TI)) Q:+TI'>0 D
|
|
. 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
|
|
K LEX S (CT,I)=0 F S I=$O(^UTILITY($J,"W",1,I)) Q:+I=0 D
|
|
. S X=$G(^UTILITY($J,"W",1,I,0)),CT=CT+1,LEX(CT)=$$TRIM(X)
|
|
K ^UTILITY($J,"W")
|
|
Q
|
|
TRIM(X) ; Trim Spaces
|
|
S X=$G(X) Q:X="" 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))
|
|
F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
|
|
Q X
|