LEXXGI2 ;ISL/KER - Global Import (Protocol/Checksum/Misc) ;05/23/2017
;;2.0;LEXICON UTILITY;**25,26,28,29,46,49,50,73,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEXM N/A
; ^ORD(101, ICR 872
;
; External References
; $$FMDIFF^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; BMES^XPDUTL ICR 10141
; MES^XPDUTL ICR 10141
; EN^XQOR ICR 10101
;
; Local Variables NEWed or KILLed Elsewhere
; LEXCHG Post-Install
; LEXNOPRO Post-Install
; XPDNM KIDS install
;
Q
NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
; Uses LEXSCHG() from the Post-Install
; Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
Q:$D(LEXNOPRO) Q:'$D(LEXSCHG("ICD"))&('$D(LEXSCHG("CPT")))&('$D(LEXSCHG("LEX")))
S:$D(LEXSCHG("ICD")) LEXSCHG("ICD")=0,LEXSCHG("LEX")=0 S:$D(LEXSCHG("CPT")) LEXSCHG("CPT")=0,LEXSCHG("LEX")=0
S:'$D(LEXSCHG("ICD"))&('$D(LEXSCHG("CPT")))&($D(LEXSCHG("LEX"))) LEXSCHG("ICD")=0,LEXSCHG("CPT")=0
N X,LEXU,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP,LEXPC S LEXUP="",LEXPC=0
S:$D(LEXSCHG("ICD")) LEXUP=$G(LEXUP)_"ICD" S:$D(LEXSCHG("CPT")) LEXUP=$G(LEXUP)_"/CPT"
S:$E(LEXUP,1)="/" LEXUP=$E(LEXUP,2,$L(LEXUP)) S:$L(LEXUP) LEXUP=LEXUP_" "
S:$D(LEXSCHG("LEX")) LEXF="Lexicon" S:$D(LEXSCHG("ICD")) LEXF=$G(LEXF)_", ICD" S:$D(LEXSCHG("CPT")) 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"
Q:'$D(LEXSCHG) S LEXP=+($O(^ORD(101,"B","LEXICAL SERVICES UPDATE",0))) Q:LEXP=0 S X=LEXP_";ORD(101," D EN^XQOR
S:$G(LEXSCHG("LEX"))>0!($G(LEXSCHG("ICD"))>0)!($G(LEXSCHG("CPT"))>0) ^LEXM(0,"PRO")=$$NOW^XLFDT
S:$G(LEXSCHG("ICD"))>0!($G(LEXSCHG("CPT"))>0) LEXU="Lexicon/Code Sets Updated"
Q:+($G(^LEXM(0,"PRO")))'>0 K LEXPROC D:$L($G(LEXU)) BL,TL($G(LEXU)),BL
I +($G(LEXSCHG("LEX")))>0 D
. N X,LEXED S X=" 'LEXICAL SERVICES UPDATE' ",X=X_$J(" ",(30-$L(X)))
. S LEXED=$$EDT($G(LEXSCHG("LEX"))) S:$L(LEXED) X=X_" "_LEXED S LEXPC=+($G(LEXPC))+1 S:$L(LEXED) LEXPROC((LEXPC+1))=X
I +($G(LEXSCHG("ICD")))>0 D
. N X,LEXED S X=" 'ICD CODE UPDATE EVENT' ",X=X_$J(" ",(30-$L(X)))
. S LEXED=$$EDT($G(LEXSCHG("ICD"))) S:$L(LEXED) X=X_" "_LEXED S LEXPC=+($G(LEXPC))+1 S:$L(LEXED) LEXPROC((LEXPC+1))=X
I +($G(LEXSCHG("CPT")))>0 D
. N X,LEXED S X=" 'CPT CODE UPDATE EVENT' ",X=X_$J(" ",(30-$L(X)))
. S LEXED=$$EDT($G(LEXSCHG("CPT"))) S:$L(LEXED) X=X_" "_LEXED S LEXPC=+($G(LEXPC))+1 S:$L(LEXED) LEXPROC((LEXPC+1))=X
S:$O(LEXPROC(" "),-1)>1 LEXPROC(1)="Protocol invoked:" S:$O(LEXPROC(" "),-1)>2 LEXPROC(1)="Protocols invoked:"
S LEXPC=0 F S LEXPC=$O(LEXPROC(LEXPC)) Q:+LEXPC'>0 D
. S X=$G(LEXPROC(LEXPC)) D TL(X) D:X["Protocol" BL
S X="Subscribing applications were notified of the "_LEXUP_"update" D BL,TL(X),BL
Q
UPCHG ;
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:"") Q:'$L(LEXID)
S LEXSCHG(LEXID)=+($G(LEXSCHG(LEXID)))
Q
SCHG ; Change Array LEXSCHG (Some or all, but never nothing)
N LEXFI,LEXID K LEXSCHG S LEXCHG=0
N LEXFI S LEXFI=0 F S LEXFI=$O(^LEXM(LEXFI)) Q:+LEXFI'>0 D
. S LEXID=$S(LEXFI=80!(LEXFI=80.1):"ICD",LEXFI=81!(LEXFI=81.1)!(LEXFI=81.2)!(LEXFI=81.3):"CPT",$P(LEXFI,".",1)=757:"LEX",1:"UNK")
. S LEXSCHG(LEXFI,0)=+($G(^LEXM(LEXFI,0))),LEXSCHG("B",LEXFI)="" S LEXSCHG("C",LEXID,LEXFI)=""
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
CS ; Checksum for import global
N LEXCHK,LEXNDS,LEXVER S LEXCHK=+($G(^LEXM(0,"CHECKSUM")))
W !," Running checksum routine on the ^LEXM import global, please wait"
S LEXNDS=+($G(^LEXM(0,"NODES"))),LEXVER=+($$VC(LEXCHK,LEXNDS)) W !
W:LEXVER>0 !," Checksum is ok",! Q:LEXVER>0
I LEXVER=0 W !!," Import global ^LEXM is missing. Please obtain a copy of ^LEXM before",!," continuing." Q
I LEXVER<0 D Q
. I LEXVER'=-3 W !," Unable to verify checksum for import global ^LEXM (possibly corrupt)"
. I LEXVER=-3 W !," Import global ^LEXM failed checksum"
. W !!," Please KILL the existing import global ^LEXM from your system and"
. W !," obtain a new copy of ^LEXM before continuing with the installation."
Q
VC(X,Y) ; Verify Checksum for import global
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
S LEXCHK=+($G(X)),LEXNDS=+($G(Y)) Q:LEXCHK'>0!(LEXNDS'>0) -2 S LEXL=64,(LEXCNT,LEXLC)=0,LEXS=(+(LEXNDS\LEXL))
S:LEXS=0 LEXS=1 W:+($O(^LEXM(0)))>0 ! S (LEXC,LEXN)="^LEXM",(LEXNC,LEXGCS)=0 W " "
F S LEXN=$Q(@LEXN) Q:LEXN=""!(LEXN'[LEXC) D
. Q:LEXN="^LEXM(0,""CHECKSUM"")" Q:LEXN="^LEXM(0,""NODES"")" S LEXCNT=LEXCNT+1
. I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0
. S LEXNC=LEXNC+1,LEXD=@LEXN,LEXT=LEXN_"="_LEXD F LEXP=1:1:$L(LEXT) S LEXGCS=$A(LEXT,LEXP)*LEXP+LEXGCS
Q:LEXNC'=LEXNDS -3 Q:LEXGCS'=LEXCHK -3
Q 1
; 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(LEX1,LEX2) ; Elapsed Time
N X S X=$$FMDIFF^XLFDT(+($G(LEX2)),+($G(LEX1)),3)
S:X="" X="00:00:00" S X=$TR(X," ","0") S LEX1=X Q LEX1
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 DIC,DICR,DILOCKTM,DIW,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")
CLR ; Clear
K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LEX
K LEX1,LEX2,LEX3,LEXC,LEXCHK,LEXCNT,LEXCT,LEXD,LEXE,LEXED
K LEXF,LEXFI,LEXGCS,LEXI,LEXID,LEXL,LEXLC,LEXLEN,LEXN,LEXNC
K LEXNDS,LEXP,LEXPC,LEXPROC,LEXS,LEXSCHG,LEXT,LEXTI,LEXU
K LEXUP,LEXVER,X,Y
Q
EDT(LEX) ; External Date
S LEX=$$FMTE^XLFDT($G(LEX),"1Z") S:LEX["@" LEX=$P(LEX,"@",1)_" "_$P(LEX,"@",2,4000)
Q LEX
TRIM(X) ; Trim Spaces
N XPDNM 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXGI2 9029 printed Apr 09, 2024@21:12:59 Page 2
LEXXGI2 ;ISL/KER - Global Import (Protocol/Checksum/Misc) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**25,26,28,29,46,49,50,73,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEXM N/A
+5 ; ^ORD(101, ICR 872
+6 ;
+7 ; External References
+8 ; $$FMDIFF^XLFDT ICR 10103
+9 ; $$FMTE^XLFDT ICR 10103
+10 ; $$NOW^XLFDT ICR 10103
+11 ; BMES^XPDUTL ICR 10141
+12 ; MES^XPDUTL ICR 10141
+13 ; EN^XQOR ICR 10101
+14 ;
+15 ; Local Variables NEWed or KILLed Elsewhere
+16 ; LEXCHG Post-Install
+17 ; LEXNOPRO Post-Install
+18 ; XPDNM KIDS install
+19 ;
+20 QUIT
NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
+1 ; Uses LEXSCHG() from the Post-Install
+2 ; Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
+3 if $DATA(LEXNOPRO)
QUIT
if '$DATA(LEXSCHG("ICD"))&('$DATA(LEXSCHG("CPT")))&('$DATA(LEXSCHG("LEX")))
QUIT
+4 if $DATA(LEXSCHG("ICD"))
SET LEXSCHG("ICD")=0
SET LEXSCHG("LEX")=0
if $DATA(LEXSCHG("CPT"))
SET LEXSCHG("CPT")=0
SET LEXSCHG("LEX")=0
+5 if '$DATA(LEXSCHG("ICD"))&('$DATA(LEXSCHG("CPT")))&($DATA(LEXSCHG("LEX")))
SET LEXSCHG("ICD")=0
SET LEXSCHG("CPT")=0
+6 NEW X,LEXU,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP,LEXPC
SET LEXUP=""
SET LEXPC=0
+7 if $DATA(LEXSCHG("ICD"))
SET LEXUP=$GET(LEXUP)_"ICD"
if $DATA(LEXSCHG("CPT"))
SET LEXUP=$GET(LEXUP)_"/CPT"
+8 if $EXTRACT(LEXUP,1)="/"
SET LEXUP=$EXTRACT(LEXUP,2,$LENGTH(LEXUP))
if $LENGTH(LEXUP)
SET LEXUP=LEXUP_" "
+9 if $DATA(LEXSCHG("LEX"))
SET LEXF="Lexicon"
if $DATA(LEXSCHG("ICD"))
SET LEXF=$GET(LEXF)_", ICD"
if $DATA(LEXSCHG("CPT"))
SET LEXF=$GET(LEXF)_", CPT"
+10 if $EXTRACT($GET(LEXF),1,2)=", "
SET LEXF=$EXTRACT($GET(LEXF),3,$LENGTH($GET(LEXF)))
SET LEXF=$$TRIM(LEXF)
+11 IF $LENGTH(LEXF)
Begin DoDot:1
+12 if $LENGTH(LEXF,", ")>1
SET LEXF=$PIECE($GET(LEXF),", ",1,($LENGTH($GET(LEXF),", ")-1))_" and "_$PIECE($GET(LEXF),", ",$LENGTH($GET(LEXF),", "))
+13 if $LENGTH($PIECE(LEXF,", ",1))
SET LEXF=$GET(LEXF)_" File"_$SELECT(LEXF[", ":"s",LEXF[" and ":"s",1:"")_" Updated"
End DoDot:1
+14 SET LEXL=78-($LENGTH(LEXF)+4)
SET LEXU="Lexical Files Updated"
+15 if '$DATA(LEXSCHG)
QUIT
SET LEXP=+($ORDER(^ORD(101,"B","LEXICAL SERVICES UPDATE",0)))
if LEXP=0
QUIT
SET X=LEXP_";ORD(101,"
DO EN^XQOR
+16 if $GET(LEXSCHG("LEX"))>0!($GET(LEXSCHG("ICD"))>0)!($GET(LEXSCHG("CPT"))>0)
SET ^LEXM(0,"PRO")=$$NOW^XLFDT
+17 if $GET(LEXSCHG("ICD"))>0!($GET(LEXSCHG("CPT"))>0)
SET LEXU="Lexicon/Code Sets Updated"
+18 if +($GET(^LEXM(0,"PRO")))'>0
QUIT
KILL LEXPROC
if $LENGTH($GET(LEXU))
DO BL
DO TL($GET(LEXU))
DO BL
+19 IF +($GET(LEXSCHG("LEX")))>0
Begin DoDot:1
+20 NEW X,LEXED
SET X=" 'LEXICAL SERVICES UPDATE' "
SET X=X_$JUSTIFY(" ",(30-$LENGTH(X)))
+21 SET LEXED=$$EDT($GET(LEXSCHG("LEX")))
if $LENGTH(LEXED)
SET X=X_" "_LEXED
SET LEXPC=+($GET(LEXPC))+1
if $LENGTH(LEXED)
SET LEXPROC((LEXPC+1))=X
End DoDot:1
+22 IF +($GET(LEXSCHG("ICD")))>0
Begin DoDot:1
+23 NEW X,LEXED
SET X=" 'ICD CODE UPDATE EVENT' "
SET X=X_$JUSTIFY(" ",(30-$LENGTH(X)))
+24 SET LEXED=$$EDT($GET(LEXSCHG("ICD")))
if $LENGTH(LEXED)
SET X=X_" "_LEXED
SET LEXPC=+($GET(LEXPC))+1
if $LENGTH(LEXED)
SET LEXPROC((LEXPC+1))=X
End DoDot:1
+25 IF +($GET(LEXSCHG("CPT")))>0
Begin DoDot:1
+26 NEW X,LEXED
SET X=" 'CPT CODE UPDATE EVENT' "
SET X=X_$JUSTIFY(" ",(30-$LENGTH(X)))
+27 SET LEXED=$$EDT($GET(LEXSCHG("CPT")))
if $LENGTH(LEXED)
SET X=X_" "_LEXED
SET LEXPC=+($GET(LEXPC))+1
if $LENGTH(LEXED)
SET LEXPROC((LEXPC+1))=X
End DoDot:1
+28 if $ORDER(LEXPROC(" "),-1)>1
SET LEXPROC(1)="Protocol invoked:"
if $ORDER(LEXPROC(" "),-1)>2
SET LEXPROC(1)="Protocols invoked:"
+29 SET LEXPC=0
FOR
SET LEXPC=$ORDER(LEXPROC(LEXPC))
if +LEXPC'>0
QUIT
Begin DoDot:1
+30 SET X=$GET(LEXPROC(LEXPC))
DO TL(X)
if X["Protocol"
DO BL
End DoDot:1
+31 SET X="Subscribing applications were notified of the "_LEXUP_"update"
DO BL
DO TL(X)
DO BL
+32 QUIT
UPCHG ;
+1 if +($GET(LEXFI))'>0
QUIT
NEW LEXID
SET LEXID=$SELECT($PIECE(LEXFI,".",1)="757":"LEX",$PIECE(LEXFI,".",1)="80":"ICD",$PIECE(LEXFI,".",1)="81":"CPT",1:"")
if '$LENGTH(LEXID)
QUIT
+2 SET LEXSCHG(LEXID)=+($GET(LEXSCHG(LEXID)))
+3 QUIT
SCHG ; Change Array LEXSCHG (Some or all, but never nothing)
+1 NEW LEXFI,LEXID
KILL LEXSCHG
SET LEXCHG=0
+2 NEW LEXFI
SET LEXFI=0
FOR
SET LEXFI=$ORDER(^LEXM(LEXFI))
if +LEXFI'>0
QUIT
Begin DoDot:1
+3 SET LEXID=$SELECT(LEXFI=80!(LEXFI=80.1):"ICD",LEXFI=81!(LEXFI=81.1)!(LEXFI=81.2)!(LEXFI=81.3):"CPT",$PIECE(LEXFI,".",1)=757:"LEX",1:"UNK")
+4 SET LEXSCHG(LEXFI,0)=+($GET(^LEXM(LEXFI,0)))
SET LEXSCHG("B",LEXFI)=""
SET LEXSCHG("C",LEXID,LEXFI)=""
End DoDot:1
+5 if $DATA(LEXSCHG("C","CPT"))!($DATA(LEXSCHG("C","ICD")))
SET LEXSCHG("D","PRO")=""
+6 if $DATA(^LEXM(80))!($DATA(^LEXM(80.1)))!($DATA(^LEXM(81)))!($DATA(^LEXM(81.2)))!($DATA(^LEXM(81.3)))!($DATA(LEXSCHG("D","PRO")))
SET LEXCHG=1
SET LEXSCHG(0)=1
+7 if $ORDER(LEXSCHG(0))'>0
DO SALL
if $DATA(LEXSCHG("C","CPT"))!($DATA(LEXSCHG("C","ICD")))
SET LEXSCHG("D","PRO")=""
+8 QUIT
SALL ; Set All (ICD/CPT/Lexicon)
+1 DO SICD
DO SCPT
DO SLEX
+2 QUIT
SICD ; Set ICD
+1 SET (LEXSCHG("80",0),LEXSCHG("B","80"),LEXSCHG("C","ICD","80"))=""
SET (LEXSCHG("80.1",0),LEXSCHG("B","80.1"),LEXSCHG("C","ICD","80.1"))=""
DO SLEX
+2 QUIT
SCPT ; Set CPT
+1 SET (LEXSCHG("81",0),LEXSCHG("B","81"),LEXSCHG("C","CPT","81"))=""
SET (LEXSCHG("81.1",0),LEXSCHG("B","81.1"),LEXSCHG("C","CPT","81.1"))=""
+2 SET (LEXSCHG("81.2",0),LEXSCHG("B","81.2"),LEXSCHG("C","CPT","81.2"))=""
SET (LEXSCHG("81.3",0),LEXSCHG("B","81.3"),LEXSCHG("C","CPT","81.3"))=""
DO SLEX
+3 QUIT
SLEX ; Set Lexicon
+1 SET (LEXSCHG("757",0),LEXSCHG("B","757"),LEXSCHG("C","LEX","757"))=""
SET (LEXSCHG("757.001",0),LEXSCHG("B","757.001"),LEXSCHG("C","LEX","757.001"))=""
+2 SET (LEXSCHG("757.01",0),LEXSCHG("B","757.01"),LEXSCHG("C","LEX","757.01"))=""
SET (LEXSCHG("757.02",0),LEXSCHG("B","757.02"),LEXSCHG("C","LEX","757.02"))=""
+3 SET (LEXSCHG("757.1",0),LEXSCHG("B","757.1"),LEXSCHG("C","LEX","757.1"))=""
+4 QUIT
CS ; Checksum for import global
+1 NEW LEXCHK,LEXNDS,LEXVER
SET LEXCHK=+($GET(^LEXM(0,"CHECKSUM")))
+2 WRITE !," Running checksum routine on the ^LEXM import global, please wait"
+3 SET LEXNDS=+($GET(^LEXM(0,"NODES")))
SET LEXVER=+($$VC(LEXCHK,LEXNDS))
WRITE !
+4 if LEXVER>0
WRITE !," Checksum is ok",!
if LEXVER>0
QUIT
+5 IF LEXVER=0
WRITE !!," Import global ^LEXM is missing. Please obtain a copy of ^LEXM before",!," continuing."
QUIT
+6 IF LEXVER<0
Begin DoDot:1
+7 IF LEXVER'=-3
WRITE !," Unable to verify checksum for import global ^LEXM (possibly corrupt)"
+8 IF LEXVER=-3
WRITE !," Import global ^LEXM failed checksum"
+9 WRITE !!," Please KILL the existing import global ^LEXM from your system and"
+10 WRITE !," obtain a new copy of ^LEXM before continuing with the installation."
End DoDot:1
QUIT
+11 QUIT
VC(X,Y) ; Verify Checksum for import global
+1 if '$DATA(^LEXM)!('$DATA(^LEXM(0)))!($ORDER(^LEXM(0))'>0)
QUIT 0
NEW LEXCHK,LEXNDS,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
+2 SET LEXCHK=+($GET(X))
SET LEXNDS=+($GET(Y))
if LEXCHK'>0!(LEXNDS'>0)
QUIT -2
SET LEXL=64
SET (LEXCNT,LEXLC)=0
SET LEXS=(+(LEXNDS\LEXL))
+3 if LEXS=0
SET LEXS=1
if +($ORDER(^LEXM(0)))>0
WRITE !
SET (LEXC,LEXN)="^LEXM"
SET (LEXNC,LEXGCS)=0
WRITE " "
+4 FOR
SET LEXN=$QUERY(@LEXN)
if LEXN=""!(LEXN'[LEXC)
QUIT
Begin DoDot:1
+5 if LEXN="^LEXM(0,""CHECKSUM"")"
QUIT
if LEXN="^LEXM(0,""NODES"")"
QUIT
SET LEXCNT=LEXCNT+1
+6 IF LEXCNT'<LEXS
SET LEXLC=LEXLC+1
if LEXLC'>LEXL
WRITE "."
SET LEXCNT=0
+7 SET LEXNC=LEXNC+1
SET LEXD=@LEXN
SET LEXT=LEXN_"="_LEXD
FOR LEXP=1:1:$LENGTH(LEXT)
SET LEXGCS=$ASCII(LEXT,LEXP)*LEXP+LEXGCS
End DoDot:1
+8 if LEXNC'=LEXNDS
QUIT -3
if LEXGCS'=LEXCHK
QUIT -3
+9 QUIT 1
+10 ; Miscellaneous
NF ; Import Global Not Found
+1 DO PB(" Import Global ^LEXM not found, consult the installation instructions")
+2 DO TL(" to install this global")
+3 QUIT
IG ; Invalid Import Global
+1 DO PB(" Invalid Import Global ^LEXM, please consult the installation")
+2 DO TL(" instructions to reload this global")
+3 QUIT
BL ; Blank Line
+1 NEW X
SET X=""
if '$DATA(XPDNM)
WRITE !
if $DATA(XPDNM)
DO MES^XPDUTL(X)
QUIT
PB(X) ; Preceeding Blank Line
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT
if '$DATA(XPDNM)
WRITE !!,X
if $DATA(XPDNM)
DO BMES^XPDUTL(X)
QUIT
TL(X) ; Text Line
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT
if '$DATA(XPDNM)
WRITE !,X
if $DATA(XPDNM)
DO MES^XPDUTL(X)
QUIT
HACK(X) ; Time
+1 SET X=$$NOW^XLFDT
QUIT X
ELAP(LEX1,LEX2) ; Elapsed Time
+1 NEW X
SET X=$$FMDIFF^XLFDT(+($GET(LEX2)),+($GET(LEX1)),3)
+2 if X=""
SET X="00:00:00"
SET X=$TRANSLATE(X," ","0")
SET LEX1=X
QUIT LEX1
+3 QUIT
KLEXM ; Subscripted Kill of ^LEXM - files only
+1 NEW LEX
SET LEX=0
FOR
SET LEX=$ORDER(^LEXM(LEX))
if +LEX'>0
QUIT
KILL ^LEXM(LEX)
+2 QUIT
KALL ; Subscripted Kill of ^LEXM - all
+1 KILL LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST
+2 KILL DIC,DICR,DILOCKTM,DIW,XMDUN,XMZ,ZTSK
+3 NEW LEX
SET LEX=0
FOR
SET LEX=$ORDER(^LEXM(LEX))
if +LEX'>0
QUIT
KILL ^LEXM(LEX)
+4 KILL ^LEXM(0)
+5 QUIT
+6 ; Error Text
ET(X) ; Save Text
+1 NEW LEXI
SET LEXI=+($GET(LEXE(0)))
SET LEXI=LEXI+1
SET LEXE(LEXI)=$GET(X)
SET LEXE(0)=LEXI
QUIT
ED ; Display Text
+1 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXE(LEXI))
if +LEXI=0
QUIT
WRITE !,LEXE(LEXI)
+2 WRITE !
KILL LEXE
+3 QUIT
+4 ; Case
MIX(X) ; Mixed Case
+1 SET X=$GET(X)
NEW LEXT,LEXI
SET LEXT=""
+2 FOR LEXI=1:1:$LENGTH(X," ")
SET LEXT=LEXT_" "_$$UP($EXTRACT($PIECE(X," ",LEXI),1))_$$LO($EXTRACT($PIECE(X," ",LEXI),2,$LENGTH($PIECE(X," ",LEXI))))
+3 FOR
if $EXTRACT(LEXT,1)'=" "
QUIT
SET LEXT=$EXTRACT(LEXT,2,$LENGTH(LEXT))
+4 if $EXTRACT(LEXT,1,3)="Cpt"
SET LEXT="CPT"_$EXTRACT(LEXT,4,$LENGTH(LEXT))
if $EXTRACT(LEXT,1,3)="Icd"
SET LEXT="ICD"_$EXTRACT(LEXT,4,$LENGTH(LEXT))
SET X=LEXT
+5 QUIT X
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LO(X) ; Lowercase
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
CLR ; Clear
+1 KILL DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LEX
+2 KILL LEX1,LEX2,LEX3,LEXC,LEXCHK,LEXCNT,LEXCT,LEXD,LEXE,LEXED
+3 KILL LEXF,LEXFI,LEXGCS,LEXI,LEXID,LEXL,LEXLC,LEXLEN,LEXN,LEXNC
+4 KILL LEXNDS,LEXP,LEXPC,LEXPROC,LEXS,LEXSCHG,LEXT,LEXTI,LEXU
+5 KILL LEXUP,LEXVER,X,Y
+6 QUIT
EDT(LEX) ; External Date
+1 SET LEX=$$FMTE^XLFDT($GET(LEX),"1Z")
if LEX["@"
SET LEX=$PIECE(LEX,"@",1)_" "_$PIECE(LEX,"@",2,4000)
+2 QUIT LEX
TRIM(X) ; Trim Spaces
+1 NEW XPDNM
SET X=$GET(X)
if X=""
QUIT X
FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 FOR
if X'[" "
QUIT
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,229)
+4 QUIT X
