LEXXGU ;ISL/KER - Global Uninstall (^LEXU) ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
Q
;
; Global Variables
; ^%ZOSF("UCI") ICR 10096
; ^LEXU N/A
; ^TMP("LEXXGUM" SACC 2.3.2.5.1
;
; External References
; HOME^%ZIS ICR 10086
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
; $$FMDIFF^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$PATCH^XPDUTL ICR 10141
; $$VERSION^XPDUTL ICR 10141
; $$PROD^XUPROD ICR 4440
;
LEXU ; Uninstall a patch Installed by ^LEXM
N LEXENV S LEXENV=$$ENV Q:'LEXENV N LEXBEG,LEXBLD,LEXBOK,LEXCHK,LEXELP,LEXEND,LEXKIL,LEXL,LEXLN,LEXNDS,LEXPIE,LEXSUB,LEXT,LEXTMP,LEXTXT,LEXUNDO
N LEXUOK,LEXVER,LEXVR K ^TMP("LEXXGUM",$J) W:$L($G(IOF)) @IOF S LEXBEG=$$NOW^XLFDT,LEXVR=$$VERSION^XPDUTL("LEX"),LEXBLD=$G(^LEXU(0,"BUILD"))
I '$D(^LEXU)!($L(LEXBLD,"*")'=3)!($P(LEXBLD,"*",1)'="LEX")!($P(LEXBLD,"*",2)'=LEXVR)!($P(LEXBLD,"*",3)'?1N.N) D Q
. N LEXTXT,LEXLN S LEXTXT="Uninstall a Patch",$P(LEXLN,"=",$L(LEXTXT))="=" W !," ",LEXTXT,!," ",LEXLN
. W !!," Undo-Global ^LEXU is missing or invalid. Please obtain a copy ",!," of ^LEXU before continuing.",! Q
S LEXTXT="Uninstall a Patch" S:$L(LEXBLD,"*")=3 LEXTXT="Uninstall Patch "_LEXBLD S $P(LEXLN,"=",$L(LEXTXT))="=" W !," ",LEXTXT,!," ",LEXLN
S LEXBOK=$$BOK(LEXBLD) I +($G(LEXBOK))'>0!($L(LEXBLD,"*")'=3) D Q
. W !!," Undo-Global ^LEXU is invalid. Please obtain a valid copy of ^LEXU",!," before continuing.",! Q
S LEXUOK=$$CHK^LEXXGU2 I "^1^"'[("^"_LEXUOK_"^") W !!," Uninstall of patch ",LEXBLD," was aborted. Undo-Global ^LEXU",!," was not deleted.",! Q
S LEXKIL=$$KOK I "^1^0^"'[("^"_LEXKIL_"^") W !!," Uninstall of patch ",LEXBLD," was aborted. Undo-Global ^LEXU",!," was not deleted.",! Q
W !!," Running checksum routine on the Undo-Global ^LEXU, please wait"
S LEXTXT="Uninstall Patch "_LEXBLD,LEXLN="" S $P(LEXLN,"-",$L(LEXTXT))="-" D MT(" "),MT((" "_LEXTXT)),MT((" "_LEXLN)),MT(" ")
S LEXCHK=+($G(^LEXU(0,"CHECKSUM"))),LEXNDS=+($G(^LEXU(0,"NODES"))) S LEXVER=$$VC(LEXCHK,LEXNDS) W !
I LEXVER>0 D
. W !," Checksum is ok",! N LEXTMP,LEXTXT,LEXUNDO S LEXUNDO=0
. S LEXTMP=$$FMTE^XLFDT($$NOW^XLFDT) S:LEXTMP["@" LEXTMP=$P(LEXTMP,"@",1)_" "_$P(LEXTMP,"@",2) S LEXTXT=" As of: "_LEXTMP D MT(LEXTXT)
. S LEXTMP=$$UCI I $L(LEXTMP) S LEXTXT=" In Account: "_LEXTMP D MT(LEXTXT)
. S LEXTMP=$$P I $L(LEXTMP) S LEXTXT=" Maint by: "_LEXTMP D MT(LEXTXT)
. S LEXTXT=" Build: "_$G(LEXBLD) D MT(LEXTXT)
. S LEXTMP=$$FMTE^XLFDT($P($$INSD^LEXXGU2(LEXBLD),"^",1)) S:LEXTMP["@" LEXTMP=$P(LEXTMP,"@",1)_" "_$P(LEXTMP,"@",2)
. S LEXTXT=" Installed on: "_LEXTMP D MT(LEXTXT)
. S LEXTMP="Passed",LEXTMP=LEXTMP_$J(" ",(26-$L(LEXTMP)))_" "_LEXCHK
. S LEXTXT=" Checksum: "_LEXTMP D MT(LEXTXT)
. D FILES^LEXXGU2,UNIN^LEXXGU2
. I $G(LEXUNDO)>0 S LEXTXT=" Uninstall: Complete" D MT(LEXTXT)
. I $G(LEXUNDO)'>0 S LEXTXT=" Uninstall: Incomplete" D MT(LEXTXT)
. S LEXEND=$$NOW^XLFDT I $P($G(LEXBEG),".",1)?7N,$P($G(LEXEND),".",1)?7N D
. . I $G(LEXBEG)=$G(LEXEND) H 1 S LEXEND=$$NOW^XLFDT
. . S LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3) N LEXPIE S LEXPIE=$$TM($P(LEXELP,":",1))
. . S:$L(LEXPIE)<2 LEXPIE="0"_LEXPIE S:$L(LEXPIE)<2 LEXPIE="0"_LEXPIE
. . S $P(LEXELP,":",1)=LEXPIE
. . S LEXTXT=" Start: "_$TR($$FMTE^XLFDT(LEXBEG,"5Z"),"@"," ") D MT(" "),MT(LEXTXT) W !!," ",$$TM(LEXTXT)
. . S LEXTXT=" Finished: "_$TR($$FMTE^XLFDT(LEXEND,"5Z"),"@"," ") D MT(LEXTXT) W !," ",$$TM(LEXTXT)
. . S LEXTXT=" Elapsed: "_LEXELP D MT(LEXTXT),MT(" ") W !," ",$$TM(LEXTXT)
. S LEXSUB=LEXBLD_" Uninstall" D MAIL^LEXXGU2
I LEXVER=0 W !!," Undo-Global ^LEXU is missing. Please obtain a copy of ^LEXU before",!," continuing." Q
I LEXVER<0 D Q
. I LEXVER'=-3 W !," Unable to verify checksum for Undo-Global ^LEXU (possibly corrupt)"
. I LEXVER=-3 W !," Undo-Global ^LEXU failed checksum"
. W !!," Please KILL the existing Undo-Global ^LEXU from your system and"
. W !," obtain a new copy of ^LEXU before continuing with the installation."
D KILL
Q
CHECKSUM ; Checksum for Undo-Global ^LEXU
N LEXCHK,LEXNDS,LEXVER,LEXBLD,LEXBOK W !," Running checksum routine on the Undo-Global ^LEXU, please wait"
I '$D(^LEXU) H 1 W !," Undo-Global ^LEXU is missing. Please obtain a copy of ^LEXU before",!," continuing.",! Q
S LEXBLD=$G(^LEXU(0,"BUILD")) I '$L(LEXBLD) H 1 W !," Undo-Global Build is missing. Please obtain a copy of ^LEXU before",!," continuing.",! Q
S LEXBOK=0 S:$L(LEXBLD) LEXBOK=$$BOK(LEXBLD) I +($G(LEXBOK))'>0 W " Please obtain a valid ",!," copy of ^LEXU before continuing.",! Q
S LEXCHK=+($G(^LEXU(0,"CHECKSUM"))),LEXNDS=+($G(^LEXU(0,"NODES"))),LEXVER=+($$VC(LEXCHK,LEXNDS)) W !
W:LEXVER>0 !," Checksum is ok",! Q:LEXVER>0
I LEXVER=0 H 1 W !," Undo-Global ^LEXU is missing. Please obtain a copy of ^LEXU before",!," continuing.",! Q
I LEXVER<0 D Q
. I LEXVER'=-3 W !," Unable to verify checksum for Undo-Global ^LEXU (possibly corrupt)",!
. I LEXVER=-3 W !," Undo-Global ^LEXU failed checksum",!
. W !!," Please KILL the existing Undo-Global ^LEXU from your system and"
. W !," obtain a new copy of ^LEXU before continuing with the installation.",!
Q
VC(X,Y) ; Verify Checksum for import global
Q:'$D(^LEXU) 0 Q:'$D(^LEXU(0)) 0 Q:$O(^LEXU(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(^LEXU(0)))>0 ! S (LEXC,LEXN)="^LEXU",(LEXNC,LEXGCS)=0 W " "
F S LEXN=$Q(@LEXN) Q:LEXN=""!(LEXN'[LEXC) D
. Q:LEXN="^LEXU(0,""CHECKSUM"")" Q:LEXN="^LEXU(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
BOK(X) ; Build is OK
N LEXB,LEXBLD,LEXFI,LEXI,LEXOUT,LEXPKG,LEXR,LEXREV,LEXVER,LEXVR,LEXVRRV
S LEXVR=$$VERSION^XPDUTL("LEX"),LEXOUT="" S LEXBLD=$G(X),LEXVER=$P(LEXBLD,"*",2)
S LEXREV=$P(LEXBLD,"*",3),LEXPKG=$P(LEXBLD,"*",1) I LEXVER'=LEXVR D Q
. W !!," Invalid Undo-Global ^LEXU (wrong version, """_LEXVER_""")"
I LEXPKG'="LEX" W !!," Invalid Undo-Global ^LEXU (wrong package, """_LEXPKG_""")" Q 0
F LEXFI=757,757.001,757.01,757.02,757.03,757.1,757.21 D
. N LEXVRRV,LEXB,LEXR,LEXI S LEXVRRV=$G(@("^DD("_+LEXFI_",0,""VRRV"")")),LEXR=$P(LEXVRRV,"^",1)
. Q:+LEXR'>0 Q:+LEXR'>LEXOUT S LEXB="LEX*"_LEXVER_"*"_LEXR,LEXI=$$PATCH^XPDUTL(LEXB)
. Q:LEXI'>0 S LEXOUT=+LEXR
I +LEXREV<+LEXOUT W !!," Invalid Undo-Global ^LEXU (old revision, """_+LEXREV_""")" Q 0
I LEXREV'=LEXOUT W !!," Invalid Undo-Global ^LEXU (wrong revision, """_+LEXREV_""")" Q 0
Q 1
UOK(X) ; Uninstall is Ok for Build X
N DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,LEXBLD S LEXBLD=$G(X)
S:$L(LEXBLD) DIR("A")=" Uninstall patch "_LEXBLD_" (Y/N): "
S:'$L(LEXBLD) DIR("A")=" Uninstall patch (Y/N): "
S DIR("B")="NO",DIR(0)="YAO" W ! D ^DIR
S X=+Y S:"^1^0^"'[("^"_Y_"^") X="^"
Q X
KOK(X) ; Kill Undo-Global ^LEXU Ok
N DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,LEXBLD S LEXBLD=$G(X)
S DIR("A")=" Kill Undo-Global ^LEXU when uninstall is complete (Y/N): "
S DIR("B")="NO",DIR(0)="YAO" W ! D ^DIR
S X=+Y S:"^1^0^"'[("^"_Y_"^") X="^"
Q X
MT(X) ; Message Text
N LEXI S LEXI=$O(^TMP("LEXXGUM",$J," "),-1)+1,^TMP("LEXXGUM",$J,LEXI)=$G(X)
Q
KILL ; Kill Undo-Global ^LEXU
Q:+($G(LEXKIL))'>0 K ^LEXU(0) N LEXFI S LEXFI=0 F S LEXFI=$O(^LEXU(LEXFI)) Q:+LEXFI'>0 K ^LEXU(LEXFI)
Q
P(X) ; Person
N LEXDUZ,LEXF,LEXL,LEXNM,LEXP,LEXPH
S LEXDUZ=+($G(DUZ)),LEXNM=$$GET1^DIQ(200,+($G(LEXDUZ)),.01) Q:'$L(LEXNM) "UNKNOWN^"
S LEXDUZ=+($G(DUZ)) S LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.132)
S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.133)
S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.134)
S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.135)
S LEXDUZ=$$PM(LEXNM)
S X=LEXDUZ,X=X_$J(" ",(26-$L(X)))_" "_LEXPH
Q X
PM(X) ; Person, Mixed Case
N LEXF,LEXL,LEXP S LEXP=$G(X),LEXL=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
S LEXL(1)=$$MX($P(LEXL,"-",1)),LEXL(2)=$$MX($P(LEXL(1)," ",2,2)),LEXL(1)=$$MX($P(LEXL(1)," ",1))
S:$L(LEXL(1))&($L(LEXL(2))) LEXL(1)=LEXL(1)_" "_LEXL(2)
S LEXL(3)=$$MX($P(LEXL,"-",2)),LEXL(4)=$$MX($P(LEXL(3)," ",2,2)),LEXL(3)=$$MX($P(LEXL(3)," ",1))
S:$L(LEXL(3))&($L(LEXL(4))) LEXL(3)=LEXL(3)_" "_LEXL(4)
S LEXL=LEXL(1) S:$L(LEXL(1))&($L(LEXL(3))) LEXL=LEXL(1)_"-"_LEXL(3)
S LEXF=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
S LEXF(1)=$$MX($P(LEXF,"-",1)),LEXF(2)=$$MX($P(LEXF(1)," ",2,2)),LEXF(1)=$$MX($P(LEXF(1)," ",1))
S:$L(LEXF(1))&($L(LEXF(2))) LEXF(1)=LEXF(1)_" "_LEXF(2)
S LEXF(3)=$$MX($P(LEXF,"-",2)),LEXF(4)=$$MX($P(LEXF(3)," ",2,2)),LEXF(3)=$$MX($P(LEXF(3)," ",1))
S:$L(LEXF(3))&($L(LEXF(4))) LEXF(3)=LEXF(3)_" "_LEXF(4)
S LEXF=LEXF(1) S:$L(LEXF(1))&($L(LEXF(3))) LEXF=LEXF(1)_"-"_LEXF(3)
S LEXP=LEXL_", "_LEXF,X=LEXP
Q X
MX(X) ; Mix Case
Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UCI(X) ; UCI where Lexicon is installed
N LEXP,LEXT,LEXU,Y X ^%ZOSF("UCI") S LEXU=Y,LEXP=""
S LEXP=$S($$PROD^XUPROD(1):"Production",1:"Test Account")
S:LEXU[","&($L($P(LEXU,",",1))>3) LEXU=$P(LEXU,",",1)
S X=LEXU I $L(LEXP) S X=X_$J(" ",(26-$L(X)))_" "_LEXP
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
SH ; Show Text
W ! N LEXNN,LEXNC S LEXNN="^TMP(""LEXXGUM"","_$J_")",LEXNC="^TMP(""LEXXGUM"","_$J_","
F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) W !,@LEXNN
W ! Q
ENV(X) ; Environment
D HOME^%ZIS S U="^",DT=$$DT^XLFDT,DTIME=300 K POP
N LEXNM S LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
I '$L($G(LEXNM)) W !!,?5,"Invalid/Missing DUZ" Q 0
S:$G(DUZ(0))'["@" DUZ(0)=$G(DUZ(0))_"@"
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXGU 10427 printed Sep 23, 2025@19:46:11 Page 2
LEXXGU ;ISL/KER - Global Uninstall (^LEXU) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 QUIT
+3 ;
+4 ; Global Variables
+5 ; ^%ZOSF("UCI") ICR 10096
+6 ; ^LEXU N/A
+7 ; ^TMP("LEXXGUM" SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; HOME^%ZIS ICR 10086
+11 ; $$GET1^DIQ ICR 2056
+12 ; ^DIR ICR 10026
+13 ; $$DT^XLFDT ICR 10103
+14 ; $$FMDIFF^XLFDT ICR 10103
+15 ; $$FMTE^XLFDT ICR 10103
+16 ; $$NOW^XLFDT ICR 10103
+17 ; $$PATCH^XPDUTL ICR 10141
+18 ; $$VERSION^XPDUTL ICR 10141
+19 ; $$PROD^XUPROD ICR 4440
+20 ;
LEXU ; Uninstall a patch Installed by ^LEXM
+1 NEW LEXENV
SET LEXENV=$$ENV
if 'LEXENV
QUIT
NEW LEXBEG,LEXBLD,LEXBOK,LEXCHK,LEXELP,LEXEND,LEXKIL,LEXL,LEXLN,LEXNDS,LEXPIE,LEXSUB,LEXT,LEXTMP,LEXTXT,LEXUNDO
+2 NEW LEXUOK,LEXVER,LEXVR
KILL ^TMP("LEXXGUM",$JOB)
if $LENGTH($GET(IOF))
WRITE @IOF
SET LEXBEG=$$NOW^XLFDT
SET LEXVR=$$VERSION^XPDUTL("LEX")
SET LEXBLD=$GET(^LEXU(0,"BUILD"))
+3 IF '$DATA(^LEXU)!($LENGTH(LEXBLD,"*")'=3)!($PIECE(LEXBLD,"*",1)'="LEX")!($PIECE(LEXBLD,"*",2)'=LEXVR)!($PIECE(LEXBLD,"*",3)'?1N.N)
Begin DoDot:1
+4 NEW LEXTXT,LEXLN
SET LEXTXT="Uninstall a Patch"
SET $PIECE(LEXLN,"=",$LENGTH(LEXTXT))="="
WRITE !," ",LEXTXT,!," ",LEXLN
+5 WRITE !!," Undo-Global ^LEXU is missing or invalid. Please obtain a copy ",!," of ^LEXU before continuing.",!
QUIT
End DoDot:1
QUIT
+6 SET LEXTXT="Uninstall a Patch"
if $LENGTH(LEXBLD,"*")=3
SET LEXTXT="Uninstall Patch "_LEXBLD
SET $PIECE(LEXLN,"=",$LENGTH(LEXTXT))="="
WRITE !," ",LEXTXT,!," ",LEXLN
+7 SET LEXBOK=$$BOK(LEXBLD)
IF +($GET(LEXBOK))'>0!($LENGTH(LEXBLD,"*")'=3)
Begin DoDot:1
+8 WRITE !!," Undo-Global ^LEXU is invalid. Please obtain a valid copy of ^LEXU",!," before continuing.",!
QUIT
End DoDot:1
QUIT
+9 SET LEXUOK=$$CHK^LEXXGU2
IF "^1^"'[("^"_LEXUOK_"^")
WRITE !!," Uninstall of patch ",LEXBLD," was aborted. Undo-Global ^LEXU",!," was not deleted.",!
QUIT
+10 SET LEXKIL=$$KOK
IF "^1^0^"'[("^"_LEXKIL_"^")
WRITE !!," Uninstall of patch ",LEXBLD," was aborted. Undo-Global ^LEXU",!," was not deleted.",!
QUIT
+11 WRITE !!," Running checksum routine on the Undo-Global ^LEXU, please wait"
+12 SET LEXTXT="Uninstall Patch "_LEXBLD
SET LEXLN=""
SET $PIECE(LEXLN,"-",$LENGTH(LEXTXT))="-"
DO MT(" ")
DO MT((" "_LEXTXT))
DO MT((" "_LEXLN))
DO MT(" ")
+13 SET LEXCHK=+($GET(^LEXU(0,"CHECKSUM")))
SET LEXNDS=+($GET(^LEXU(0,"NODES")))
SET LEXVER=$$VC(LEXCHK,LEXNDS)
WRITE !
+14 IF LEXVER>0
Begin DoDot:1
+15 WRITE !," Checksum is ok",!
NEW LEXTMP,LEXTXT,LEXUNDO
SET LEXUNDO=0
+16 SET LEXTMP=$$FMTE^XLFDT($$NOW^XLFDT)
if LEXTMP["@"
SET LEXTMP=$PIECE(LEXTMP,"@",1)_" "_$PIECE(LEXTMP,"@",2)
SET LEXTXT=" As of: "_LEXTMP
DO MT(LEXTXT)
+17 SET LEXTMP=$$UCI
IF $LENGTH(LEXTMP)
SET LEXTXT=" In Account: "_LEXTMP
DO MT(LEXTXT)
+18 SET LEXTMP=$$P
IF $LENGTH(LEXTMP)
SET LEXTXT=" Maint by: "_LEXTMP
DO MT(LEXTXT)
+19 SET LEXTXT=" Build: "_$GET(LEXBLD)
DO MT(LEXTXT)
+20 SET LEXTMP=$$FMTE^XLFDT($PIECE($$INSD^LEXXGU2(LEXBLD),"^",1))
if LEXTMP["@"
SET LEXTMP=$PIECE(LEXTMP,"@",1)_" "_$PIECE(LEXTMP,"@",2)
+21 SET LEXTXT=" Installed on: "_LEXTMP
DO MT(LEXTXT)
+22 SET LEXTMP="Passed"
SET LEXTMP=LEXTMP_$JUSTIFY(" ",(26-$LENGTH(LEXTMP)))_" "_LEXCHK
+23 SET LEXTXT=" Checksum: "_LEXTMP
DO MT(LEXTXT)
+24 DO FILES^LEXXGU2
DO UNIN^LEXXGU2
+25 IF $GET(LEXUNDO)>0
SET LEXTXT=" Uninstall: Complete"
DO MT(LEXTXT)
+26 IF $GET(LEXUNDO)'>0
SET LEXTXT=" Uninstall: Incomplete"
DO MT(LEXTXT)
+27 SET LEXEND=$$NOW^XLFDT
IF $PIECE($GET(LEXBEG),".",1)?7N
IF $PIECE($GET(LEXEND),".",1)?7N
Begin DoDot:2
+28 IF $GET(LEXBEG)=$GET(LEXEND)
HANG 1
SET LEXEND=$$NOW^XLFDT
+29 SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
NEW LEXPIE
SET LEXPIE=$$TM($PIECE(LEXELP,":",1))
+30 if $LENGTH(LEXPIE)<2
SET LEXPIE="0"_LEXPIE
if $LENGTH(LEXPIE)<2
SET LEXPIE="0"_LEXPIE
+31 SET $PIECE(LEXELP,":",1)=LEXPIE
+32 SET LEXTXT=" Start: "_$TRANSLATE($$FMTE^XLFDT(LEXBEG,"5Z"),"@"," ")
DO MT(" ")
DO MT(LEXTXT)
WRITE !!," ",$$TM(LEXTXT)
+33 SET LEXTXT=" Finished: "_$TRANSLATE($$FMTE^XLFDT(LEXEND,"5Z"),"@"," ")
DO MT(LEXTXT)
WRITE !," ",$$TM(LEXTXT)
+34 SET LEXTXT=" Elapsed: "_LEXELP
DO MT(LEXTXT)
DO MT(" ")
WRITE !," ",$$TM(LEXTXT)
End DoDot:2
+35 SET LEXSUB=LEXBLD_" Uninstall"
DO MAIL^LEXXGU2
End DoDot:1
+36 IF LEXVER=0
WRITE !!," Undo-Global ^LEXU is missing. Please obtain a copy of ^LEXU before",!," continuing."
QUIT
+37 IF LEXVER<0
Begin DoDot:1
+38 IF LEXVER'=-3
WRITE !," Unable to verify checksum for Undo-Global ^LEXU (possibly corrupt)"
+39 IF LEXVER=-3
WRITE !," Undo-Global ^LEXU failed checksum"
+40 WRITE !!," Please KILL the existing Undo-Global ^LEXU from your system and"
+41 WRITE !," obtain a new copy of ^LEXU before continuing with the installation."
End DoDot:1
QUIT
+42 DO KILL
+43 QUIT
CHECKSUM ; Checksum for Undo-Global ^LEXU
+1 NEW LEXCHK,LEXNDS,LEXVER,LEXBLD,LEXBOK
WRITE !," Running checksum routine on the Undo-Global ^LEXU, please wait"
+2 IF '$DATA(^LEXU)
HANG 1
WRITE !," Undo-Global ^LEXU is missing. Please obtain a copy of ^LEXU before",!," continuing.",!
QUIT
+3 SET LEXBLD=$GET(^LEXU(0,"BUILD"))
IF '$LENGTH(LEXBLD)
HANG 1
WRITE !," Undo-Global Build is missing. Please obtain a copy of ^LEXU before",!," continuing.",!
QUIT
+4 SET LEXBOK=0
if $LENGTH(LEXBLD)
SET LEXBOK=$$BOK(LEXBLD)
IF +($GET(LEXBOK))'>0
WRITE " Please obtain a valid ",!," copy of ^LEXU before continuing.",!
QUIT
+5 SET LEXCHK=+($GET(^LEXU(0,"CHECKSUM")))
SET LEXNDS=+($GET(^LEXU(0,"NODES")))
SET LEXVER=+($$VC(LEXCHK,LEXNDS))
WRITE !
+6 if LEXVER>0
WRITE !," Checksum is ok",!
if LEXVER>0
QUIT
+7 IF LEXVER=0
HANG 1
WRITE !," Undo-Global ^LEXU is missing. Please obtain a copy of ^LEXU before",!," continuing.",!
QUIT
+8 IF LEXVER<0
Begin DoDot:1
+9 IF LEXVER'=-3
WRITE !," Unable to verify checksum for Undo-Global ^LEXU (possibly corrupt)",!
+10 IF LEXVER=-3
WRITE !," Undo-Global ^LEXU failed checksum",!
+11 WRITE !!," Please KILL the existing Undo-Global ^LEXU from your system and"
+12 WRITE !," obtain a new copy of ^LEXU before continuing with the installation.",!
End DoDot:1
QUIT
+13 QUIT
VC(X,Y) ; Verify Checksum for import global
+1 if '$DATA(^LEXU)
QUIT 0
if '$DATA(^LEXU(0))
QUIT 0
if $ORDER(^LEXU(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(^LEXU(0)))>0
WRITE !
SET (LEXC,LEXN)="^LEXU"
SET (LEXNC,LEXGCS)=0
WRITE " "
+4 FOR
SET LEXN=$QUERY(@LEXN)
if LEXN=""!(LEXN'[LEXC)
QUIT
Begin DoDot:1
+5 if LEXN="^LEXU(0,""CHECKSUM"")"
QUIT
if LEXN="^LEXU(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 ;
+11 ; Miscellaneous
BOK(X) ; Build is OK
+1 NEW LEXB,LEXBLD,LEXFI,LEXI,LEXOUT,LEXPKG,LEXR,LEXREV,LEXVER,LEXVR,LEXVRRV
+2 SET LEXVR=$$VERSION^XPDUTL("LEX")
SET LEXOUT=""
SET LEXBLD=$GET(X)
SET LEXVER=$PIECE(LEXBLD,"*",2)
+3 SET LEXREV=$PIECE(LEXBLD,"*",3)
SET LEXPKG=$PIECE(LEXBLD,"*",1)
IF LEXVER'=LEXVR
Begin DoDot:1
+4 WRITE !!," Invalid Undo-Global ^LEXU (wrong version, """_LEXVER_""")"
End DoDot:1
QUIT
+5 IF LEXPKG'="LEX"
WRITE !!," Invalid Undo-Global ^LEXU (wrong package, """_LEXPKG_""")"
QUIT 0
+6 FOR LEXFI=757,757.001,757.01,757.02,757.03,757.1,757.21
Begin DoDot:1
+7 NEW LEXVRRV,LEXB,LEXR,LEXI
SET LEXVRRV=$GET(@("^DD("_+LEXFI_",0,""VRRV"")"))
SET LEXR=$PIECE(LEXVRRV,"^",1)
+8 if +LEXR'>0
QUIT
if +LEXR'>LEXOUT
QUIT
SET LEXB="LEX*"_LEXVER_"*"_LEXR
SET LEXI=$$PATCH^XPDUTL(LEXB)
+9 if LEXI'>0
QUIT
SET LEXOUT=+LEXR
End DoDot:1
+10 IF +LEXREV<+LEXOUT
WRITE !!," Invalid Undo-Global ^LEXU (old revision, """_+LEXREV_""")"
QUIT 0
+11 IF LEXREV'=LEXOUT
WRITE !!," Invalid Undo-Global ^LEXU (wrong revision, """_+LEXREV_""")"
QUIT 0
+12 QUIT 1
UOK(X) ; Uninstall is Ok for Build X
+1 NEW DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,LEXBLD
SET LEXBLD=$GET(X)
+2 if $LENGTH(LEXBLD)
SET DIR("A")=" Uninstall patch "_LEXBLD_" (Y/N): "
+3 if '$LENGTH(LEXBLD)
SET DIR("A")=" Uninstall patch (Y/N): "
+4 SET DIR("B")="NO"
SET DIR(0)="YAO"
WRITE !
DO ^DIR
+5 SET X=+Y
if "^1^0^"'[("^"_Y_"^")
SET X="^"
+6 QUIT X
KOK(X) ; Kill Undo-Global ^LEXU Ok
+1 NEW DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,LEXBLD
SET LEXBLD=$GET(X)
+2 SET DIR("A")=" Kill Undo-Global ^LEXU when uninstall is complete (Y/N): "
+3 SET DIR("B")="NO"
SET DIR(0)="YAO"
WRITE !
DO ^DIR
+4 SET X=+Y
if "^1^0^"'[("^"_Y_"^")
SET X="^"
+5 QUIT X
MT(X) ; Message Text
+1 NEW LEXI
SET LEXI=$ORDER(^TMP("LEXXGUM",$JOB," "),-1)+1
SET ^TMP("LEXXGUM",$JOB,LEXI)=$GET(X)
+2 QUIT
KILL ; Kill Undo-Global ^LEXU
+1 if +($GET(LEXKIL))'>0
QUIT
KILL ^LEXU(0)
NEW LEXFI
SET LEXFI=0
FOR
SET LEXFI=$ORDER(^LEXU(LEXFI))
if +LEXFI'>0
QUIT
KILL ^LEXU(LEXFI)
+2 QUIT
P(X) ; Person
+1 NEW LEXDUZ,LEXF,LEXL,LEXNM,LEXP,LEXPH
+2 SET LEXDUZ=+($GET(DUZ))
SET LEXNM=$$GET1^DIQ(200,+($GET(LEXDUZ)),.01)
if '$LENGTH(LEXNM)
QUIT "UNKNOWN^"
+3 SET LEXDUZ=+($GET(DUZ))
SET LEXPH=$$GET1^DIQ(200,+($GET(LEXDUZ)),.132)
+4 if LEXPH=""
SET LEXPH=$$GET1^DIQ(200,+($GET(LEXDUZ)),.133)
+5 if LEXPH=""
SET LEXPH=$$GET1^DIQ(200,+($GET(LEXDUZ)),.134)
+6 if LEXPH=""
SET LEXPH=$$GET1^DIQ(200,+($GET(LEXDUZ)),.135)
+7 SET LEXDUZ=$$PM(LEXNM)
+8 SET X=LEXDUZ
SET X=X_$JUSTIFY(" ",(26-$LENGTH(X)))_" "_LEXPH
+9 QUIT X
PM(X) ; Person, Mixed Case
+1 NEW LEXF,LEXL,LEXP
SET LEXP=$GET(X)
SET LEXL=$$MX($PIECE(LEXP,",",1))
SET LEXF=$PIECE(LEXP,",",2)
+2 SET LEXL(1)=$$MX($PIECE(LEXL,"-",1))
SET LEXL(2)=$$MX($PIECE(LEXL(1)," ",2,2))
SET LEXL(1)=$$MX($PIECE(LEXL(1)," ",1))
+3 if $LENGTH(LEXL(1))&($LENGTH(LEXL(2)))
SET LEXL(1)=LEXL(1)_" "_LEXL(2)
+4 SET LEXL(3)=$$MX($PIECE(LEXL,"-",2))
SET LEXL(4)=$$MX($PIECE(LEXL(3)," ",2,2))
SET LEXL(3)=$$MX($PIECE(LEXL(3)," ",1))
+5 if $LENGTH(LEXL(3))&($LENGTH(LEXL(4)))
SET LEXL(3)=LEXL(3)_" "_LEXL(4)
+6 SET LEXL=LEXL(1)
if $LENGTH(LEXL(1))&($LENGTH(LEXL(3)))
SET LEXL=LEXL(1)_"-"_LEXL(3)
+7 SET LEXF=$$MX($PIECE(LEXP,",",1))
SET LEXF=$PIECE(LEXP,",",2)
+8 SET LEXF(1)=$$MX($PIECE(LEXF,"-",1))
SET LEXF(2)=$$MX($PIECE(LEXF(1)," ",2,2))
SET LEXF(1)=$$MX($PIECE(LEXF(1)," ",1))
+9 if $LENGTH(LEXF(1))&($LENGTH(LEXF(2)))
SET LEXF(1)=LEXF(1)_" "_LEXF(2)
+10 SET LEXF(3)=$$MX($PIECE(LEXF,"-",2))
SET LEXF(4)=$$MX($PIECE(LEXF(3)," ",2,2))
SET LEXF(3)=$$MX($PIECE(LEXF(3)," ",1))
+11 if $LENGTH(LEXF(3))&($LENGTH(LEXF(4)))
SET LEXF(3)=LEXF(3)_" "_LEXF(4)
+12 SET LEXF=LEXF(1)
if $LENGTH(LEXF(1))&($LENGTH(LEXF(3)))
SET LEXF=LEXF(1)_"-"_LEXF(3)
+13 SET LEXP=LEXL_", "_LEXF
SET X=LEXP
+14 QUIT X
MX(X) ; Mix Case
+1 QUIT $TRANSLATE($EXTRACT(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TRANSLATE($EXTRACT(X,2,$LENGTH(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UCI(X) ; UCI where Lexicon is installed
+1 NEW LEXP,LEXT,LEXU,Y
XECUTE ^%ZOSF("UCI")
SET LEXU=Y
SET LEXP=""
+2 SET LEXP=$SELECT($$PROD^XUPROD(1):"Production",1:"Test Account")
+3 if LEXU[","&($LENGTH($PIECE(LEXU,",",1))>3)
SET LEXU=$PIECE(LEXU,",",1)
+4 SET X=LEXU
IF $LENGTH(LEXP)
SET X=X_$JUSTIFY(" ",(26-$LENGTH(X)))_" "_LEXP
+5 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
SH ; Show Text
+1 WRITE !
NEW LEXNN,LEXNC
SET LEXNN="^TMP(""LEXXGUM"","_$JOB_")"
SET LEXNC="^TMP(""LEXXGUM"","_$JOB_","
+2 FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
WRITE !,@LEXNN
+3 WRITE !
QUIT
ENV(X) ; Environment
+1 DO HOME^%ZIS
SET U="^"
SET DT=$$DT^XLFDT
SET DTIME=300
KILL POP
+2 NEW LEXNM
SET LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
+3 IF '$LENGTH($GET(LEXNM))
WRITE !!,?5,"Invalid/Missing DUZ"
QUIT 0
+4 if $GET(DUZ(0))'["@"
SET DUZ(0)=$GET(DUZ(0))_"@"
+5 QUIT 1
