ICD1857 ;ISL/KER - ICD*18.0*57 Env Check ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
;
;
; Global Variables
; ^%ZOSF("UCI") ICR 10096
; ^%ZOSF("UCICHECK") ICR 10096
; ^ICD0(1535) N/A
; ^ICD0(1548) N/A
; ^ICD0(366) N/A
; ^ICD9(11938) N/A
; ^ICD9(3066) N/A
; ^TMP("ICDKID") SACC 2.3.2.5.1
; ^TMP("ICDMSG") SACC 2.3.2.5.1
;
; External References
; $$FMTE^XLFDT ICR 10103
; $$GET1^DIQ ICR 2056
; $$IENS^DILF ICR 2054
; $$NETNAME^XMXUTIL ICR 2734
; $$PATCH^XPDUTL ICR 10141
; $$PKG^XPDUTL ICR 10141
; $$VERSION^XPDUTL ICR 10141
; $$VER^XPDUTL ICR 10141
; BMES^XPDUTL ICR 10141
; EN^DIQ1 ICR 10015
; FIELD^DID ICR 2052
; FILE^DID ICR 2052
; FIND^DIC ICR 2051
; BMES^XPDUTL ICR 10141
; FIND^DIC ICR 2051
; ^DIR ICR 10026
; ^XMD ICR 10070
;
; Local Variables NEWed or KILLed Elsewhere
; XPDABORT,XPDDIQ,XPDENV,XPDQUIT
;
ENV ; ICD*18.0*57 Environment Check
; Checks
S XPDNOQUE=1 N DA,DIC,DIFROM,DIQ,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,ICD,ICD10,ICD9,ICDADR,ICDATA,ICDBUILD,ICDC,ICDC1,ICDC2,ICDC3
N ICDC4,ICDCOM,ICDCONT,ICDD,ICDDA,ICDDD,ICDDT,ICDE,ICDENT,ICDF,ICDFI,ICDFULL,ICDFY,ICDG,ICDGBL,ICDI,ICDIEN,ICDIGHF
N ICDINE,ICDINS,ICDLREV,ICDM,ICDMSG,ICDNM,ICDNS,ICDO,ICDOUT,ICDP,ICDPAT,ICDPI,ICDPK,ICDPN,ICDPRI,ICDPT,ICDPTYPE
N ICDQTR,ICDR,ICDREL,ICDREQ,ICDREQP,ICDRT,ICDRV,ICDSCR,ICDSTR,ICDSUB,ICDT,ICDUCI,ICDV,ICDVD,ICDVI,ICDVER,ICDVR
N IEN,X,XCNP,XMDUZ,XMSCR,XMSUB,XMTEXT,XMY,XMZ,Y D IMP K XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B")
S XPDDIQ("XPZ1","B")="NO",XPDDIQ("XPI1","B")="NO",U="^"
; User Variables
D:+($$UR)'>0 ET("User not defined (DUZ)")
; System Variables
D:+($$SY)'>0 ET("Undefined IO variable(s)")
; Data
N ICDTEST D:+($$GOK)'>0 ET("Cannot locate import data global ^LEXM")
I $D(ICDE) D ABRT Q
; Version Number
W !,?3,"Checking for ICD Version installations",!
S ICDVER="ICD 18.0" S ICDINS=$$VER(ICDVER) I +ICDINS'>0 D D ABRT Q
. D ET(" Version 18.0 not found. Please install ICD v 18.0")
I +ICDINS>0,$P(ICDINS,"^",1)?7N,$L($P(ICDINS,"^",2)) D
. W !,?5,ICDVER," installed ",$P(ICDINS,"^",2)
S ICDVER="ICD*18.0*57" S ICDINS=$$VER(ICDVER)
I +ICDINS>0,$P(ICDINS,"^",1)?7N,$L($P(ICDINS,"^",2)) D
. W !,?5,ICDVER," installed ",$P(ICDINS,"^",2)
; Required Patches
D:$O(ICDREQP(0))'>0 IMP I $O(ICDREQP(0))>0 D
. W ! N ICDPAT,ICDI,ICDPN,ICDP,ICDR,ICDC,ICDO,ICDC1,ICDC2,ICDC3,ICDC4,ICD
. S (ICDR,ICDC)=0 S ICDC1=3,(ICDC2,ICDC3,ICDC4)=20,ICDC2=18
. S ICDI=0 F S ICDI=$O(ICDREQP(ICDI)) Q:+ICDI'>0 D
. . S ICDC=ICDC+1,ICDPAT=$G(ICDREQP(ICDI))
. . S:$P(ICDPAT,"^",2)?7N ICDR=ICDR+1,ICDC3=ICDC2+13,ICDC4=ICDC2+36
. S ICDI=0 F S ICDI=$O(ICDREQP(ICDI)) Q:+ICDI'>0 D
. . N ICDPAT,ICDREL,ICDINS,ICDCOM,ICDINE,ICDREQ S ICDREQ=$G(ICDREQP(ICDI))
. . S ICDPAT=$P(ICDREQ,"^",1),ICDREL=$P(ICDREQ,"^",2),ICDCOM=$P(ICDREQ,"^",3)
. . S ICDPN=$$INS(ICDPAT) S ICDINS=$$INSD(ICDPAT),ICDINE=$P(ICDINS,"^",2)
. . W:ICDI=1 !,?3,"Checking for ",?ICDC2,$S(+($G(ICDR))>0:"Released",1:"")
. . W !,?ICDC1,ICDPAT
. . W:ICDREL?7N ?ICDC2,$TR($$FMTE^XLFDT(ICDREL,"5DZ"),"@"," ")
. . I +ICDPN>0 D
. . . S ICDO=+($G(ICDO))+1 W ?ICDC3,"Installed " W:$L($G(ICDINE)) ICDINE
. . . W:+ICDC4>0&(+ICDC4>ICDC3)&($L(ICDCOM)) ?ICDC4,ICDCOM
. . I +ICDPN'>0 D ET((" "_ICDPAT_" not found, please install "_ICDPAT_" before continuing"))
. W:+($G(ICDO))'=ICDC !
; UCI
I +($$UOK)'>0&('$D(ICDTEST)) W ! D ET("Unable to install in this UCI") G ABRT
D STATUS S ICDCONT=$$CONT I +ICDCONT'>0 W ! D ET(" User aborted install") G ABRT
I $D(ICDE) D ABRT Q
I '$D(ICDFULL)&(+($G(XPDENV))'=1) D QUIT Q
; Quit, Exit or Abort
QUIT ; Quit Passed Environment Check
K ICDFULL D OK
Q
EXIT ; Exit Failed Environment Check
D:$D(ICDE) ED S XPDQUIT=2 K ICDE,ICDFULL Q
ABRT ; Abort Failed Environment Check, KILL the distribution
D:$D(ICDE) ED S XPDABORT=1,XPDQUIT=1,XPDQUIT("ICD*18.0*57")=1,XPDQUIT("LEX*2.0*80")=1
K ICDE,ICDFULL
Q
SY(X) ; Check System variables
Q:'$D(IO)!('$D(IOF))!('$D(IOM))!('$D(ION))!('$D(IOSL))!('$D(IOST)) 0
Q 1
UR(X) ; Check User variables
Q:'$L($G(DUZ(0))) 0
Q:+($G(DUZ))=0!($$NOTDEF(+$G(DUZ))) 0
Q 1
ET(X) ; Error Text
N ICDI S ICDI=+($G(ICDE(0))),ICDI=ICDI+1,ICDE(ICDI)=" "_$G(X),ICDE(0)=ICDI
Q
ED ; Error Display
N ICDI S ICDI=0 F S ICDI=$O(ICDE(ICDI)) Q:+ICDI=0 D M(ICDE(ICDI))
D M(" ") K ICDE Q
NOTDEF(X) ; Check to see if user is defined
N DA,DR,DIQ,ICD,DIC S DA=+($G(X)),DR=.01,DIC=200,DIQ="ICD" D EN^DIQ1 Q '$D(ICD)
OK ; Environment is OK
N ICDPTYPE,ICDLREV,ICDREQP,ICDBUILD,ICDIGHF,ICDFY,ICDQTR,ICDT
D IMP S ICDT=" Environment "_$S($L(ICDBUILD):("for patch/build "_ICDBUILD_" "),1:"")_"is ok"
D BM(ICDT),M(" ")
Q
MAIL ; Mail global array in message
N DIFROM,ICDPRI,ICDADR,ICDI,ICDM,ICDSUB,XCNP,XMDUZ,XMSCR,XMSUB,XMTEXT,XMY,XMZ,ICDPTYPE,ICDLREV,ICDREQP,ICDBUILD,ICDIGHF,ICDFY,ICDQTR
D IMP K ^TMP("ICDMSG",$J) S ICDSUB="Lexicon/ICD-10 Installation" S:$L($G(ICDBUILD)) ICDSUB=$G(ICDBUILD)_" Installation"
S ICDPRI=$$ADR G:'$L(ICDPRI) MAILQ S ICDPRI="G.ICDINS@"_ICDPRI S ICDADR=$$GET1^DIQ(200,+($G(DUZ)),.01) G:'$L(ICDADR) MAILQ
S XMSUB=ICDSUB S ICDI=0 F S ICDI=$O(^TMP("ICDKID",$J,ICDI)) Q:+ICDI=0 D
. S ICDM=+($O(^TMP("ICDMSG",$J," "),-1))+1,^TMP("ICDMSG",$J,ICDM,0)=$E($G(^TMP("ICDKID",$J,ICDI)),1,79),^TMP("ICDMSG",$J,0)=ICDM
K ^TMP("ICDKID",$J) G:'$D(^TMP("ICDMSG",$J)) MAILQ G:+($G(^TMP("ICDMSG",$J,0)))'>0 MAILQ S XMY(ICDPRI)="",XMY(ICDADR)=""
S XMTEXT="^TMP(""ICDMSG"",$J,",XMDUZ=.5 D ^XMD
MAILQ ; Quit Mail
D KILL K XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMY,XMTEXT,XMDUZ
Q
ADR(ICD) ; Mailing Address
N DIC,DTOUT,DUOUT,X,Y S DIC="^DIC(4.2,",DIC(0)="M",(ICD,X)="FO-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 ICD
S DIC="^DIC(4.2,",DIC(0)="M",(ICD,X)="ISC-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 ICD
Q "ISC-SLC.VA.GOV"
KILL ; Kill all ^TMP(
K ^TMP("ICDMSG",$J),^TMP("ICDKID",$J)
Q
CONT(X) ; Continue
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y
W !!," WARNING WARNING WARNING WARNING WARNING WARNING WARNING",!
W !," * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *"
W !," * *"
W !," * This Install will delete both the ICD-9 Data Dictionary and data in *"
W !," * files #80 and #80.1. It will then install a new Data Dictionary *"
W !," * for files #80 and #80.1. The new Data Dictionary will accommodate *"
W !," * both the ICD-9 and ICD-10 coding systems. The new data will be *"
W !," * installed by the accompanying Lexicon patch LEX*2.0*80. These *"
W !," * changes will affect this namespace and any other namespace that *"
W !," * the ^ICD9 and ^ICD0 globals are mapped to. If your current *"
W !," * namespace is mapped to another namespace, make sure the other *"
W !," * namespace is also scheduled to be updated by this patch before *"
W !," * continuing. *"
W !," * *"
W !," * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *"
S DIR(0)="YAO",DIR("A")=" Do you wish to continue? (Y/N) "
S DIR("PRE")="S:X[""?"" X=""??""" S (DIR("?"),DIR("??"))="^D CONTH^ICD1857"
W ! D ^DIR S (X,Y)=+($G(Y)) S:Y'>0 XPDABORT=1,XPDQUIT=1,XPDQUIT("ICD*18.0*57")=1,XPDQUIT("LEX*2.0*80")=1
Q X
CONTH ; Continue Help
W !,?5,"Answering 'Yes' will:",!
W !,?7,"1) Delete the Data Dictionaries and the data for the following:",!
W !,?11,"ICD DIAGNOSIS file #80 ^ICD9("
W !,?11,"ICD OPERATION/PROCEDURE file #80.1 ^ICD0(",!
W !,?7,"2) Install the new joint ICD-9/10 Data Dictionaries."
W !,?7,"3) Update legacy ICD-9 APIs and install new ICD-9/10 APIs."
W !,?7,"4) Populate files #80 and #80.1 with ICD-9/10 data (LEX*2.0*80)",!
W !,?7," This affects the current namespace and any "
W !,?7," namespace that the Data Dictionary and files"
W !,?7," #80 and file #80.1 are mapped to.",!
W !,?5,"Answering 'No' will abort the installation of this patch"
Q
UOK(X) ; UCI Ok for Install
N X,Y S X=$$NETNAME^XMXUTIL(.5) Q:X["LEXDEV1.FO-BAYPINES" 1
X ^%ZOSF("UCI") Q:$G(Y)["LEXDEV1" 1
Q 1
GOK(X) ; Input Global Ok for Install
Q:$D(^TMP("LEX*2.0*80",$J,"NODATA")) 1
N ND,OK S OK=1 F ND="^LEXM","^LEXM(80)","^LEXM(80.1)","^LEXM(80.4)" S:'$D(@ND) OK=0
S ND="^LEXM(0,""BUILD"")" S:$G(@ND)'="LEX*2.0*80" OK=0
S X=OK
Q X
VER(X) ;
N DA,ICD,ICDDA,ICDE,ICDI,ICDMSG,ICDNS,ICDOUT,ICDPI,ICDPN,ICDSCR,ICDVI,ICDVD,ICDVI,ICDVR S ICD=$G(X)
S ICDNS=$$PKG^XPDUTL(ICD),ICDVR=$$VER^XPDUTL(ICD),ICDPN=$P(X,"*",3)
Q:'$L(ICDNS) 0 S ICDVR=+ICDVR Q:ICDVR'>0 0 S ICDPN=+ICDPN S:ICDVR'["." ICDVR=ICDVR_".0"
D FIND^DIC(9.4,,.01,"O",ICDNS,10,"C",,,"ICDOUT","ICDMSG") S ICDPI=$G(ICDOUT("DILIST",2,1))
K ICDOUT,ICDMSG Q:+ICDPI'>0 0 Q:'$D(@("^DIC(9.4,"_ICDPI_",22)")) 0
K DA S DA(1)=ICDPI S ICDDA=$$IENS^DILF(.DA)
D FIND^DIC(9.49,ICDDA,".01;1I;2I","O",ICDVR,10,"B",,,"ICDOUT","ICDMSG")
S ICDVD=$G(ICDOUT("DILIST","ID",1,2)) I $E(ICDVD,1,7)?7N&(+ICDPN'>0) D Q X
. S X=$E(ICDVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(ICDVD,1,7),"5DZ"),"@"," ")
S:$E(ICDVD,1,7)'?7N ICDVD=$G(ICDOUT("DILIST","ID",1,1)) I $E(ICDVD,1,7)?7N&(+ICDPN'>0) D Q X
. S X=$E(ICDVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(ICDVD,1,7),"5DZ"),"@"," ")
Q:+ICDPN'>0 0 S ICDVI=$G(ICDOUT("DILIST",2,1)) K ICDOUT,ICDMSG
Q 0
INS(X) ;
N ICD,ICDP,ICDV,ICDI S ICD=$G(X) I $L(ICD,"*")=3 S X=$$PATCH^XPDUTL(ICD) Q X
S ICDP=$$PKG^XPDUTL(ICD),ICDV=$$VER^XPDUTL(ICD),ICDI=$$VERSION^XPDUTL(ICDP)
Q:+ICDV>0&(ICDV=ICDI) 1
Q 0
INSD(X) ; Installed on
N DA,ICD,ICDDA,ICDE,ICDI,ICDMSG,ICDNS,ICDOUT,ICDPI,ICDPN,ICDSCR,ICDVI,ICDVD,ICDVI,ICDVR S ICD=$G(X)
S ICDNS=$$PKG^XPDUTL(ICD),ICDVR=$$VER^XPDUTL(ICD),ICDPN=$P(X,"*",3)
Q:'$L(ICDNS) 0 S ICDVR=+ICDVR Q:ICDVR'>0 0 S ICDPN=+ICDPN S:ICDVR'["." ICDVR=ICDVR_".0"
D FIND^DIC(9.4,,.01,"O",ICDNS,10,"C",,,"ICDOUT","ICDMSG") S ICDPI=$G(ICDOUT("DILIST",2,1))
K ICDOUT,ICDMSG Q:+ICDPI'>0 0 Q:'$D(@("^DIC(9.4,"_ICDPI_",22)")) 0
K DA S DA(1)=ICDPI S ICDDA=$$IENS^DILF(.DA)
D FIND^DIC(9.49,ICDDA,".01;1I;2I","O",ICDVR,10,"B",,,"ICDOUT","ICDMSG")
S ICDVD=$G(ICDOUT("DILIST","ID",1,2)) I $E(ICDVD,1,7)?7N&(+ICDPN'>0) D Q X
. S X=$E(ICDVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(ICDVD,1,7),"5DZ"),"@"," ")
S:$E(ICDVD,1,7)'?7N ICDVD=$G(ICDOUT("DILIST","ID",1,1)) I $E(ICDVD,1,7)?7N&(+ICDPN'>0) D Q X
. S X=$E(ICDVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(ICDVD,1,7),"5DZ"),"@"," ")
Q:+ICDPN'>0 0 S ICDVI=$G(ICDOUT("DILIST",2,1)) K ICDOUT,ICDMSG
Q:+ICDVI'>0 "" Q:'$D(@("^DIC(9.4,"_ICDPI_",22,"_ICDVI_",""PAH"")")) ""
K DA S DA(2)=ICDPI,DA(1)=ICDVI S ICDDA=$$IENS^DILF(.DA)
S ICDSCR="I $G(^DIC(9.4,"_ICDPI_",22,"_ICDVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
D FIND^DIC(9.4901,ICDDA,".01;.02I",,ICDPN,10,"B",ICDSCR,,"ICDOUT","ICDMSG")
S ICDI=$G(ICDOUT("DILIST","ID",1,.02)) I '$L(ICDI) D
. S ICDSCR="" D FIND^DIC(9.4901,ICDDA,".01;.02I",,ICDPN,10,"B",ICDSCR,,"ICDOUT","ICDMSG")
. S ICDI=$G(ICDOUT("DILIST","ID",1,.02))
Q:'$L(ICDI) "" Q:$P(ICDI,".",1)'?7N "" S ICDE=$TR($$FMTE^XLFDT(ICDI,"5DZ"),"@"," ")
Q:'$L(ICDE) "" S X=ICDI_"^"_ICDE
Q X
IMP ; Import names
S ICDREQP(1)="ICD*18.0*6^3030924^CSV"
S ICDREQP(2)="ICD*18.0*12^3041008^CTD"
S ICDREQP(3)="ICD*18.0*15^3050609^Legacy APIs"
S ICDREQP(4)="ICD*18.0*29^3071115^Legacy APIs"
S ICDREQP(5)="LEX*2.0*81^3120214^Fix Cross-Reference"
;S ICDREQP(6)="PSO*7.0*404^3120814^Global Read of ICD files"
;S ICDREQP(7)="ONC*2.11*56^3120927^Global Read of ICD files"
;S ICDREQP(8)="RA*5.0*112^3130417^Global Read of ICD files"
S ICDREQP(6)="ICD*18.0*62^3130501^DRG Grouper Fixes"
;S ICDREQP(10)="GMPL*2.0*43^3130514^Global Read of ICD files"
;S ICDREQP(11)="TIU*1.0*267^3130514^Global Read of ICD files"
S ICDREQP(7)="ICD*18.0*69^3130621^DRG Grouper Fixes"
;S ICDREQP(13)="DG*5.3*870^3130715^Global Read of ICD files"
;S ICDREQP(14)="IBD*3.0*64^3130903^Global Read of ICD files"
;S ICDREQP(15)="LR*5.2*429^3130918^Global Read of ICD files"
;S ICDREQP(16)="ACKQ*3.0*22^3131212^Global Read of ICD files"
;S ICDREQP(17)="LEX*2.0*94^3140114^FY14 2nd Qtr Update"
S ICDPTYPE="ICD-10 Implementation",ICDLREV=""
S ICDBUILD="ICD*18.0*57",ICDIGHF="",ICDFY="",ICDQTR=""
Q
STATUS ; ICD-9/10 Status in files 80/80.1
N ICD10,ICD9,ICDATA,ICDD,ICDDT,ICDENT,ICDF,ICDFI,ICDIEN,ICDM,ICDNM,ICDNS,ICDPK,ICDPT,ICDRT,ICDRV,ICDUCI,ICDVR,ICDT,ICDX,X,Y
K ICDDD,ICDGBL X ^%ZOSF("UCI") S (ICDNS,ICDUCI)=Y S:ICDNS[","&($L($P(Y,",",1))) ICDNS=$P(Y,",",1)
S ICDX=" Checking "_$S($L(ICDNS):(ICDNS_" "),1:"")_"ICD Data Dictionary/Global/Data Status:" D BM(ICDX)
D FIELD^DID(80.066,60,"N","LABEL","ICD9","ICDM")
D FIELD^DID(80.012,.01,"N","LABEL","ICD10","ICDM")
D BM(" Data Dictionary:"),M(" ")
D:'$D(ICD9) M(" Legacy ICD Data Dictionary does not exist")
D:$D(ICD9) M(" Remnants of the legacy ICD Data Dictionary found") S:$D(ICD9) ICDDD(1)=""
D:'$D(ICD10) M(" ICD-9/ICD-10 Data Dictionary does not exist") S:'$D(ICD10) ICDDD(2)=""
D:$D(ICD10) M(" ICD-9/ICD-10 Data Dictionary found")
D BM(" Global:"),M(" ")
F ICDT=80,80.1 D
. D FILE^DID(ICDT,"N","DATE;GLOBAL NAME;NAME;PACKAGE REVISION DATA;VERSION;LOOKUP PROGRAM","ICDF","ICDM")
. N ICDRT,ICDFI,ICDNM,ICDVR,ICDPK,ICDRV,ICDDT,ICDPT,ICDIEN,ICDENT S ICDRT=$G(ICDF("GLOBAL NAME"))
. S ICDRT=ICDRT_$J(" ",(8-$L(ICDRT))) S ICDFI=$G(ICDT),ICDFI=ICDFI_$J(" ",(6-$L(ICDFI)))
. S ICDNM=$G(ICDF("NAME")),ICDNM=ICDNM_$J(" ",(25-$L(ICDNM))),ICDVR=$G(ICDF("VERSION")) S:+ICDVR'>0 ICDVR="18.0"
. S ICDPK="ICD",ICDRV=$G(ICDF("PACKAGE REVISION DATA")),ICDDT=$P(ICDRV,"^",2),ICDRV=$P(ICDRV,"^",1)
. S ICDPT="" S:$L(ICDPK)&(+($G(ICDVR))>0)&(+($G(ICDRV))>0) ICDPT=ICDPK_"*"_ICDVR_"*"_ICDRV
. S ICDPT=ICDPT_$J(" ",(13-$L(ICDPT))),ICDDT=$S(ICDDT?7N:$TR($$FMTE^XLFDT(ICDDT,"5DZ"),"@"," "),1:"")
. S ICDDT=ICDDT_$J(" ",(12-$L(ICDDT)))
. D:ICDT=80 M(" Global Name # Root Patched Updated")
. D M((" "_ICDNM_ICDFI_ICDRT_ICDPT_ICDDT))
D BM(" Data:") I '$D(^ICD9(3066,"DRG"))&('$D(^ICD9(11938,66,3,"DRG")))&($L($G(^ICD9(3066,0)),"^")'>1) S ICDATA(80,9)="No "
I $D(^ICD9(3066,"DRG"))!($D(^ICD9(11938,66,3,"DRG")))!($L($G(^ICD9(3066,0)),"^")>1) S ICDGBL(1)="",ICDATA(80,9)="Yes"
I '$D(^ICD9(3066,7,1,0)) S ICDGBL(2)="",ICDATA(80,10)="No "
I $D(^ICD9(3066,7,1,0)) S ICDATA(80,10)="Yes"
I '$D(^ICD0(366,"MDC"))&($L($G(^ICD0(1535,0)),"^")'>1) S ICDATA(80.1,9)="No "
I $D(^ICD0(366,"MDC"))!($L($G(^ICD0(1535,0)),"^")>1) S ICDGBL(1)="",ICDATA(80.1,9)="Yes"
I '$D(^ICD0(1548,3,1,0))&($L($G(^ICD0(1548,1)),"^")'>1) S ICDGBL(2)="",ICDATA(80.1,10)="No "
I $D(^ICD0(1548,3,1,0))&($L($G(^ICD0(1548,1)),"^")>1) S ICDATA(80.1,10)="Yes"
S ICDX=" ",ICDX=ICDX_$J(" ",(32-$L(ICDX)))_"Legacy ICD-9"
S ICDX=ICDX_$J(" ",(50-$L(ICDX)))_"Updated ICD-10" D M(ICDX)
S ICDX=" Data Type ",ICDX=ICDX_$J(" ",(32-$L(ICDX)))_"Data Format"
S ICDX=ICDX_$J(" ",(50-$L(ICDX)))_"Data Format" D M(ICDX)
S ICDX=" ICD Diagnosis Data",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_$G(ICDATA(80,9))
S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_$G(ICDATA(80,10)) D M(ICDX)
S ICDX=" ICD Procedure Data",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_$G(ICDATA(80.1,9))
S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_$G(ICDATA(80.1,10)) D M(ICDX)
Q
M(X) ; Blank/Text
D MES^XPDUTL($G(X)) Q
BM(X) ; Blank/Text
D BMES^XPDUTL($G(X)) Q
TRIM(X) ; Trim Spaces
S X=$G(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))
Q X
ICD1857 ;ISL/KER - ICD*18.0*57 Env Check ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
+2 ;
+3 ;
+4 ; Global Variables
+5 ; ^%ZOSF("UCI") ICR 10096
+6 ; ^%ZOSF("UCICHECK") ICR 10096
+7 ; ^ICD0(1535) N/A
+8 ; ^ICD0(1548) N/A
+9 ; ^ICD0(366) N/A
+10 ; ^ICD9(11938) N/A
+11 ; ^ICD9(3066) N/A
+12 ; ^TMP("ICDKID") SACC 2.3.2.5.1
+13 ; ^TMP("ICDMSG") SACC 2.3.2.5.1
+14 ;
+15 ; External References
+16 ; $$FMTE^XLFDT ICR 10103
+17 ; $$GET1^DIQ ICR 2056
+18 ; $$IENS^DILF ICR 2054
+19 ; $$NETNAME^XMXUTIL ICR 2734
+20 ; $$PATCH^XPDUTL ICR 10141
+21 ; $$PKG^XPDUTL ICR 10141
+22 ; $$VERSION^XPDUTL ICR 10141
+23 ; $$VER^XPDUTL ICR 10141
+24 ; BMES^XPDUTL ICR 10141
+25 ; EN^DIQ1 ICR 10015
+26 ; FIELD^DID ICR 2052
+27 ; FILE^DID ICR 2052
+28 ; FIND^DIC ICR 2051
+29 ; BMES^XPDUTL ICR 10141
+30 ; FIND^DIC ICR 2051
+31 ; ^DIR ICR 10026
+32 ; ^XMD ICR 10070
+33 ;
+34 ; Local Variables NEWed or KILLed Elsewhere
+35 ; XPDABORT,XPDDIQ,XPDENV,XPDQUIT
+36 ;
ENV ; ICD*18.0*57 Environment Check
+1 ; Checks
+2 SET XPDNOQUE=1
NEW DA,DIC,DIFROM,DIQ,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,ICD,ICD10,ICD9,ICDADR,ICDATA,ICDBUILD,ICDC,ICDC1,ICDC2,ICDC3
+3 NEW ICDC4,ICDCOM,ICDCONT,ICDD,ICDDA,ICDDD,ICDDT,ICDE,ICDENT,ICDF,ICDFI,ICDFULL,ICDFY,ICDG,ICDGBL,ICDI,ICDIEN,ICDIGHF
+4 NEW ICDINE,ICDINS,ICDLREV,ICDM,ICDMSG,ICDNM,ICDNS,ICDO,ICDOUT,ICDP,ICDPAT,ICDPI,ICDPK,ICDPN,ICDPRI,ICDPT,ICDPTYPE
+5 NEW ICDQTR,ICDR,ICDREL,ICDREQ,ICDREQP,ICDRT,ICDRV,ICDSCR,ICDSTR,ICDSUB,ICDT,ICDUCI,ICDV,ICDVD,ICDVI,ICDVER,ICDVR
+6 NEW IEN,X,XCNP,XMDUZ,XMSCR,XMSUB,XMTEXT,XMY,XMZ,Y
DO IMP
KILL XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B")
+7 SET XPDDIQ("XPZ1","B")="NO"
SET XPDDIQ("XPI1","B")="NO"
SET U="^"
+8 ; User Variables
+9 IF +($$UR)'>0
DO ET("User not defined (DUZ)")
+10 ; System Variables
+11 IF +($$SY)'>0
DO ET("Undefined IO variable(s)")
+12 ; Data
+13 NEW ICDTEST
IF +($$GOK)'>0
DO ET("Cannot locate import data global ^LEXM")
+14 IF $DATA(ICDE)
DO ABRT
QUIT
+15 ; Version Number
+16 WRITE !,?3,"Checking for ICD Version installations",!
+17 SET ICDVER="ICD 18.0"
SET ICDINS=$$VER(ICDVER)
IF +ICDINS'>0
Begin DoDot:1
+18 DO ET(" Version 18.0 not found. Please install ICD v 18.0")
End DoDot:1
DO ABRT
QUIT
+19 IF +ICDINS>0
IF $PIECE(ICDINS,"^",1)?7N
IF $LENGTH($PIECE(ICDINS,"^",2))
Begin DoDot:1
+20 WRITE !,?5,ICDVER," installed ",$PIECE(ICDINS,"^",2)
End DoDot:1
+21 SET ICDVER="ICD*18.0*57"
SET ICDINS=$$VER(ICDVER)
+22 IF +ICDINS>0
IF $PIECE(ICDINS,"^",1)?7N
IF $LENGTH($PIECE(ICDINS,"^",2))
Begin DoDot:1
+23 WRITE !,?5,ICDVER," installed ",$PIECE(ICDINS,"^",2)
End DoDot:1
+24 ; Required Patches
+25 IF $ORDER(ICDREQP(0))'>0
DO IMP
IF $ORDER(ICDREQP(0))>0
Begin DoDot:1
+26 WRITE !
NEW ICDPAT,ICDI,ICDPN,ICDP,ICDR,ICDC,ICDO,ICDC1,ICDC2,ICDC3,ICDC4,ICD
+27 SET (ICDR,ICDC)=0
SET ICDC1=3
SET (ICDC2,ICDC3,ICDC4)=20
SET ICDC2=18
+28 SET ICDI=0
FOR
SET ICDI=$ORDER(ICDREQP(ICDI))
IF +ICDI'>0
QUIT
Begin DoDot:2
+29 SET ICDC=ICDC+1
SET ICDPAT=$GET(ICDREQP(ICDI))
+30 IF $PIECE(ICDPAT,"^",2)?7N
SET ICDR=ICDR+1
SET ICDC3=ICDC2+13
SET ICDC4=ICDC2+36
End DoDot:2
+31 SET ICDI=0
FOR
SET ICDI=$ORDER(ICDREQP(ICDI))
IF +ICDI'>0
QUIT
Begin DoDot:2
+32 NEW ICDPAT,ICDREL,ICDINS,ICDCOM,ICDINE,ICDREQ
SET ICDREQ=$GET(ICDREQP(ICDI))
+33 SET ICDPAT=$PIECE(ICDREQ,"^",1)
SET ICDREL=$PIECE(ICDREQ,"^",2)
SET ICDCOM=$PIECE(ICDREQ,"^",3)
+34 SET ICDPN=$$INS(ICDPAT)
SET ICDINS=$$INSD(ICDPAT)
SET ICDINE=$PIECE(ICDINS,"^",2)
+35 IF ICDI=1
WRITE !,?3,"Checking for ",?ICDC2,$SELECT(+($GET(ICDR))>0:"Released",1:"")
+36 WRITE !,?ICDC1,ICDPAT
+37 IF ICDREL?7N
WRITE ?ICDC2,$TRANSLATE($$FMTE^XLFDT(ICDREL,"5DZ"),"@"," ")
+38 IF +ICDPN>0
Begin DoDot:3
+39 SET ICDO=+($GET(ICDO))+1
WRITE ?ICDC3,"Installed "
IF $LENGTH($GET(ICDINE))
WRITE ICDINE
+40 IF +ICDC4>0&(+ICDC4>ICDC3)&($LENGTH(ICDCOM))
WRITE ?ICDC4,ICDCOM
End DoDot:3
+41 IF +ICDPN'>0
DO ET((" "_ICDPAT_" not found, please install "_ICDPAT_" before continuing"))
End DoDot:2
+42 IF +($GET(ICDO))'=ICDC
WRITE !
End DoDot:1
+43 ; UCI
+44 IF +($$UOK)'>0&('$DATA(ICDTEST))
WRITE !
DO ET("Unable to install in this UCI")
GOTO ABRT
+45 DO STATUS
SET ICDCONT=$$CONT
IF +ICDCONT'>0
WRITE !
DO ET(" User aborted install")
GOTO ABRT
+46 IF $DATA(ICDE)
DO ABRT
QUIT
+47 IF '$DATA(ICDFULL)&(+($GET(XPDENV))'=1)
DO QUIT
QUIT
+48 ; Quit, Exit or Abort
QUIT ; Quit Passed Environment Check
+1 KILL ICDFULL
DO OK
+2 QUIT
EXIT ; Exit Failed Environment Check
+1 IF $DATA(ICDE)
DO ED
SET XPDQUIT=2
KILL ICDE,ICDFULL
QUIT
ABRT ; Abort Failed Environment Check, KILL the distribution
+1 IF $DATA(ICDE)
DO ED
SET XPDABORT=1
SET XPDQUIT=1
SET XPDQUIT("ICD*18.0*57")=1
SET XPDQUIT("LEX*2.0*80")=1
+2 KILL ICDE,ICDFULL
+3 QUIT
SY(X) ; Check System variables
+1 IF '$DATA(IO)!('$DATA(IOF))!('$DATA(IOM))!('$DATA(ION))!('$DATA(IOSL))!('$DATA(IOST))
QUIT 0
+2 QUIT 1
UR(X) ; Check User variables
+1 IF '$LENGTH($GET(DUZ(0)))
QUIT 0
+2 IF +($GET(DUZ))=0!($$NOTDEF(+$GET(DUZ)))
QUIT 0
+3 QUIT 1
ET(X) ; Error Text
+1 NEW ICDI
SET ICDI=+($GET(ICDE(0)))
SET ICDI=ICDI+1
SET ICDE(ICDI)=" "_$GET(X)
SET ICDE(0)=ICDI
+2 QUIT
ED ; Error Display
+1 NEW ICDI
SET ICDI=0
FOR
SET ICDI=$ORDER(ICDE(ICDI))
IF +ICDI=0
QUIT
DO M(ICDE(ICDI))
+2 DO M(" ")
KILL ICDE
QUIT
NOTDEF(X) ; Check to see if user is defined
+1 NEW DA,DR,DIQ,ICD,DIC
SET DA=+($GET(X))
SET DR=.01
SET DIC=200
SET DIQ="ICD"
DO EN^DIQ1
QUIT '$DATA(ICD)
OK ; Environment is OK
+1 NEW ICDPTYPE,ICDLREV,ICDREQP,ICDBUILD,ICDIGHF,ICDFY,ICDQTR,ICDT
+2 DO IMP
SET ICDT=" Environment "_$SELECT($LENGTH(ICDBUILD):("for patch/build "_ICDBUILD_" "),1:"")_"is ok"
+3 DO BM(ICDT)
DO M(" ")
+4 QUIT
MAIL ; Mail global array in message
+1 NEW DIFROM,ICDPRI,ICDADR,ICDI,ICDM,ICDSUB,XCNP,XMDUZ,XMSCR,XMSUB,XMTEXT,XMY,XMZ,ICDPTYPE,ICDLREV,ICDREQP,ICDBUILD,ICDIGHF,ICDFY,ICDQTR
+2 DO IMP
KILL ^TMP("ICDMSG",$JOB)
SET ICDSUB="Lexicon/ICD-10 Installation"
IF $LENGTH($GET(ICDBUILD))
SET ICDSUB=$GET(ICDBUILD)_" Installation"
+3 SET ICDPRI=$$ADR
IF '$LENGTH(ICDPRI)
GOTO MAILQ
SET ICDPRI="G.ICDINS@"_ICDPRI
SET ICDADR=$$GET1^DIQ(200,+($GET(DUZ)),.01)
IF '$LENGTH(ICDADR)
GOTO MAILQ
+4 SET XMSUB=ICDSUB
SET ICDI=0
FOR
SET ICDI=$ORDER(^TMP("ICDKID",$JOB,ICDI))
IF +ICDI=0
QUIT
Begin DoDot:1
+5 SET ICDM=+($ORDER(^TMP("ICDMSG",$JOB," "),-1))+1
SET ^TMP("ICDMSG",$JOB,ICDM,0)=$EXTRACT($GET(^TMP("ICDKID",$JOB,ICDI)),1,79)
SET ^TMP("ICDMSG",$JOB,0)=ICDM
End DoDot:1
+6 KILL ^TMP("ICDKID",$JOB)
IF '$DATA(^TMP("ICDMSG",$JOB))
GOTO MAILQ
IF +($GET(^TMP("ICDMSG",$JOB,0)))'>0
GOTO MAILQ
SET XMY(ICDPRI)=""
SET XMY(ICDADR)=""
+7 SET XMTEXT="^TMP(""ICDMSG"",$J,"
SET XMDUZ=.5
DO ^XMD
MAILQ ; Quit Mail
+1 DO KILL
KILL XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMY,XMTEXT,XMDUZ
+2 QUIT
ADR(ICD) ; Mailing Address
+1 NEW DIC,DTOUT,DUOUT,X,Y
SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (ICD,X)="FO-SLC.MED.VA.GOV"
DO ^DIC
IF +Y>0
QUIT ICD
+2 SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (ICD,X)="ISC-SLC.MED.VA.GOV"
DO ^DIC
IF +Y>0
QUIT ICD
+3 QUIT "ISC-SLC.VA.GOV"
KILL ; Kill all ^TMP(
+1 KILL ^TMP("ICDMSG",$JOB),^TMP("ICDKID",$JOB)
+2 QUIT
CONT(X) ; Continue
+1 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y
+2 WRITE !!," WARNING WARNING WARNING WARNING WARNING WARNING WARNING",!
+3 WRITE !," * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *"
+4 WRITE !," * *"
+5 WRITE !," * This Install will delete both the ICD-9 Data Dictionary and data in *"
+6 WRITE !," * files #80 and #80.1. It will then install a new Data Dictionary *"
+7 WRITE !," * for files #80 and #80.1. The new Data Dictionary will accommodate *"
+8 WRITE !," * both the ICD-9 and ICD-10 coding systems. The new data will be *"
+9 WRITE !," * installed by the accompanying Lexicon patch LEX*2.0*80. These *"
+10 WRITE !," * changes will affect this namespace and any other namespace that *"
+11 WRITE !," * the ^ICD9 and ^ICD0 globals are mapped to. If your current *"
+12 WRITE !," * namespace is mapped to another namespace, make sure the other *"
+13 WRITE !," * namespace is also scheduled to be updated by this patch before *"
+14 WRITE !," * continuing. *"
+15 WRITE !," * *"
+16 WRITE !," * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *"
+17 SET DIR(0)="YAO"
SET DIR("A")=" Do you wish to continue? (Y/N) "
+18 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D CONTH^ICD1857"
+19 WRITE !
DO ^DIR
SET (X,Y)=+($GET(Y))
IF Y'>0
SET XPDABORT=1
SET XPDQUIT=1
SET XPDQUIT("ICD*18.0*57")=1
SET XPDQUIT("LEX*2.0*80")=1
+20 QUIT X
CONTH ; Continue Help
+1 WRITE !,?5,"Answering 'Yes' will:",!
+2 WRITE !,?7,"1) Delete the Data Dictionaries and the data for the following:",!
+3 WRITE !,?11,"ICD DIAGNOSIS file #80 ^ICD9("
+4 WRITE !,?11,"ICD OPERATION/PROCEDURE file #80.1 ^ICD0(",!
+5 WRITE !,?7,"2) Install the new joint ICD-9/10 Data Dictionaries."
+6 WRITE !,?7,"3) Update legacy ICD-9 APIs and install new ICD-9/10 APIs."
+7 WRITE !,?7,"4) Populate files #80 and #80.1 with ICD-9/10 data (LEX*2.0*80)",!
+8 WRITE !,?7," This affects the current namespace and any "
+9 WRITE !,?7," namespace that the Data Dictionary and files"
+10 WRITE !,?7," #80 and file #80.1 are mapped to.",!
+11 WRITE !,?5,"Answering 'No' will abort the installation of this patch"
+12 QUIT
UOK(X) ; UCI Ok for Install
+1 NEW X,Y
SET X=$$NETNAME^XMXUTIL(.5)
IF X["LEXDEV1.FO-BAYPINES"
QUIT 1
+2 XECUTE ^%ZOSF("UCI")
IF $GET(Y)["LEXDEV1"
QUIT 1
+3 QUIT 1
GOK(X) ; Input Global Ok for Install
+1 IF $DATA(^TMP("LEX*2.0*80",$JOB,"NODATA"))
QUIT 1
+2 NEW ND,OK
SET OK=1
FOR ND="^LEXM","^LEXM(80)","^LEXM(80.1)","^LEXM(80.4)"
IF '$DATA(@ND)
SET OK=0
+3 SET ND="^LEXM(0,""BUILD"")"
IF $GET(@ND)'="LEX*2.0*80"
SET OK=0
+4 SET X=OK
+5 QUIT X
VER(X) ;
+1 NEW DA,ICD,ICDDA,ICDE,ICDI,ICDMSG,ICDNS,ICDOUT,ICDPI,ICDPN,ICDSCR,ICDVI,ICDVD,ICDVI,ICDVR
SET ICD=$GET(X)
+2 SET ICDNS=$$PKG^XPDUTL(ICD)
SET ICDVR=$$VER^XPDUTL(ICD)
SET ICDPN=$PIECE(X,"*",3)
+3 IF '$LENGTH(ICDNS)
QUIT 0
SET ICDVR=+ICDVR
IF ICDVR'>0
QUIT 0
SET ICDPN=+ICDPN
IF ICDVR'["."
SET ICDVR=ICDVR_".0"
+4 DO FIND^DIC(9.4,,.01,"O",ICDNS,10,"C",,,"ICDOUT","ICDMSG")
SET ICDPI=$GET(ICDOUT("DILIST",2,1))
+5 KILL ICDOUT,ICDMSG
IF +ICDPI'>0
QUIT 0
IF '$DATA(@("^DIC(9.4,"_ICDPI_",22)"))
QUIT 0
+6 KILL DA
SET DA(1)=ICDPI
SET ICDDA=$$IENS^DILF(.DA)
+7 DO FIND^DIC(9.49,ICDDA,".01;1I;2I","O",ICDVR,10,"B",,,"ICDOUT","ICDMSG")
+8 SET ICDVD=$GET(ICDOUT("DILIST","ID",1,2))
IF $EXTRACT(ICDVD,1,7)?7N&(+ICDPN'>0)
Begin DoDot:1
+9 SET X=$EXTRACT(ICDVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(ICDVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+10 IF $EXTRACT(ICDVD,1,7)'?7N
SET ICDVD=$GET(ICDOUT("DILIST","ID",1,1))
IF $EXTRACT(ICDVD,1,7)?7N&(+ICDPN'>0)
Begin DoDot:1
+11 SET X=$EXTRACT(ICDVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(ICDVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+12 IF +ICDPN'>0
QUIT 0
SET ICDVI=$GET(ICDOUT("DILIST",2,1))
KILL ICDOUT,ICDMSG
+13 QUIT 0
INS(X) ;
+1 NEW ICD,ICDP,ICDV,ICDI
SET ICD=$GET(X)
IF $LENGTH(ICD,"*")=3
SET X=$$PATCH^XPDUTL(ICD)
QUIT X
+2 SET ICDP=$$PKG^XPDUTL(ICD)
SET ICDV=$$VER^XPDUTL(ICD)
SET ICDI=$$VERSION^XPDUTL(ICDP)
+3 IF +ICDV>0&(ICDV=ICDI)
QUIT 1
+4 QUIT 0
INSD(X) ; Installed on
+1 NEW DA,ICD,ICDDA,ICDE,ICDI,ICDMSG,ICDNS,ICDOUT,ICDPI,ICDPN,ICDSCR,ICDVI,ICDVD,ICDVI,ICDVR
SET ICD=$GET(X)
+2 SET ICDNS=$$PKG^XPDUTL(ICD)
SET ICDVR=$$VER^XPDUTL(ICD)
SET ICDPN=$PIECE(X,"*",3)
+3 IF '$LENGTH(ICDNS)
QUIT 0
SET ICDVR=+ICDVR
IF ICDVR'>0
QUIT 0
SET ICDPN=+ICDPN
IF ICDVR'["."
SET ICDVR=ICDVR_".0"
+4 DO FIND^DIC(9.4,,.01,"O",ICDNS,10,"C",,,"ICDOUT","ICDMSG")
SET ICDPI=$GET(ICDOUT("DILIST",2,1))
+5 KILL ICDOUT,ICDMSG
IF +ICDPI'>0
QUIT 0
IF '$DATA(@("^DIC(9.4,"_ICDPI_",22)"))
QUIT 0
+6 KILL DA
SET DA(1)=ICDPI
SET ICDDA=$$IENS^DILF(.DA)
+7 DO FIND^DIC(9.49,ICDDA,".01;1I;2I","O",ICDVR,10,"B",,,"ICDOUT","ICDMSG")
+8 SET ICDVD=$GET(ICDOUT("DILIST","ID",1,2))
IF $EXTRACT(ICDVD,1,7)?7N&(+ICDPN'>0)
Begin DoDot:1
+9 SET X=$EXTRACT(ICDVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(ICDVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+10 IF $EXTRACT(ICDVD,1,7)'?7N
SET ICDVD=$GET(ICDOUT("DILIST","ID",1,1))
IF $EXTRACT(ICDVD,1,7)?7N&(+ICDPN'>0)
Begin DoDot:1
+11 SET X=$EXTRACT(ICDVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(ICDVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+12 IF +ICDPN'>0
QUIT 0
SET ICDVI=$GET(ICDOUT("DILIST",2,1))
KILL ICDOUT,ICDMSG
+13 IF +ICDVI'>0
QUIT ""
IF '$DATA(@("^DIC(9.4,"_ICDPI_",22,"_ICDVI_",""PAH"")"))
QUIT ""
+14 KILL DA
SET DA(2)=ICDPI
SET DA(1)=ICDVI
SET ICDDA=$$IENS^DILF(.DA)
+15 SET ICDSCR="I $G(^DIC(9.4,"_ICDPI_",22,"_ICDVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
+16 DO FIND^DIC(9.4901,ICDDA,".01;.02I",,ICDPN,10,"B",ICDSCR,,"ICDOUT","ICDMSG")
+17 SET ICDI=$GET(ICDOUT("DILIST","ID",1,.02))
IF '$LENGTH(ICDI)
Begin DoDot:1
+18 SET ICDSCR=""
DO FIND^DIC(9.4901,ICDDA,".01;.02I",,ICDPN,10,"B",ICDSCR,,"ICDOUT","ICDMSG")
+19 SET ICDI=$GET(ICDOUT("DILIST","ID",1,.02))
End DoDot:1
+20 IF '$LENGTH(ICDI)
QUIT ""
IF $PIECE(ICDI,".",1)'?7N
QUIT ""
SET ICDE=$TRANSLATE($$FMTE^XLFDT(ICDI,"5DZ"),"@"," ")
+21 IF '$LENGTH(ICDE)
QUIT ""
SET X=ICDI_"^"_ICDE
+22 QUIT X
IMP ; Import names
+1 SET ICDREQP(1)="ICD*18.0*6^3030924^CSV"
+2 SET ICDREQP(2)="ICD*18.0*12^3041008^CTD"
+3 SET ICDREQP(3)="ICD*18.0*15^3050609^Legacy APIs"
+4 SET ICDREQP(4)="ICD*18.0*29^3071115^Legacy APIs"
+5 SET ICDREQP(5)="LEX*2.0*81^3120214^Fix Cross-Reference"
+6 ;S ICDREQP(6)="PSO*7.0*404^3120814^Global Read of ICD files"
+7 ;S ICDREQP(7)="ONC*2.11*56^3120927^Global Read of ICD files"
+8 ;S ICDREQP(8)="RA*5.0*112^3130417^Global Read of ICD files"
+9 SET ICDREQP(6)="ICD*18.0*62^3130501^DRG Grouper Fixes"
+10 ;S ICDREQP(10)="GMPL*2.0*43^3130514^Global Read of ICD files"
+11 ;S ICDREQP(11)="TIU*1.0*267^3130514^Global Read of ICD files"
+12 SET ICDREQP(7)="ICD*18.0*69^3130621^DRG Grouper Fixes"
+13 ;S ICDREQP(13)="DG*5.3*870^3130715^Global Read of ICD files"
+14 ;S ICDREQP(14)="IBD*3.0*64^3130903^Global Read of ICD files"
+15 ;S ICDREQP(15)="LR*5.2*429^3130918^Global Read of ICD files"
+16 ;S ICDREQP(16)="ACKQ*3.0*22^3131212^Global Read of ICD files"
+17 ;S ICDREQP(17)="LEX*2.0*94^3140114^FY14 2nd Qtr Update"
+18 SET ICDPTYPE="ICD-10 Implementation"
SET ICDLREV=""
+19 SET ICDBUILD="ICD*18.0*57"
SET ICDIGHF=""
SET ICDFY=""
SET ICDQTR=""
+20 QUIT
STATUS ; ICD-9/10 Status in files 80/80.1
+1 NEW ICD10,ICD9,ICDATA,ICDD,ICDDT,ICDENT,ICDF,ICDFI,ICDIEN,ICDM,ICDNM,ICDNS,ICDPK,ICDPT,ICDRT,ICDRV,ICDUCI,ICDVR,ICDT,ICDX,X,Y
+2 KILL ICDDD,ICDGBL
XECUTE ^%ZOSF("UCI")
SET (ICDNS,ICDUCI)=Y
IF ICDNS[","&($LENGTH($PIECE(Y,",",1)))
SET ICDNS=$PIECE(Y,",",1)
+3 SET ICDX=" Checking "_$SELECT($LENGTH(ICDNS):(ICDNS_" "),1:"")_"ICD Data Dictionary/Global/Data Status:"
DO BM(ICDX)
+4 DO FIELD^DID(80.066,60,"N","LABEL","ICD9","ICDM")
+5 DO FIELD^DID(80.012,.01,"N","LABEL","ICD10","ICDM")
+6 DO BM(" Data Dictionary:")
DO M(" ")
+7 IF '$DATA(ICD9)
DO M(" Legacy ICD Data Dictionary does not exist")
+8 IF $DATA(ICD9)
DO M(" Remnants of the legacy ICD Data Dictionary found")
IF $DATA(ICD9)
SET ICDDD(1)=""
+9 IF '$DATA(ICD10)
DO M(" ICD-9/ICD-10 Data Dictionary does not exist")
IF '$DATA(ICD10)
SET ICDDD(2)=""
+10 IF $DATA(ICD10)
DO M(" ICD-9/ICD-10 Data Dictionary found")
+11 DO BM(" Global:")
DO M(" ")
+12 FOR ICDT=80,80.1
Begin DoDot:1
+13 DO FILE^DID(ICDT,"N","DATE;GLOBAL NAME;NAME;PACKAGE REVISION DATA;VERSION;LOOKUP PROGRAM","ICDF","ICDM")
+14 NEW ICDRT,ICDFI,ICDNM,ICDVR,ICDPK,ICDRV,ICDDT,ICDPT,ICDIEN,ICDENT
SET ICDRT=$GET(ICDF("GLOBAL NAME"))
+15 SET ICDRT=ICDRT_$JUSTIFY(" ",(8-$LENGTH(ICDRT)))
SET ICDFI=$GET(ICDT)
SET ICDFI=ICDFI_$JUSTIFY(" ",(6-$LENGTH(ICDFI)))
+16 SET ICDNM=$GET(ICDF("NAME"))
SET ICDNM=ICDNM_$JUSTIFY(" ",(25-$LENGTH(ICDNM)))
SET ICDVR=$GET(ICDF("VERSION"))
IF +ICDVR'>0
SET ICDVR="18.0"
+17 SET ICDPK="ICD"
SET ICDRV=$GET(ICDF("PACKAGE REVISION DATA"))
SET ICDDT=$PIECE(ICDRV,"^",2)
SET ICDRV=$PIECE(ICDRV,"^",1)
+18 SET ICDPT=""
IF $LENGTH(ICDPK)&(+($GET(ICDVR))>0)&(+($GET(ICDRV))>0)
SET ICDPT=ICDPK_"*"_ICDVR_"*"_ICDRV
+19 SET ICDPT=ICDPT_$JUSTIFY(" ",(13-$LENGTH(ICDPT)))
SET ICDDT=$SELECT(ICDDT?7N:$TRANSLATE($$FMTE^XLFDT(ICDDT,"5DZ"),"@"," "),1:"")
+20 SET ICDDT=ICDDT_$JUSTIFY(" ",(12-$LENGTH(ICDDT)))
+21 IF ICDT=80
DO M(" Global Name # Root Patched Updated")
+22 DO M((" "_ICDNM_ICDFI_ICDRT_ICDPT_ICDDT))
End DoDot:1
+23 DO BM(" Data:")
IF '$DATA(^ICD9(3066,"DRG"))&('$DATA(^ICD9(11938,66,3,"DRG")))&($LENGTH($GET(^ICD9(3066,0)),"^")'>1)
SET ICDATA(80,9)="No "
+24 IF $DATA(^ICD9(3066,"DRG"))!($DATA(^ICD9(11938,66,3,"DRG")))!($LENGTH($GET(^ICD9(3066,0)),"^")>1)
SET ICDGBL(1)=""
SET ICDATA(80,9)="Yes"
+25 IF '$DATA(^ICD9(3066,7,1,0))
SET ICDGBL(2)=""
SET ICDATA(80,10)="No "
+26 IF $DATA(^ICD9(3066,7,1,0))
SET ICDATA(80,10)="Yes"
+27 IF '$DATA(^ICD0(366,"MDC"))&($LENGTH($GET(^ICD0(1535,0)),"^")'>1)
SET ICDATA(80.1,9)="No "
+28 IF $DATA(^ICD0(366,"MDC"))!($LENGTH($GET(^ICD0(1535,0)),"^")>1)
SET ICDGBL(1)=""
SET ICDATA(80.1,9)="Yes"
+29 IF '$DATA(^ICD0(1548,3,1,0))&($LENGTH($GET(^ICD0(1548,1)),"^")'>1)
SET ICDGBL(2)=""
SET ICDATA(80.1,10)="No "
+30 IF $DATA(^ICD0(1548,3,1,0))&($LENGTH($GET(^ICD0(1548,1)),"^")>1)
SET ICDATA(80.1,10)="Yes"
+31 SET ICDX=" "
SET ICDX=ICDX_$JUSTIFY(" ",(32-$LENGTH(ICDX)))_"Legacy ICD-9"
+32 SET ICDX=ICDX_$JUSTIFY(" ",(50-$LENGTH(ICDX)))_"Updated ICD-10"
DO M(ICDX)
+33 SET ICDX=" Data Type "
SET ICDX=ICDX_$JUSTIFY(" ",(32-$LENGTH(ICDX)))_"Data Format"
+34 SET ICDX=ICDX_$JUSTIFY(" ",(50-$LENGTH(ICDX)))_"Data Format"
DO M(ICDX)
+35 SET ICDX=" ICD Diagnosis Data"
SET ICDX=ICDX_$JUSTIFY(" ",(37-$LENGTH(ICDX)))_$GET(ICDATA(80,9))
+36 SET ICDX=ICDX_$JUSTIFY(" ",(55-$LENGTH(ICDX)))_$GET(ICDATA(80,10))
DO M(ICDX)
+37 SET ICDX=" ICD Procedure Data"
SET ICDX=ICDX_$JUSTIFY(" ",(37-$LENGTH(ICDX)))_$GET(ICDATA(80.1,9))
+38 SET ICDX=ICDX_$JUSTIFY(" ",(55-$LENGTH(ICDX)))_$GET(ICDATA(80.1,10))
DO M(ICDX)
+39 QUIT
M(X) ; Blank/Text
+1 DO MES^XPDUTL($GET(X))
QUIT
BM(X) ; Blank/Text
+1 DO BMES^XPDUTL($GET(X))
QUIT
TRIM(X) ; Trim Spaces
+1 SET X=$GET(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 QUIT X
