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

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