LEX2080P ;ISL/KER - LEX*2.0*80 Pre/Post Install ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^%ZOSF("UCI") ICR 10096
; ^LEX(757.31 N/A
; ^LEXM( N/A
; ^ORD(101, ICR 872
; ^TMP("LEXKID") SACC 2.3.2.5.1
; ^TMP(BUILD) SACC 2.3.2.5.1
;
; External References
; $$FIND1^DIC ICR 2051
; FILE^DIE ICR 2053
; ^DIK ICR 10013
; IX1^DIK ICR 10013
; IX2^DIK ICR 10013
; $$GET1^DIQ ICR 2056
; $$FMTE^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
; BMES^XPDUTL ICR 10141
; MES^XPDUTL ICR 10141
; EN^XQOR ICR 10101
;
; Local Variables NEWed or KILLed by Kernel
; XPDNOQUE
;
Q
PRE ; LEX*2.0*80 Pre-Install
S XPDNOQUE=1 I $D(ZTQUEUED) S XPDABORT=1,XPDQUIT=1,XPDQUIT("ICD*18.0*57")=1,XPDQUIT("LEX*2.0*80")=1 Q
Q
POST ; LEX*2.0*80 Post-Install
S XPDNOQUE=1 I $D(ZTQUEUED) S XPDABORT=1,XPDQUIT=1,XPDQUIT("ICD*18.0*57")=1,XPDQUIT("LEX*2.0*80")=1 Q
N LEX1,LEX2,LEX3,LEXA,LEXAC,LEXAO,LEXB,LEXBUILD,LEXC,LEXDUZ,LEXFI,LEXLOUD
N LEXFY,LEXH,LEXI,LEXID,LEXIN,LEXNM,LEXP,LEXPH,LEXPRO,LEXNOPRO,LEXPTYPE
N LEXQTR,LEXS,LEXSTR,LEXSCHG,LEXT,LEXU,LEXUSR,X,Y S LEXNOPRO=""
D IMP^LEX2080 Q:'$L(LEXBUILD) D CON,LOAD,UPD,STATUS^LEX2080A,EN^LEX2080B,DEF S LEXLOUD=1
I '$D(^TMP("LEX*2.0*80",$J,"NODATA")) D:$L($T(POST2^LEXXGP1)) POST2^LEXXGP1
K ^TMP("LEX*2.0*80",$J,"NODATA"),LEXLOUD
Q
LOAD ; Load Data
;
; LEXSHORT Send Short Message
; LEXMSG Flag to send Message
;
N LEXSHORT,LEXMSG,LEXSUBH S LEXSHORT="",LEXMSG=""
S:$L($G(LEXPTYPE)) LEXSUBH=$G(LEXPTYPE) S U="^"
S LEXB=$G(^LEXM(0,"BUILD")) Q:LEXB="" Q:$G(LEXBUILD)=""
I $D(^TMP("LEX*2.0*80",$J,"NODATA")) Q
D:LEXB=LEXBUILD EN^LEXXGI
LQ ; Load Quit
D KLEXM
Q
;
KLEXM ; Subscripted Kill of ^LEXM
H 2 N DA S DA=0 F S DA=$O(^LEXM(DA)) Q:+DA=0 K ^LEXM(DA)
N LEX S LEX=$G(^LEXM(0,"PRO")) K ^LEXM(0)
Q
;
INS ; Install Message
K ^TMP("LEXKID",$J),LEXSCHG N LEXA,LEXAC,LEXAO,LEXB,LEXBUILD,LEXH
N LEXIN,LEXPRO,LEXS,LEXT,LEXU S LEXBUILD="LEX*2.0*80"
S LEXPRO=$$NOT,LEXS="LEX*2.0*80 Installation" H 2
D BL,TL((" "_LEXS)),TL(" ======================="),BL
S LEXAO=" As of: "_$$ED($$NOW^XLFDT) D TL(LEXAO) S LEXAC=""
S LEXA=$$UCI S:$L($P(LEXA,"^",1)) LEXAC=" In Account: "
S LEXAC=LEXAC_$S($L($P(LEXA,"^",1)):"[",1:"")_$P(LEXA,"^",1)_$S($L($P(LEXA,"^",2)):"]",1:"")
S:$L($P(LEXA,"^",2)) LEXAC=LEXAC_" "_$P(LEXA,"^",2) D TL(LEXAC) S LEXU=$$USR
S:$L($P(LEXU,"^",1)) LEXU=" Maint By: "_$P(LEXU,"^",1)_" "_$P(LEXU,"^",2) D TL(LEXU)
S LEXB=" Build: "_LEXBUILD D TL(LEXB) S LEXIN=$P($G(LEXPRO),"^",1) I LEXIN>0 D
. S LEXT=" Protocol: "_"LEXICAL SERVICES UPDATE" D BL,TL(LEXT) S LEXT=" Invoked: "_$$ED(LEXIN) D TL(LEXT),BL
D:+($G(^TMP("LEXKID",$J,0)))>0 MAIL^LEX2080 K ^TMP("LEXKID",$J)
Q
NOT(X) ; Notify by Protocol
N LEXIN,LEXFI,LEXID,LEXP,Y K LEXSCHG S LEXFI=0,LEXIN="",LEXSCHG("LEX")=""
S LEXP=+($O(^ORD(101,"B","LEXICAL SERVICES UPDATE",0))) Q:LEXP=0 "" S X=LEXP_";ORD(101," D EN^XQOR
S:$P($G(LEXSCHG("LEX")),".",1)?7N LEXIN=$G(LEXSCHG("LEX"))
D:+LEXIN>0 BMES^XPDUTL((" Protocol 'LEXICAL SERVICES UPDATE' invoked "_$$ED(LEXIN))),MES^XPDUTL(" ") S X=LEXIN
Q X
;
; Miscellaneous
ED(X) ; External Date
N Y S Y=$$FMTE^XLFDT($G(X)) S:Y["@" Y=$P(Y,"@",1)_" "_$P(Y,"@",2,299) S:$L(Y) X=Y
Q X
UCI(X) ; UCI where Lexicon is installed
N LEXU,LEXP,LEXT,Y X ^%ZOSF("UCI") S LEXU=Y,LEXP=""
S LEXP=$S($$PROD^XUPROD(1):" (Production)",1:" (Test)")
S:LEXU[","&($L($P(LEXU,",",1))>3) LEXU=$P(LEXU,",",1)
S X="",$P(X,"^",1)=LEXU,$P(X,"^",2)=LEXP
Q X
USR(X) ; User/Person Installing
N LEXDUZ,LEXUSR,LEXPH,LEXNM S LEXDUZ=+($G(DUZ)) Q:+LEXDUZ'>0 "UNKNOWN^" S LEXNM=$$GET1^DIQ(200,+LEXDUZ,.01) Q:'$L(LEXNM) "UNKNOWN^"
S LEXUSR=LEXDUZ S LEXPH=$$GET1^DIQ(200,+LEXUSR,.132) S:LEXPH="" LEXPH=$$GET1^DIQ(200,+LEXUSR,.131)
S:LEXPH="" LEXPH=$$GET1^DIQ(200,+LEXUSR,.133) S:LEXPH="" LEXPH=$$GET1^DIQ(200,+LEXUSR,.134)
S LEXUSR=$$GET1^DIQ(200,+LEXDUZ,.01),X=LEXUSR_"^"_LEXPH
Q X
UPD ; Update to data after load
N DA,DIK S DA=5009688
S ^LEX(757.033,DA,0)="10DS02.0^S02.0^3120324^30"
S ^LEX(757.033,DA,1,0)="^757.331D^^1"
S ^LEX(757.033,DA,1,1,0)="3141001^1"
S ^LEX(757.033,DA,2,0)="^757.332D^1^1"
S ^LEX(757.033,DA,2,1,0)="3141001"
S ^LEX(757.033,DA,2,1,1)="Fracture of vault of skull"
S ^LEX(757.033,DA,3,0)="^757.043D^1^1"
S ^LEX(757.033,DA,3,1,0)="3141001"
S ^LEX(757.033,DA,3,1,1)="Fracture of vault of skull"
S DA=5009688,DIK="^LEX(757.033," D IX1^DIK
I $G(^LEX(757.01,332908,5,2,0))="HYPERTENSION" D
. N DA,DIK S DA(1)=332908,DA=2,DIK="^LEX(757.01,"_DA(1)_",5," D ^DIK
I $G(^LEX(757.01,332908,5,3,0))="HYPERTENSIVE" D
. N DA,DIK S DA(1)=332908,DA=3,DIK="^LEX(757.01,"_DA(1)_",5," D ^DIK
I $G(^ICD9(13450,68,2,2,5,0))="HYPERTENSION" D
. N DA,DIK S DA(2)=13450,DA(1)=2,DA=5,DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2," D ^DIK
I $G(^ICD9(13450,68,2,2,6,0))="HYPERTENSIVE" D
. N DA,DIK S DA(2)=13450,DA(1)=2,DA=6,DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2," D ^DIK
I $G(^ICD9(502758,68,1,2,2,0))="HYPERTENSION" D
. N DA,DIK S DA(2)=502758,DA(1)=1,DA=2,DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2," D ^DIK
I $G(^ICD9(502758,68,1,2,3,0))="HYPERTENSIVE" D
. N DA,DIK S DA(2)=502758,DA(1)=1,DA=3,DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2," D ^DIK
S ^ICD9(509440,68,1,2,0)="^80.682^2^2"
S ^ICD9(509440,68,1,2,1,0)="FARM"
S ^ICD9(509440,68,1,2,2,0)="FARMERS"
S DA=509440,DIK="^ICD9(" D IX1^DIK
S ^ICD9(9127,68,1,2,0)="^80.682^1^1"
S ^ICD9(9127,68,1,2,1,0)="FARM"
S DA=9127,DIK="^ICD9(" D IX1^DIK
Q
CON ; Conversion of Data
D DISP,SUBSET,NARR,OPTS,IMP
Q
IMP ; Fix errant Implementation Dates
N CODE F CODE="250.00","294.9" D
. N STA F STA="0",2 K ^LEX(757.02,"ACT",(CODE_" "),STA,3131001)
. N SIEN S SIEN=0 F S SIEN=$O(^LEX(757.02,"CODE",(CODE_" "),SIEN)) Q:+SIEN'>0 D
. . N HIST S HIST=0 F S HIST=$O(^LEX(757.02,+SIEN,4,HIST)) Q:+HIST'>0 D
. . . N ND,DA,DIK,STA,EFF S ND=$G(^LEX(757.02,SIEN,4,HIST,0)),STA=$P(ND,"^",2),EFF=$P(ND,"^",1)
. . . Q:STA'?1N Q:EFF'?7N Q:STA>0 Q:EFF'=3131001
. . . S DA(1)=SIEN,DA=HIST,DIK="^LEX(757.02,"_DA(1)_",4," D ^DIK
. . K ^LEX(757.02,SIEN,4,"B",3131001)
Q
OPTS ; Option Names
N OPT,OIEN,ONAM,FDA,MSG,TIEN,TNM
S OPT="LEX CSV ICD QUERY",OIEN=$$FIND1^DIC(19,,,OPT) I OIEN>0 D
. S ONAM="ICD Diagnosis Code Set Query" S FDA(19,(OIEN_","),1)=ONAM
. S FDA(19,(OIEN_","),1.1)=$$UP^XLFSTR(ONAM)
. D FILE^DIE("E","FDA","MSG")
S OPT="LEX CSV ICP QUERY",OIEN=$$FIND1^DIC(19,,,OPT) I OIEN>0 D
. S ONAM="ICD Procedure Code Set Query" S FDA(19,(OIEN_","),1)=ONAM
. S FDA(19,(OIEN_","),1.1)=$$UP^XLFSTR(ONAM)
. D FILE^DIE("E","FDA","MSG")
S OPT="LEX CSV",OIEN=$$FIND1^DIC(19,,"X",OPT) I OIEN>0 D
. N TID,TIEN,MSG S TID="ICD",TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X",TID,"C",,"MSG")
. S:TIEN'>0 TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X","DX","C",,"MSG") I TIEN>0 D
. . N TNM,FDA,MSG S TNM="DX",FDA(19.01,(TIEN_","_OIEN_","),2)=TNM
. . D FILE^DIE("E","FDA","MSG")
. S TID="ICP",TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X",TID,"C",,"MSG")
. S:TIEN'>0 TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X","PR","C",,"MSG") I TIEN>0 D
. . N TNM,FDA,MSG S TNM="PR",FDA(19.01,(TIEN_","_OIEN_","),2)=TNM
. . D FILE^DIE("E","FDA","MSG")
Q
DISP ; Displays
D BMES^XPDUTL(" Updating ICD displays to include ICD-10")
N IEN,NEW,OLD S IEN=1,OLD="ICD",NEW="ICD/10D" D USER
S IEN=2,OLD="ICD/ICP",NEW="ICD/ICP/10D/10P" D USER
S IEN=3,OLD="ICD/ICP/CPT/CPC",NEW="ICD/ICP/10D/10P/CPT/CPC" D USER
S IEN=4,OLD="ICD/ICP/CPT/CPC/DS4",NEW="ICD/ICP/10D/10P/CPT/CPC/DS4"
D USER S IEN=7,OLD="ICD/ICP/CPT/CPC/DS4/SNM/NAN/OMA/NIC/SCC/SCT"
S NEW="ICD/ICP/10D/10P/CPT/CPC/DS4/SNM/NAN/OMA/NIC/SCC/SCT" D USER
S IEN=8,OLD="ICP/ICD/CPT/CPC/DS3/DS4/SNM/SCC/NAN/NIC/ACR/AIR/COS/"
S OLD=OLD_"CSP/CST/DXP/MCM/UMD/OMA/UWA/SCT"
S NEW="ICP/ICD/10D/10P/CPT/CPC/DS3/DS4/SNM/SCC/NAN/NIC/ACR/AIR/"
S NEW=NEW_"COS/CSP/CST/DXP/MCM/UMD/OMA/UWA/SCT" D USER
S IEN=9,OLD="DS4/ICD",NEW="DS4/ICD/10D" D USER
Q
DEF ; Definitions file hard re-index
K ^LEXT(757.2,"AA"),^LEXT(757.2,"AB"),^LEXT(757.2,"ADEF")
K ^LEXT(757.2,"AN"),^LEXT(757.2,"APPS"),^LEXT(757.2,"AUD")
K ^LEXT(757.2,"B"),^LEXT(757.2,"C"),^LEXT(757.2,"D")
K ^LEXT(757.2,1,200,"B"),^LEXT(757.2,4,200,"B")
N IEN S IEN=0 F S IEN=$O(^LEXT(757.2,IEN)) Q:+IEN'>0 D
. N DA,DIK S DA=IEN,DIK="^LEXT(757.2," D IX1^DIK
Q
USER ; User Display Update
Q:+($G(IEN))'>0 Q:'$L($G(OLD)) Q:'$L($G(NEW)) Q:$L(NEW)'>$L(OLD)
Q:'$D(^LEX(757.31,+IEN,0)) Q:'$D(^LEX(757.31,+IEN,1))
S ^LEX(757.31,+IEN,1)=NEW N APP,USR,DEF
S APP=0 F S APP=$O(^LEXT(757.2,APP)) Q:+APP'>0 D
. S USR=0 F S USR=$O(^LEXT(757.2,APP,200,USR)) Q:+USR'>0 D
. . I $G(^LEXT(757.2,APP,200,USR,2))=OLD D
. . . S ^LEXT(757.2,APP,200,USR,2)=NEW
Q
SUBSET ; Sub-Sets
S ^LEXT(757.2,21,0)="ICD-10 Diagnosis",^LEXT(757.2,21,1)="^LEX(757.01,",^LEXT(757.2,21,2)="XTLK^LEXHLP"
S ^LEXT(757.2,21,3)="XTLK^LEXPRNT",^LEXT(757.2,21,4)="10D",^LEXT(757.2,21,5)="10D^WRD^0^80^10D^0^1"
S ^LEXT(757.2,21,6)="I $L($$ONE^LEXU(+Y,+($G(LEXVDT)),""10D""))"
S ^LEXT(757.2,21,7)="10D",^LEXT(757.2,21,100,0)="^^3^3^3111115^^^^"
S ^LEXT(757.2,21,100,1,0)="This subset is artifically created through the use of"
S ^LEXT(757.2,21,100,2,0)="a filter which will not permit the selection of a term"
S ^LEXT(757.2,21,100,3,0)="which does not have a valid ICD-10 Diagnosis code assigned."
S ^LEXT(757.2,22,0)="ICD-10 Procedures",^LEXT(757.2,22,1)="^LEX(757.01,",^LEXT(757.2,22,2)="XTLK^LEXHLP"
S ^LEXT(757.2,22,3)="XTLK^LEXPRNT",^LEXT(757.2,22,4)="10P",^LEXT(757.2,22,5)="10P^WRD^0^80^10P^0^1"
S ^LEXT(757.2,22,6)="I $L($$ONE^LEXU(+Y,+($G(LEXVDT)),""10P""))"
S ^LEXT(757.2,22,7)="10P",^LEXT(757.2,22,100,0)="^^3^3^3111115^^^^"
S ^LEXT(757.2,22,100,1,0)="This subset is artifically created through the use of"
S ^LEXT(757.2,22,100,2,0)="a filter which will not permit the selection of a term"
S ^LEXT(757.2,22,100,3,0)="which does not have a valid ICD-10 Procedure code assigned."
N DA,DIK S DIK="^LEXT(757.2," F DA=21,22 D IX1^DIK
Q
NARR ; Narratives
K ^LEX(757.06) S ^LEX(757.06,0)="UNRESOLVED NARRATIVES^757.06^^0"
Q
BL ; Blank Line
D TL(" ")
Q
TL(X) ; Text Line
N LEXI S LEXI=$O(^TMP("LEXKID",$J," "),-1),LEXI=LEXI+1,^TMP("LEXKID",$J,LEXI)=$G(X),^TMP("LEXKID",$J,0)=LEXI
Q
M(X) ; Blank/Text
D MES^XPDUTL($G(X)) Q
BM(X) ; Blank/Text
D BMES^XPDUTL($G(X)) Q
CLR ;
N ZTQUEUED,XPDABORT,XPDQUIT,XPDQUIT
Q
LEX2080P ;ISL/KER - LEX*2.0*80 Pre/Post Install ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^%ZOSF("UCI") ICR 10096
+5 ; ^LEX(757.31 N/A
+6 ; ^LEXM( N/A
+7 ; ^ORD(101, ICR 872
+8 ; ^TMP("LEXKID") SACC 2.3.2.5.1
+9 ; ^TMP(BUILD) SACC 2.3.2.5.1
+10 ;
+11 ; External References
+12 ; $$FIND1^DIC ICR 2051
+13 ; FILE^DIE ICR 2053
+14 ; ^DIK ICR 10013
+15 ; IX1^DIK ICR 10013
+16 ; IX2^DIK ICR 10013
+17 ; $$GET1^DIQ ICR 2056
+18 ; $$FMTE^XLFDT ICR 10103
+19 ; $$NOW^XLFDT ICR 10103
+20 ; $$UP^XLFSTR ICR 10104
+21 ; BMES^XPDUTL ICR 10141
+22 ; MES^XPDUTL ICR 10141
+23 ; EN^XQOR ICR 10101
+24 ;
+25 ; Local Variables NEWed or KILLed by Kernel
+26 ; XPDNOQUE
+27 ;
+28 QUIT
PRE ; LEX*2.0*80 Pre-Install
+1 SET XPDNOQUE=1
IF $DATA(ZTQUEUED)
SET XPDABORT=1
SET XPDQUIT=1
SET XPDQUIT("ICD*18.0*57")=1
SET XPDQUIT("LEX*2.0*80")=1
QUIT
+2 QUIT
POST ; LEX*2.0*80 Post-Install
+1 SET XPDNOQUE=1
IF $DATA(ZTQUEUED)
SET XPDABORT=1
SET XPDQUIT=1
SET XPDQUIT("ICD*18.0*57")=1
SET XPDQUIT("LEX*2.0*80")=1
QUIT
+2 NEW LEX1,LEX2,LEX3,LEXA,LEXAC,LEXAO,LEXB,LEXBUILD,LEXC,LEXDUZ,LEXFI,LEXLOUD
+3 NEW LEXFY,LEXH,LEXI,LEXID,LEXIN,LEXNM,LEXP,LEXPH,LEXPRO,LEXNOPRO,LEXPTYPE
+4 NEW LEXQTR,LEXS,LEXSTR,LEXSCHG,LEXT,LEXU,LEXUSR,X,Y
SET LEXNOPRO=""
+5 DO IMP^LEX2080
IF '$LENGTH(LEXBUILD)
QUIT
DO CON
DO LOAD
DO UPD
DO STATUS^LEX2080A
DO EN^LEX2080B
DO DEF
SET LEXLOUD=1
+6 IF '$DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
IF $LENGTH($TEXT(POST2^LEXXGP1))
DO POST2^LEXXGP1
+7 KILL ^TMP("LEX*2.0*80",$JOB,"NODATA"),LEXLOUD
+8 QUIT
LOAD ; Load Data
+1 ;
+2 ; LEXSHORT Send Short Message
+3 ; LEXMSG Flag to send Message
+4 ;
+5 NEW LEXSHORT,LEXMSG,LEXSUBH
SET LEXSHORT=""
SET LEXMSG=""
+6 IF $LENGTH($GET(LEXPTYPE))
SET LEXSUBH=$GET(LEXPTYPE)
SET U="^"
+7 SET LEXB=$GET(^LEXM(0,"BUILD"))
IF LEXB=""
QUIT
IF $GET(LEXBUILD)=""
QUIT
+8 IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
QUIT
+9 IF LEXB=LEXBUILD
DO EN^LEXXGI
LQ ; Load Quit
+1 DO KLEXM
+2 QUIT
+3 ;
KLEXM ; Subscripted Kill of ^LEXM
+1 HANG 2
NEW DA
SET DA=0
FOR
SET DA=$ORDER(^LEXM(DA))
IF +DA=0
QUIT
KILL ^LEXM(DA)
+2 NEW LEX
SET LEX=$GET(^LEXM(0,"PRO"))
KILL ^LEXM(0)
+3 QUIT
+4 ;
INS ; Install Message
+1 KILL ^TMP("LEXKID",$JOB),LEXSCHG
NEW LEXA,LEXAC,LEXAO,LEXB,LEXBUILD,LEXH
+2 NEW LEXIN,LEXPRO,LEXS,LEXT,LEXU
SET LEXBUILD="LEX*2.0*80"
+3 SET LEXPRO=$$NOT
SET LEXS="LEX*2.0*80 Installation"
HANG 2
+4 DO BL
DO TL((" "_LEXS))
DO TL(" =======================")
DO BL
+5 SET LEXAO=" As of: "_$$ED($$NOW^XLFDT)
DO TL(LEXAO)
SET LEXAC=""
+6 SET LEXA=$$UCI
IF $LENGTH($PIECE(LEXA,"^",1))
SET LEXAC=" In Account: "
+7 SET LEXAC=LEXAC_$SELECT($LENGTH($PIECE(LEXA,"^",1)):"[",1:"")_$PIECE(LEXA,"^",1)_$SELECT($LENGTH($PIECE(LEXA,"^",2)):"]",1:"")
+8 IF $LENGTH($PIECE(LEXA,"^",2))
SET LEXAC=LEXAC_" "_$PIECE(LEXA,"^",2)
DO TL(LEXAC)
SET LEXU=$$USR
+9 IF $LENGTH($PIECE(LEXU,"^",1))
SET LEXU=" Maint By: "_$PIECE(LEXU,"^",1)_" "_$PIECE(LEXU,"^",2)
DO TL(LEXU)
+10 SET LEXB=" Build: "_LEXBUILD
DO TL(LEXB)
SET LEXIN=$PIECE($GET(LEXPRO),"^",1)
IF LEXIN>0
Begin DoDot:1
+11 SET LEXT=" Protocol: "_"LEXICAL SERVICES UPDATE"
DO BL
DO TL(LEXT)
SET LEXT=" Invoked: "_$$ED(LEXIN)
DO TL(LEXT)
DO BL
End DoDot:1
+12 IF +($GET(^TMP("LEXKID",$JOB,0)))>0
DO MAIL^LEX2080
KILL ^TMP("LEXKID",$JOB)
+13 QUIT
NOT(X) ; Notify by Protocol
+1 NEW LEXIN,LEXFI,LEXID,LEXP,Y
KILL LEXSCHG
SET LEXFI=0
SET LEXIN=""
SET LEXSCHG("LEX")=""
+2 SET LEXP=+($ORDER(^ORD(101,"B","LEXICAL SERVICES UPDATE",0)))
IF LEXP=0
QUIT ""
SET X=LEXP_";ORD(101,"
DO EN^XQOR
+3 IF $PIECE($GET(LEXSCHG("LEX")),".",1)?7N
SET LEXIN=$GET(LEXSCHG("LEX"))
+4 IF +LEXIN>0
DO BMES^XPDUTL((" Protocol 'LEXICAL SERVICES UPDATE' invoked "_$$ED(LEXIN)))
DO MES^XPDUTL(" ")
SET X=LEXIN
+5 QUIT X
+6 ;
+7 ; Miscellaneous
ED(X) ; External Date
+1 NEW Y
SET Y=$$FMTE^XLFDT($GET(X))
IF Y["@"
SET Y=$PIECE(Y,"@",1)_" "_$PIECE(Y,"@",2,299)
IF $LENGTH(Y)
SET X=Y
+2 QUIT X
UCI(X) ; UCI where Lexicon is installed
+1 NEW LEXU,LEXP,LEXT,Y
XECUTE ^%ZOSF("UCI")
SET LEXU=Y
SET LEXP=""
+2 SET LEXP=$SELECT($$PROD^XUPROD(1):" (Production)",1:" (Test)")
+3 IF LEXU[","&($LENGTH($PIECE(LEXU,",",1))>3)
SET LEXU=$PIECE(LEXU,",",1)
+4 SET X=""
SET $PIECE(X,"^",1)=LEXU
SET $PIECE(X,"^",2)=LEXP
+5 QUIT X
USR(X) ; User/Person Installing
+1 NEW LEXDUZ,LEXUSR,LEXPH,LEXNM
SET LEXDUZ=+($GET(DUZ))
IF +LEXDUZ'>0
QUIT "UNKNOWN^"
SET LEXNM=$$GET1^DIQ(200,+LEXDUZ,.01)
IF '$LENGTH(LEXNM)
QUIT "UNKNOWN^"
+2 SET LEXUSR=LEXDUZ
SET LEXPH=$$GET1^DIQ(200,+LEXUSR,.132)
IF LEXPH=""
SET LEXPH=$$GET1^DIQ(200,+LEXUSR,.131)
+3 IF LEXPH=""
SET LEXPH=$$GET1^DIQ(200,+LEXUSR,.133)
IF LEXPH=""
SET LEXPH=$$GET1^DIQ(200,+LEXUSR,.134)
+4 SET LEXUSR=$$GET1^DIQ(200,+LEXDUZ,.01)
SET X=LEXUSR_"^"_LEXPH
+5 QUIT X
UPD ; Update to data after load
+1 NEW DA,DIK
SET DA=5009688
+2 SET ^LEX(757.033,DA,0)="10DS02.0^S02.0^3120324^30"
+3 SET ^LEX(757.033,DA,1,0)="^757.331D^^1"
+4 SET ^LEX(757.033,DA,1,1,0)="3141001^1"
+5 SET ^LEX(757.033,DA,2,0)="^757.332D^1^1"
+6 SET ^LEX(757.033,DA,2,1,0)="3141001"
+7 SET ^LEX(757.033,DA,2,1,1)="Fracture of vault of skull"
+8 SET ^LEX(757.033,DA,3,0)="^757.043D^1^1"
+9 SET ^LEX(757.033,DA,3,1,0)="3141001"
+10 SET ^LEX(757.033,DA,3,1,1)="Fracture of vault of skull"
+11 SET DA=5009688
SET DIK="^LEX(757.033,"
DO IX1^DIK
+12 IF $GET(^LEX(757.01,332908,5,2,0))="HYPERTENSION"
Begin DoDot:1
+13 NEW DA,DIK
SET DA(1)=332908
SET DA=2
SET DIK="^LEX(757.01,"_DA(1)_",5,"
DO ^DIK
End DoDot:1
+14 IF $GET(^LEX(757.01,332908,5,3,0))="HYPERTENSIVE"
Begin DoDot:1
+15 NEW DA,DIK
SET DA(1)=332908
SET DA=3
SET DIK="^LEX(757.01,"_DA(1)_",5,"
DO ^DIK
End DoDot:1
+16 IF $GET(^ICD9(13450,68,2,2,5,0))="HYPERTENSION"
Begin DoDot:1
+17 NEW DA,DIK
SET DA(2)=13450
SET DA(1)=2
SET DA=5
SET DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2,"
DO ^DIK
End DoDot:1
+18 IF $GET(^ICD9(13450,68,2,2,6,0))="HYPERTENSIVE"
Begin DoDot:1
+19 NEW DA,DIK
SET DA(2)=13450
SET DA(1)=2
SET DA=6
SET DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2,"
DO ^DIK
End DoDot:1
+20 IF $GET(^ICD9(502758,68,1,2,2,0))="HYPERTENSION"
Begin DoDot:1
+21 NEW DA,DIK
SET DA(2)=502758
SET DA(1)=1
SET DA=2
SET DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2,"
DO ^DIK
End DoDot:1
+22 IF $GET(^ICD9(502758,68,1,2,3,0))="HYPERTENSIVE"
Begin DoDot:1
+23 NEW DA,DIK
SET DA(2)=502758
SET DA(1)=1
SET DA=3
SET DIK="^ICD9("_DA(2)_",68,"_DA(1)_",2,"
DO ^DIK
End DoDot:1
+24 SET ^ICD9(509440,68,1,2,0)="^80.682^2^2"
+25 SET ^ICD9(509440,68,1,2,1,0)="FARM"
+26 SET ^ICD9(509440,68,1,2,2,0)="FARMERS"
+27 SET DA=509440
SET DIK="^ICD9("
DO IX1^DIK
+28 SET ^ICD9(9127,68,1,2,0)="^80.682^1^1"
+29 SET ^ICD9(9127,68,1,2,1,0)="FARM"
+30 SET DA=9127
SET DIK="^ICD9("
DO IX1^DIK
+31 QUIT
CON ; Conversion of Data
+1 DO DISP
DO SUBSET
DO NARR
DO OPTS
DO IMP
+2 QUIT
IMP ; Fix errant Implementation Dates
+1 NEW CODE
FOR CODE="250.00","294.9"
Begin DoDot:1
+2 NEW STA
FOR STA="0",2
KILL ^LEX(757.02,"ACT",(CODE_" "),STA,3131001)
+3 NEW SIEN
SET SIEN=0
FOR
SET SIEN=$ORDER(^LEX(757.02,"CODE",(CODE_" "),SIEN))
IF +SIEN'>0
QUIT
Begin DoDot:2
+4 NEW HIST
SET HIST=0
FOR
SET HIST=$ORDER(^LEX(757.02,+SIEN,4,HIST))
IF +HIST'>0
QUIT
Begin DoDot:3
+5 NEW ND,DA,DIK,STA,EFF
SET ND=$GET(^LEX(757.02,SIEN,4,HIST,0))
SET STA=$PIECE(ND,"^",2)
SET EFF=$PIECE(ND,"^",1)
+6 IF STA'?1N
QUIT
IF EFF'?7N
QUIT
IF STA>0
QUIT
IF EFF'=3131001
QUIT
+7 SET DA(1)=SIEN
SET DA=HIST
SET DIK="^LEX(757.02,"_DA(1)_",4,"
DO ^DIK
End DoDot:3
+8 KILL ^LEX(757.02,SIEN,4,"B",3131001)
End DoDot:2
End DoDot:1
+9 QUIT
OPTS ; Option Names
+1 NEW OPT,OIEN,ONAM,FDA,MSG,TIEN,TNM
+2 SET OPT="LEX CSV ICD QUERY"
SET OIEN=$$FIND1^DIC(19,,,OPT)
IF OIEN>0
Begin DoDot:1
+3 SET ONAM="ICD Diagnosis Code Set Query"
SET FDA(19,(OIEN_","),1)=ONAM
+4 SET FDA(19,(OIEN_","),1.1)=$$UP^XLFSTR(ONAM)
+5 DO FILE^DIE("E","FDA","MSG")
End DoDot:1
+6 SET OPT="LEX CSV ICP QUERY"
SET OIEN=$$FIND1^DIC(19,,,OPT)
IF OIEN>0
Begin DoDot:1
+7 SET ONAM="ICD Procedure Code Set Query"
SET FDA(19,(OIEN_","),1)=ONAM
+8 SET FDA(19,(OIEN_","),1.1)=$$UP^XLFSTR(ONAM)
+9 DO FILE^DIE("E","FDA","MSG")
End DoDot:1
+10 SET OPT="LEX CSV"
SET OIEN=$$FIND1^DIC(19,,"X",OPT)
IF OIEN>0
Begin DoDot:1
+11 NEW TID,TIEN,MSG
SET TID="ICD"
SET TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X",TID,"C",,"MSG")
+12 IF TIEN'>0
SET TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X","DX","C",,"MSG")
IF TIEN>0
Begin DoDot:2
+13 NEW TNM,FDA,MSG
SET TNM="DX"
SET FDA(19.01,(TIEN_","_OIEN_","),2)=TNM
+14 DO FILE^DIE("E","FDA","MSG")
End DoDot:2
+15 SET TID="ICP"
SET TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X",TID,"C",,"MSG")
+16 IF TIEN'>0
SET TIEN=$$FIND1^DIC(19.01,(","_OIEN_","),"X","PR","C",,"MSG")
IF TIEN>0
Begin DoDot:2
+17 NEW TNM,FDA,MSG
SET TNM="PR"
SET FDA(19.01,(TIEN_","_OIEN_","),2)=TNM
+18 DO FILE^DIE("E","FDA","MSG")
End DoDot:2
End DoDot:1
+19 QUIT
DISP ; Displays
+1 DO BMES^XPDUTL(" Updating ICD displays to include ICD-10")
+2 NEW IEN,NEW,OLD
SET IEN=1
SET OLD="ICD"
SET NEW="ICD/10D"
DO USER
+3 SET IEN=2
SET OLD="ICD/ICP"
SET NEW="ICD/ICP/10D/10P"
DO USER
+4 SET IEN=3
SET OLD="ICD/ICP/CPT/CPC"
SET NEW="ICD/ICP/10D/10P/CPT/CPC"
DO USER
+5 SET IEN=4
SET OLD="ICD/ICP/CPT/CPC/DS4"
SET NEW="ICD/ICP/10D/10P/CPT/CPC/DS4"
+6 DO USER
SET IEN=7
SET OLD="ICD/ICP/CPT/CPC/DS4/SNM/NAN/OMA/NIC/SCC/SCT"
+7 SET NEW="ICD/ICP/10D/10P/CPT/CPC/DS4/SNM/NAN/OMA/NIC/SCC/SCT"
DO USER
+8 SET IEN=8
SET OLD="ICP/ICD/CPT/CPC/DS3/DS4/SNM/SCC/NAN/NIC/ACR/AIR/COS/"
+9 SET OLD=OLD_"CSP/CST/DXP/MCM/UMD/OMA/UWA/SCT"
+10 SET NEW="ICP/ICD/10D/10P/CPT/CPC/DS3/DS4/SNM/SCC/NAN/NIC/ACR/AIR/"
+11 SET NEW=NEW_"COS/CSP/CST/DXP/MCM/UMD/OMA/UWA/SCT"
DO USER
+12 SET IEN=9
SET OLD="DS4/ICD"
SET NEW="DS4/ICD/10D"
DO USER
+13 QUIT
DEF ; Definitions file hard re-index
+1 KILL ^LEXT(757.2,"AA"),^LEXT(757.2,"AB"),^LEXT(757.2,"ADEF")
+2 KILL ^LEXT(757.2,"AN"),^LEXT(757.2,"APPS"),^LEXT(757.2,"AUD")
+3 KILL ^LEXT(757.2,"B"),^LEXT(757.2,"C"),^LEXT(757.2,"D")
+4 KILL ^LEXT(757.2,1,200,"B"),^LEXT(757.2,4,200,"B")
+5 NEW IEN
SET IEN=0
FOR
SET IEN=$ORDER(^LEXT(757.2,IEN))
IF +IEN'>0
QUIT
Begin DoDot:1
+6 NEW DA,DIK
SET DA=IEN
SET DIK="^LEXT(757.2,"
DO IX1^DIK
End DoDot:1
+7 QUIT
USER ; User Display Update
+1 IF +($GET(IEN))'>0
QUIT
IF '$LENGTH($GET(OLD))
QUIT
IF '$LENGTH($GET(NEW))
QUIT
IF $LENGTH(NEW)'>$LENGTH(OLD)
QUIT
+2 IF '$DATA(^LEX(757.31,+IEN,0))
QUIT
IF '$DATA(^LEX(757.31,+IEN,1))
QUIT
+3 SET ^LEX(757.31,+IEN,1)=NEW
NEW APP,USR,DEF
+4 SET APP=0
FOR
SET APP=$ORDER(^LEXT(757.2,APP))
IF +APP'>0
QUIT
Begin DoDot:1
+5 SET USR=0
FOR
SET USR=$ORDER(^LEXT(757.2,APP,200,USR))
IF +USR'>0
QUIT
Begin DoDot:2
+6 IF $GET(^LEXT(757.2,APP,200,USR,2))=OLD
Begin DoDot:3
+7 SET ^LEXT(757.2,APP,200,USR,2)=NEW
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
SUBSET ; Sub-Sets
+1 SET ^LEXT(757.2,21,0)="ICD-10 Diagnosis"
SET ^LEXT(757.2,21,1)="^LEX(757.01,"
SET ^LEXT(757.2,21,2)="XTLK^LEXHLP"
+2 SET ^LEXT(757.2,21,3)="XTLK^LEXPRNT"
SET ^LEXT(757.2,21,4)="10D"
SET ^LEXT(757.2,21,5)="10D^WRD^0^80^10D^0^1"
+3 SET ^LEXT(757.2,21,6)="I $L($$ONE^LEXU(+Y,+($G(LEXVDT)),""10D""))"
+4 SET ^LEXT(757.2,21,7)="10D"
SET ^LEXT(757.2,21,100,0)="^^3^3^3111115^^^^"
+5 SET ^LEXT(757.2,21,100,1,0)="This subset is artifically created through the use of"
+6 SET ^LEXT(757.2,21,100,2,0)="a filter which will not permit the selection of a term"
+7 SET ^LEXT(757.2,21,100,3,0)="which does not have a valid ICD-10 Diagnosis code assigned."
+8 SET ^LEXT(757.2,22,0)="ICD-10 Procedures"
SET ^LEXT(757.2,22,1)="^LEX(757.01,"
SET ^LEXT(757.2,22,2)="XTLK^LEXHLP"
+9 SET ^LEXT(757.2,22,3)="XTLK^LEXPRNT"
SET ^LEXT(757.2,22,4)="10P"
SET ^LEXT(757.2,22,5)="10P^WRD^0^80^10P^0^1"
+10 SET ^LEXT(757.2,22,6)="I $L($$ONE^LEXU(+Y,+($G(LEXVDT)),""10P""))"
+11 SET ^LEXT(757.2,22,7)="10P"
SET ^LEXT(757.2,22,100,0)="^^3^3^3111115^^^^"
+12 SET ^LEXT(757.2,22,100,1,0)="This subset is artifically created through the use of"
+13 SET ^LEXT(757.2,22,100,2,0)="a filter which will not permit the selection of a term"
+14 SET ^LEXT(757.2,22,100,3,0)="which does not have a valid ICD-10 Procedure code assigned."
+15 NEW DA,DIK
SET DIK="^LEXT(757.2,"
FOR DA=21,22
DO IX1^DIK
+16 QUIT
NARR ; Narratives
+1 KILL ^LEX(757.06)
SET ^LEX(757.06,0)="UNRESOLVED NARRATIVES^757.06^^0"
+2 QUIT
BL ; Blank Line
+1 DO TL(" ")
+2 QUIT
TL(X) ; Text Line
+1 NEW LEXI
SET LEXI=$ORDER(^TMP("LEXKID",$JOB," "),-1)
SET LEXI=LEXI+1
SET ^TMP("LEXKID",$JOB,LEXI)=$GET(X)
SET ^TMP("LEXKID",$JOB,0)=LEXI
+2 QUIT
M(X) ; Blank/Text
+1 DO MES^XPDUTL($GET(X))
QUIT
BM(X) ; Blank/Text
+1 DO BMES^XPDUTL($GET(X))
QUIT
CLR ;
+1 NEW ZTQUEUED,XPDABORT,XPDQUIT,XPDQUIT
+2 QUIT
