LEX2049P ; ISL/OI - Post Install LEX*2.0*49 ; 02/22/2007
;;2.0;LEXICON UTILITY;**49**;Sep 23, 1996;Build 3
;
; Global Variables
; ^%ZOSF("DEL"
; ^%ZOSF("TEST"
; ^LEXC
; ^LEXM(0
; ^LEXT(757.2
; ^ORD(101
; ^TMP("LEXCNT"
; ^TMP("LEXCS"
; ^TMP("LEXI"
; ^TMP("LEXINS"
; ^TMP("LEXKID"
; ^TMP("LEXMSG"
;
; External References
; HOME^%ZIS
; $$GET1^DID
; ^DIK
; ^DIM
; $$GET1^DIQ
; EN^DIU2
; $$DT^XLFDT
; $$FMTE^XLFDT
; $$NOW^XLFDT
; BMES^XPDUTL
; MES^XPDUTL
; EN^XQOR
; $$DTIME^XUP
;
POST ; Post-Install Main Entry Point
N CNT,DA,DIK,DIU,ERR,EXEC,FI,FIX,FNAME,I,INST,LEX,LEXBEG,LEXBUILD,LEXCHG,LEXEDT,LEXELP,LEXEND
N LEXFC,LEXI,LEXID,LEXMOD,LEXMUL,LEXNM,LEXO,LEXP,LEXPOST,LEXSCHG,LEXSHORT,LEXSUB,LEXTCS,LEXTND
N NAME,OK,PN,PNO,ROK,RTN,SSIEN,STR,T,TAG,TXT,TY,X,Y,ZTQUEUED,ZTREQ S LEXPOST="",LEXSHORT="",(LEXID,LEXSUB)="LEXKID" D MSG1
S LEXCHG=1,LEXEDT=$$NOW^XLFDT,LEXSCHG("0")="1"
S LEXSCHG("81",0)="",LEXSCHG("81.1",0)="",LEXSCHG("81.2",0)="",LEXSCHG("81.3",0)=""
S LEXSCHG("B","81")="",LEXSCHG("B","81.1")="",LEXSCHG("B","81.2")="",LEXSCHG("B","81.3")=""
S LEXSCHG("C","CPT","81")="",LEXSCHG("C","CPT","81.1")="",LEXSCHG("C","CPT","81.2")="",LEXSCHG("C","CPT","81.3")=""
S LEXSCHG("80",0)="",LEXSCHG("80.1",0)=""
S LEXSCHG("B","80")="",LEXSCHG("B","80.1")=""
S LEXSCHG("C","ICD","80")="",LEXSCHG("C","ICD","80.1")=""
S LEXSCHG("757",0)="",LEXSCHG("757.001",0)="",LEXSCHG("757.01",0)="",LEXSCHG("757.02",0)="",LEXSCHG("757.1",0)=""
S LEXSCHG("B","757")="",LEXSCHG("B","757.001")="",LEXSCHG("B","757.01")="",LEXSCHG("B","757.02")="",LEXSCHG("B","757.1")=""
S LEXSCHG("C","LEX","757")="",LEXSCHG("C","LEX","757.001")="",LEXSCHG("C","LEX","757.01")="",LEXSCHG("C","LEX","757.02")="",LEXSCHG("C","LEX","757.1")=""
S LEXSCHG("D","PRO")="",LEXSHORT=""
D DDUZ,CHGF,RTN,INST,NOTIFY,MSG2,KALL^LEXXGI2
Q
INST ; Installed Patches
N INST,STR D BL
S INST=$$PROK("PXRMCSD",9) S STR=" PXRM*2.0*9 "_$S(INST>0:"Installed",1:"Not Installed") D BM(STR),TL(STR)
S INST=$$PROK("ICDUPDT",28) S STR=" ICD*18.0*28 "_$S(INST>0:"Installed",1:"Not Installed") D M(STR),TL(STR)
S INST=$$PROK("ICPTAU",34) S STR=" ICPT*6.0*34 "_$S(INST>0:"Installed",1:"Not Installed") D M(STR),TL(STR)
S INST=$$PROK("LEXXGI",49) S STR=" LEX*2.0*49 "_$S(INST>0:"Installed",1:"Not Installed") D M(STR),TL(STR)
Q
NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
N LEXP,X,STR
S STR="ERROR: Array of files not found" D:'$D(LEXSCHG) BM(STR),BL,TL(STR) Q:'$D(LEXSCHG)
S LEXP=+($O(^ORD(101,"B","LEXICAL SERVICES UPDATE",0)))
S STR="ERROR: LEXICAL SERVICES UPDATE protocol not found" D:$G(LEXP)'>0 BM(STR),BL,TL(STR) Q:LEXP=0
S X=LEXP_";ORD(101," D EN^XQOR
S STR="ERROR: LEXICAL SERVICES UPDATE protocol not invoked" D:$D(LEXSCHG) BM(STR),BL,TL(STR) Q:$D(LEXSCHG)
S ^LEXM(0,"PRO")=$$NOW^XLFDT,X="Protocol 'LEXICAL SERVICES UPDATE' was invoked"
W:'$D(XPDNM) !!,X D:$D(XPDNM) BM(X)
S (STR,X)="Subscribing applications were notified",STR=" "_STR D BL,TL(STR)
W:'$D(XPDNM) !,X D:$D(XPDNM) M(X)
Q
CHGF ; Change File
D M(" "),RI("Removing Change Files (757.9-757.91)","Remedy 175985") N FI,FNAME,ERR,ROK,STR
S FI=757.91,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D
. N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)
S FI=757.903,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D
. N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)
S FI=757.9,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D
. N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)
S FI=757.901,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D
. N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)
S FI=757.902,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D
. N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)
I '$D(^LEXC) S STR="Removed Change Files (757.9-757.91) (Remedy 175985)" D BL,TL(STR) Q
Q
RTN ; Routines
D M(" "),BL D DRTN,MRTN
Q
DRTN ; Delete Routines
N EXEC,ROK,RTN,STR,X
S X=$G(^%ZOSF("DEL")) Q:'$L(X) D ^DIM Q:'$D(X) Q:'$L(X) S EXEC=X
F RTN="LEXCHGF","LEXCHGF2","LEXNDX7","LEXXST5" D
. S ROK=+($$ROK(RTN)) I +ROK'>0 S STR=" "_RTN,STR=STR_$J(" ",(17-$L(STR)))_"Deleted" D M(STR),TL(STR) Q
. S X=RTN X EXEC
. S ROK=+($$ROK(RTN)) I +ROK'>0 S STR=" "_RTN,STR=STR_$J(" ",(17-$L(STR)))_"Deleted" D M(STR),TL(STR) Q
. S STR=" "_RTN D M(STR),TL(STR)
Q
MRTN ; Modified Routines
N CNT,EXEC,FIX,I,RTN,PN,PNO,STR,TXT,TY S CNT=0 F I=1:1 D Q:'$L(TXT)
. S TXT="" S EXEC="S TXT=$T(MRN+"_I_"^LEX2049P)" X EXEC
. S TXT=$P(TXT,";;",2,299) Q:TXT=""
. S RTN=$P(TXT,";",1) S:'$L(RTN) TXT="" Q:'$L(TXT) Q:+($$ROK(RTN))=0
. S PN=$P(TXT,";",2),TY=$P(TXT,";",3),FIX=$P(TXT,";",4)
. S PNO=$$PROK(RTN,PN)
. S STR=" "_RTN S:+PNO>0 STR=STR_$J(" ",(17-$L(STR)))_TY S:+PNO>0 STR=STR_$J(" ",(29-$L(STR)))_FIX
. D M(STR),TL(STR)
Q
MRN ; Modified Routine Names
;;LEXXFI;49;Modified;Removed references to file #757.9
;;LEXXFI7;49;Modified;Removed references to file #757.9
;;LEXXST;49;Modified;Removed references to file #757.9
;;LEXXGI;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol
;;LEXXGI2;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol
;;LEXXII;49;Modified;Fix Install Message (Protocol)
;;ICDUPDT;28;Modified;Fix ICD CODE UPDATE EVENT Protocol
;;ICPTAU;34;Modified;Fix ICPT CODE UPDATE EVENT Protocol
;;PXRMCSD;9;Modified;Fix ICD/CPT Reminder Dialogs Message
;;PXRMCSTX;9;Modified;Fix ICD/CPT Reminder Taxonomies Message
;;
DDUZ ; Delete Exported DUZ if broken Pointer
N STR S STR="Removing broken Pointer in file #757.2"
D M(" "),RI(STR,"ROF LEX*2.0*46") S STR=STR_" (ROF LEX*2.0*46)" Q:$L($$GET1^DIQ(200,("1118,"),.01))
D BL,TL(STR) N DA,DIK,NAME,SSIEN S SSIEN=0 F S SSIEN=$O(^LEXT(757.2,SSIEN)) Q:+SSIEN'>0 D
. Q:'$D(^LEXT(757.2,SSIEN,200)) Q:$O(^LEXT(757.2,SSIEN,200,0))'>0 Q:'$D(^LEXT(757.2,SSIEN,200,1118))
. N DA,DIK,NAME S NAME=$P($G(^LEXT(757.2,SSIEN,0)),"^",1) D:$L(NAME) CI((" "_NAME))
. S DA(1)=SSIEN,DA=1118,DIK="^LEXT(757.2,"_SSIEN_",200," D ^DIK
Q
ROK(X) ; Routine OK
S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0
PROK(X,Y) ; Routine and Patch # OK (in UCI)
N LEX,LEXI,LEXO S X=$G(X),Y=$G(Y) Q:'$L(X) 0 Q:Y'=""&(+Y=0)
S Y=+Y,LEX=$$ROK(X) Q:'LEX 0 Q:+Y=0 1 S LEXO=0,LEX=$T(@("+2^"_X)),LEX=$P($P(LEX,"**",2),"**",1)
F LEXI=1:1:$L(LEX,",") S:+($P(LEX,",",LEXI))=Y LEXO=1 Q:LEXO=1
S X=LEXO
Q X
LL(T,X) ; Line Label
N RTN,TAG,ROK,EXEC,OK S TAG=$G(T),RTN=$G(X) Q:'$L(RTN) 0 S ROK=$$ROK(RTN) Q:+ROK'>0 0 S:'$L(TAG)&($L(RTN)) TAG=RTN
S OK=0,EXEC="S OK=$L($T("_TAG_"^"_RTN_")) S OK=$S(OK>0:1,1:0)" X EXEC S X=+($G(OK))
Q X
MSG1 ; Send Installation Message to G.LEXICON
K ^TMP("LEXCS",$J),^TMP("LEXCNT",$J),^TMP("LEXI",$J),^TMP("LEXMSG",$J)
K ^TMP("LEXINS",$J),^TMP("LEXKID",$J) S:$D(ZTQUEUED) ZTREQ="@"
N LEXBEG,LEXELP,LEXEND,LEXFC,LEXMOD,LEXMUL,LEXTCS,LEXTND,LEXID,ZTQUEUED
S LEXID="LEXKID",LEXMUL=1,(LEXTND,LEXTCS,LEXMOD,LEXFC,ZTQUEUED)=0
D HDR^LEXXFI,EN^LEXXII K ^LEXM(0,"PRO")
Q
MSG2 ; Send Installation (part 2)
N LEXSHORT,ZTQUEUED,LEXBUILD S ZTQUEUED=0,LEXSHORT=1,LEXBUILD="LEX*2.0*49"
D MAIL^LEXXFI,KILL^LEXXFI
Q
ENV(X) ; Environment check
N LEXNM D HOME^%ZIS S U="^",DT=$$DT^XLFDT,LEXNM=$$GET1^DIQ(200,+($G(DUZ)),.01),DTIME=$$DTIME^XUP(+($G(DUZ))) Q:+($G(DUZ))'>0!('$L(LEXNM)) 0
Q 1
ED(LEX) ; External Date MM/DD/YYYY TT:TT
N XPDNM S LEX=$$FMTE^XLFDT($G(LEX),"1Z") S:LEX["@" LEX=$P(LEX,"@",1)_" "_$P(LEX,"@",2,299)
Q LEX
RI(X,Y) ; Reference - Indented
N I S X=$G(X),Y=$G(Y) Q:'$L(X)
I $L(Y) S X=" "_X F Q:$L(X)>54 S X=X_" "
S X=X_" "_Y S:$E(X,1)'=" " X=" "_X D MES^XPDUTL(X) Q
CI(X) ; Comment Text - Indented
N I S X=$G(X) Q:'$L(X) S X=" "_X D MES^XPDUTL(X)
Q
BL ; Blank Line
D TL("") Q
TL(LEXX) ; Text Line
S LEXSUB=$G(LEXSUB) S:'$L(LEXSUB) LEXSUB="LEXXII"
I '$D(^TMP(LEXSUB,$J,1)) S ^TMP(LEXSUB,$J,1)=" ",^TMP(LEXSUB,$J,0)=1
N LEXNX S LEXNX=$O(^TMP(LEXSUB,$J," "),-1),LEXNX=LEXNX+1
S ^TMP(LEXSUB,$J,LEXNX)=" "_$G(LEXX),^TMP(LEXSUB,$J,0)=LEXNX
Q
BM(X) ; Blank and Line
D BMES^XPDUTL($G(X))
Q
M(X) ; Line
D MES^XPDUTL($G(X))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX2049P 8604 printed Apr 09, 2024@21:10:13 Page 2
LEX2049P ; ISL/OI - Post Install LEX*2.0*49 ; 02/22/2007
+1 ;;2.0;LEXICON UTILITY;**49**;Sep 23, 1996;Build 3
+2 ;
+3 ; Global Variables
+4 ; ^%ZOSF("DEL"
+5 ; ^%ZOSF("TEST"
+6 ; ^LEXC
+7 ; ^LEXM(0
+8 ; ^LEXT(757.2
+9 ; ^ORD(101
+10 ; ^TMP("LEXCNT"
+11 ; ^TMP("LEXCS"
+12 ; ^TMP("LEXI"
+13 ; ^TMP("LEXINS"
+14 ; ^TMP("LEXKID"
+15 ; ^TMP("LEXMSG"
+16 ;
+17 ; External References
+18 ; HOME^%ZIS
+19 ; $$GET1^DID
+20 ; ^DIK
+21 ; ^DIM
+22 ; $$GET1^DIQ
+23 ; EN^DIU2
+24 ; $$DT^XLFDT
+25 ; $$FMTE^XLFDT
+26 ; $$NOW^XLFDT
+27 ; BMES^XPDUTL
+28 ; MES^XPDUTL
+29 ; EN^XQOR
+30 ; $$DTIME^XUP
+31 ;
POST ; Post-Install Main Entry Point
+1 NEW CNT,DA,DIK,DIU,ERR,EXEC,FI,FIX,FNAME,I,INST,LEX,LEXBEG,LEXBUILD,LEXCHG,LEXEDT,LEXELP,LEXEND
+2 NEW LEXFC,LEXI,LEXID,LEXMOD,LEXMUL,LEXNM,LEXO,LEXP,LEXPOST,LEXSCHG,LEXSHORT,LEXSUB,LEXTCS,LEXTND
+3 NEW NAME,OK,PN,PNO,ROK,RTN,SSIEN,STR,T,TAG,TXT,TY,X,Y,ZTQUEUED,ZTREQ
SET LEXPOST=""
SET LEXSHORT=""
SET (LEXID,LEXSUB)="LEXKID"
DO MSG1
+4 SET LEXCHG=1
SET LEXEDT=$$NOW^XLFDT
SET LEXSCHG("0")="1"
+5 SET LEXSCHG("81",0)=""
SET LEXSCHG("81.1",0)=""
SET LEXSCHG("81.2",0)=""
SET LEXSCHG("81.3",0)=""
+6 SET LEXSCHG("B","81")=""
SET LEXSCHG("B","81.1")=""
SET LEXSCHG("B","81.2")=""
SET LEXSCHG("B","81.3")=""
+7 SET LEXSCHG("C","CPT","81")=""
SET LEXSCHG("C","CPT","81.1")=""
SET LEXSCHG("C","CPT","81.2")=""
SET LEXSCHG("C","CPT","81.3")=""
+8 SET LEXSCHG("80",0)=""
SET LEXSCHG("80.1",0)=""
+9 SET LEXSCHG("B","80")=""
SET LEXSCHG("B","80.1")=""
+10 SET LEXSCHG("C","ICD","80")=""
SET LEXSCHG("C","ICD","80.1")=""
+11 SET LEXSCHG("757",0)=""
SET LEXSCHG("757.001",0)=""
SET LEXSCHG("757.01",0)=""
SET LEXSCHG("757.02",0)=""
SET LEXSCHG("757.1",0)=""
+12 SET LEXSCHG("B","757")=""
SET LEXSCHG("B","757.001")=""
SET LEXSCHG("B","757.01")=""
SET LEXSCHG("B","757.02")=""
SET LEXSCHG("B","757.1")=""
+13 SET LEXSCHG("C","LEX","757")=""
SET LEXSCHG("C","LEX","757.001")=""
SET LEXSCHG("C","LEX","757.01")=""
SET LEXSCHG("C","LEX","757.02")=""
SET LEXSCHG("C","LEX","757.1")=""
+14 SET LEXSCHG("D","PRO")=""
SET LEXSHORT=""
+15 DO DDUZ
DO CHGF
DO RTN
DO INST
DO NOTIFY
DO MSG2
DO KALL^LEXXGI2
+16 QUIT
INST ; Installed Patches
+1 NEW INST,STR
DO BL
+2 SET INST=$$PROK("PXRMCSD",9)
SET STR=" PXRM*2.0*9 "_$SELECT(INST>0:"Installed",1:"Not Installed")
DO BM(STR)
DO TL(STR)
+3 SET INST=$$PROK("ICDUPDT",28)
SET STR=" ICD*18.0*28 "_$SELECT(INST>0:"Installed",1:"Not Installed")
DO M(STR)
DO TL(STR)
+4 SET INST=$$PROK("ICPTAU",34)
SET STR=" ICPT*6.0*34 "_$SELECT(INST>0:"Installed",1:"Not Installed")
DO M(STR)
DO TL(STR)
+5 SET INST=$$PROK("LEXXGI",49)
SET STR=" LEX*2.0*49 "_$SELECT(INST>0:"Installed",1:"Not Installed")
DO M(STR)
DO TL(STR)
+6 QUIT
NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
+1 NEW LEXP,X,STR
+2 SET STR="ERROR: Array of files not found"
if '$DATA(LEXSCHG)
DO BM(STR)
DO BL
DO TL(STR)
if '$DATA(LEXSCHG)
QUIT
+3 SET LEXP=+($ORDER(^ORD(101,"B","LEXICAL SERVICES UPDATE",0)))
+4 SET STR="ERROR: LEXICAL SERVICES UPDATE protocol not found"
if $GET(LEXP)'>0
DO BM(STR)
DO BL
DO TL(STR)
if LEXP=0
QUIT
+5 SET X=LEXP_";ORD(101,"
DO EN^XQOR
+6 SET STR="ERROR: LEXICAL SERVICES UPDATE protocol not invoked"
if $DATA(LEXSCHG)
DO BM(STR)
DO BL
DO TL(STR)
if $DATA(LEXSCHG)
QUIT
+7 SET ^LEXM(0,"PRO")=$$NOW^XLFDT
SET X="Protocol 'LEXICAL SERVICES UPDATE' was invoked"
+8 if '$DATA(XPDNM)
WRITE !!,X
if $DATA(XPDNM)
DO BM(X)
+9 SET (STR,X)="Subscribing applications were notified"
SET STR=" "_STR
DO BL
DO TL(STR)
+10 if '$DATA(XPDNM)
WRITE !,X
if $DATA(XPDNM)
DO M(X)
+11 QUIT
CHGF ; Change File
+1 DO M(" ")
DO RI("Removing Change Files (757.9-757.91)","Remedy 175985")
NEW FI,FNAME,ERR,ROK,STR
+2 SET FI=757.91
SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")
IF $LENGTH(FNAME)
Begin DoDot:1
+3 NEW DIU,ERR
SET DIU="^LEXC("_FI_","
SET DIU(0)="D"
DO EN^DIU2
if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))
KILL ^LEXC(FI)
End DoDot:1
+4 SET FI=757.903
SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")
IF $LENGTH(FNAME)
Begin DoDot:1
+5 NEW DIU,ERR
SET DIU="^LEXC("_FI_","
SET DIU(0)="D"
DO EN^DIU2
if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))
KILL ^LEXC(FI)
End DoDot:1
+6 SET FI=757.9
SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")
IF $LENGTH(FNAME)
Begin DoDot:1
+7 NEW DIU,ERR
SET DIU="^LEXC("_FI_","
SET DIU(0)="D"
DO EN^DIU2
if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))
KILL ^LEXC(FI)
End DoDot:1
+8 SET FI=757.901
SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")
IF $LENGTH(FNAME)
Begin DoDot:1
+9 NEW DIU,ERR
SET DIU="^LEXC("_FI_","
SET DIU(0)="D"
DO EN^DIU2
if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))
KILL ^LEXC(FI)
End DoDot:1
+10 SET FI=757.902
SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")
IF $LENGTH(FNAME)
Begin DoDot:1
+11 NEW DIU,ERR
SET DIU="^LEXC("_FI_","
SET DIU(0)="D"
DO EN^DIU2
if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))
KILL ^LEXC(FI)
End DoDot:1
+12 IF '$DATA(^LEXC)
SET STR="Removed Change Files (757.9-757.91) (Remedy 175985)"
DO BL
DO TL(STR)
QUIT
+13 QUIT
RTN ; Routines
+1 DO M(" ")
DO BL
DO DRTN
DO MRTN
+2 QUIT
DRTN ; Delete Routines
+1 NEW EXEC,ROK,RTN,STR,X
+2 SET X=$GET(^%ZOSF("DEL"))
if '$LENGTH(X)
QUIT
DO ^DIM
if '$DATA(X)
QUIT
if '$LENGTH(X)
QUIT
SET EXEC=X
+3 FOR RTN="LEXCHGF","LEXCHGF2","LEXNDX7","LEXXST5"
Begin DoDot:1
+4 SET ROK=+($$ROK(RTN))
IF +ROK'>0
SET STR=" "_RTN
SET STR=STR_$JUSTIFY(" ",(17-$LENGTH(STR)))_"Deleted"
DO M(STR)
DO TL(STR)
QUIT
+5 SET X=RTN
XECUTE EXEC
+6 SET ROK=+($$ROK(RTN))
IF +ROK'>0
SET STR=" "_RTN
SET STR=STR_$JUSTIFY(" ",(17-$LENGTH(STR)))_"Deleted"
DO M(STR)
DO TL(STR)
QUIT
+7 SET STR=" "_RTN
DO M(STR)
DO TL(STR)
End DoDot:1
+8 QUIT
MRTN ; Modified Routines
+1 NEW CNT,EXEC,FIX,I,RTN,PN,PNO,STR,TXT,TY
SET CNT=0
FOR I=1:1
Begin DoDot:1
+2 SET TXT=""
SET EXEC="S TXT=$T(MRN+"_I_"^LEX2049P)"
XECUTE EXEC
+3 SET TXT=$PIECE(TXT,";;",2,299)
if TXT=""
QUIT
+4 SET RTN=$PIECE(TXT,";",1)
if '$LENGTH(RTN)
SET TXT=""
if '$LENGTH(TXT)
QUIT
if +($$ROK(RTN))=0
QUIT
+5 SET PN=$PIECE(TXT,";",2)
SET TY=$PIECE(TXT,";",3)
SET FIX=$PIECE(TXT,";",4)
+6 SET PNO=$$PROK(RTN,PN)
+7 SET STR=" "_RTN
if +PNO>0
SET STR=STR_$JUSTIFY(" ",(17-$LENGTH(STR)))_TY
if +PNO>0
SET STR=STR_$JUSTIFY(" ",(29-$LENGTH(STR)))_FIX
+8 DO M(STR)
DO TL(STR)
End DoDot:1
if '$LENGTH(TXT)
QUIT
+9 QUIT
MRN ; Modified Routine Names
+1 ;;LEXXFI;49;Modified;Removed references to file #757.9
+2 ;;LEXXFI7;49;Modified;Removed references to file #757.9
+3 ;;LEXXST;49;Modified;Removed references to file #757.9
+4 ;;LEXXGI;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol
+5 ;;LEXXGI2;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol
+6 ;;LEXXII;49;Modified;Fix Install Message (Protocol)
+7 ;;ICDUPDT;28;Modified;Fix ICD CODE UPDATE EVENT Protocol
+8 ;;ICPTAU;34;Modified;Fix ICPT CODE UPDATE EVENT Protocol
+9 ;;PXRMCSD;9;Modified;Fix ICD/CPT Reminder Dialogs Message
+10 ;;PXRMCSTX;9;Modified;Fix ICD/CPT Reminder Taxonomies Message
+11 ;;
DDUZ ; Delete Exported DUZ if broken Pointer
+1 NEW STR
SET STR="Removing broken Pointer in file #757.2"
+2 DO M(" ")
DO RI(STR,"ROF LEX*2.0*46")
SET STR=STR_" (ROF LEX*2.0*46)"
if $LENGTH($$GET1^DIQ(200,("1118,"),.01))
QUIT
+3 DO BL
DO TL(STR)
NEW DA,DIK,NAME,SSIEN
SET SSIEN=0
FOR
SET SSIEN=$ORDER(^LEXT(757.2,SSIEN))
if +SSIEN'>0
QUIT
Begin DoDot:1
+4 if '$DATA(^LEXT(757.2,SSIEN,200))
QUIT
if $ORDER(^LEXT(757.2,SSIEN,200,0))'>0
QUIT
if '$DATA(^LEXT(757.2,SSIEN,200,1118))
QUIT
+5 NEW DA,DIK,NAME
SET NAME=$PIECE($GET(^LEXT(757.2,SSIEN,0)),"^",1)
if $LENGTH(NAME)
DO CI((" "_NAME))
+6 SET DA(1)=SSIEN
SET DA=1118
SET DIK="^LEXT(757.2,"_SSIEN_",200,"
DO ^DIK
End DoDot:1
+7 QUIT
ROK(X) ; Routine OK
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
if $LENGTH(X)>8
QUIT 0
XECUTE ^%ZOSF("TEST")
if $TEST
QUIT 1
QUIT 0
PROK(X,Y) ; Routine and Patch # OK (in UCI)
+1 NEW LEX,LEXI,LEXO
SET X=$GET(X)
SET Y=$GET(Y)
if '$LENGTH(X)
QUIT 0
if Y'=""&(+Y=0)
QUIT
+2 SET Y=+Y
SET LEX=$$ROK(X)
if 'LEX
QUIT 0
if +Y=0
QUIT 1
SET LEXO=0
SET LEX=$TEXT(@("+2^"_X))
SET LEX=$PIECE($PIECE(LEX,"**",2),"**",1)
+3 FOR LEXI=1:1:$LENGTH(LEX,",")
if +($PIECE(LEX,",",LEXI))=Y
SET LEXO=1
if LEXO=1
QUIT
+4 SET X=LEXO
+5 QUIT X
LL(T,X) ; Line Label
+1 NEW RTN,TAG,ROK,EXEC,OK
SET TAG=$GET(T)
SET RTN=$GET(X)
if '$LENGTH(RTN)
QUIT 0
SET ROK=$$ROK(RTN)
if +ROK'>0
QUIT 0
if '$LENGTH(TAG)&($LENGTH(RTN))
SET TAG=RTN
+2 SET OK=0
SET EXEC="S OK=$L($T("_TAG_"^"_RTN_")) S OK=$S(OK>0:1,1:0)"
XECUTE EXEC
SET X=+($GET(OK))
+3 QUIT X
MSG1 ; Send Installation Message to G.LEXICON
+1 KILL ^TMP("LEXCS",$JOB),^TMP("LEXCNT",$JOB),^TMP("LEXI",$JOB),^TMP("LEXMSG",$JOB)
+2 KILL ^TMP("LEXINS",$JOB),^TMP("LEXKID",$JOB)
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 NEW LEXBEG,LEXELP,LEXEND,LEXFC,LEXMOD,LEXMUL,LEXTCS,LEXTND,LEXID,ZTQUEUED
+4 SET LEXID="LEXKID"
SET LEXMUL=1
SET (LEXTND,LEXTCS,LEXMOD,LEXFC,ZTQUEUED)=0
+5 DO HDR^LEXXFI
DO EN^LEXXII
KILL ^LEXM(0,"PRO")
+6 QUIT
MSG2 ; Send Installation (part 2)
+1 NEW LEXSHORT,ZTQUEUED,LEXBUILD
SET ZTQUEUED=0
SET LEXSHORT=1
SET LEXBUILD="LEX*2.0*49"
+2 DO MAIL^LEXXFI
DO KILL^LEXXFI
+3 QUIT
ENV(X) ; Environment check
+1 NEW LEXNM
DO HOME^%ZIS
SET U="^"
SET DT=$$DT^XLFDT
SET LEXNM=$$GET1^DIQ(200,+($GET(DUZ)),.01)
SET DTIME=$$DTIME^XUP(+($GET(DUZ)))
if +($GET(DUZ))'>0!('$LENGTH(LEXNM))
QUIT 0
+2 QUIT 1
ED(LEX) ; External Date MM/DD/YYYY TT:TT
+1 NEW XPDNM
SET LEX=$$FMTE^XLFDT($GET(LEX),"1Z")
if LEX["@"
SET LEX=$PIECE(LEX,"@",1)_" "_$PIECE(LEX,"@",2,299)
+2 QUIT LEX
RI(X,Y) ; Reference - Indented
+1 NEW I
SET X=$GET(X)
SET Y=$GET(Y)
if '$LENGTH(X)
QUIT
+2 IF $LENGTH(Y)
SET X=" "_X
FOR
if $LENGTH(X)>54
QUIT
SET X=X_" "
+3 SET X=X_" "_Y
if $EXTRACT(X,1)'=" "
SET X=" "_X
DO MES^XPDUTL(X)
QUIT
CI(X) ; Comment Text - Indented
+1 NEW I
SET X=$GET(X)
if '$LENGTH(X)
QUIT
SET X=" "_X
DO MES^XPDUTL(X)
+2 QUIT
BL ; Blank Line
+1 DO TL("")
QUIT
TL(LEXX) ; Text Line
+1 SET LEXSUB=$GET(LEXSUB)
if '$LENGTH(LEXSUB)
SET LEXSUB="LEXXII"
+2 IF '$DATA(^TMP(LEXSUB,$JOB,1))
SET ^TMP(LEXSUB,$JOB,1)=" "
SET ^TMP(LEXSUB,$JOB,0)=1
+3 NEW LEXNX
SET LEXNX=$ORDER(^TMP(LEXSUB,$JOB," "),-1)
SET LEXNX=LEXNX+1
+4 SET ^TMP(LEXSUB,$JOB,LEXNX)=" "_$GET(LEXX)
SET ^TMP(LEXSUB,$JOB,0)=LEXNX
+5 QUIT
BM(X) ; Blank and Line
+1 DO BMES^XPDUTL($GET(X))
+2 QUIT
M(X) ; Line
+1 DO MES^XPDUTL($GET(X))
+2 QUIT
