LEX2080A ;ISL/KER - LEX*2.0*80 Pre/Post Install (cont) ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^%ZOSF("UCI") ICR 10096
; ^ICD0( ICR 4486
; ^ICD0(1535) ICR 4486
; ^ICD0(1548) ICR 4486
; ^ICD0(366) ICR 4486
; ^ICD9( ICR 4485
; ^ICD9(11938) ICR 4485
; ^ICD9(3066) ICR 4485
; ^TMP("LEXKID") SACC 2.3.2.5.1
;
; External References
; $$FMTE^XLFDT ICR 10103
; FIELD^DID ICR 2052
; FILE^DID ICR 2052
; BMES^XPDUTL ICR 10141
; MES^XPDUTL ICR 10141
;
STATUS ; ICD-9/10 Status in files 80/80.1 and Lexicon
N LEX10,ICD10,ICD9,LEGD,LEGP,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 LEGD=$$LEGD,LEGP=$$LEGP
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 FIELD^DID(757.03,11,"N","LABEL","LEX10","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 Data Dictionary updates for ICD-10 not found") S:'$D(ICD10) ICDDD(2)=""
D:$D(ICD10) M(" ICD Data Dictionary updates for ICD-10 found")
D:'$D(LEX10) M(" Lexicon Data Dictionary updates for ICD-10 not found")
D:$D(LEX10) M(" Lexicon Data Dictionary updates for ICD-10 found")
D BM(" Global:"),M(" ")
F ICDT=80,80.1,80.4,757,757.001,757.01,757.02,757.03,757.033,757.1,757.3,757.31 D
. K ICDF,ICDM 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 ICDNM=$E($G(ICDF("NAME")),1,24)
. S ICDNM=$G(ICDF("NAME"))
. S ICDNM=ICDNM_$J(" ",(36-$L(ICDNM))) S ICDVR=$G(ICDF("VERSION"))
. S ICDFI=$G(ICDT),ICDFI=ICDFI_$J(" ",(10-$L(ICDFI)))
. S ICDRT=$G(ICDF("GLOBAL NAME")),ICDRT=ICDRT_$J(" ",(15-$L(ICDRT)))
. S ICDPK=$S($P(ICDT,".",1)=80:"ICD",$P(ICDT,".",1)=757:"LEX",1:"") Q:'$L(ICDPK)
. S 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(" ",(14-$L(ICDPT))),ICDDT=$S(ICDDT?7N:$TR($$FMTE^XLFDT(ICDDT,"5DZ"),"@"," "),1:"")
. D:ICDT=80 M(" Global Name File # Patched Effective")
. D M((" "_ICDNM_ICDFI_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:+LEGD>0 ICDATA(80,9)="Yes" S:+LEGP>0 ICDATA(80.1,9)="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=" Coding System Data",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)
S ICDX=" Lexicon Data ",ICDX=ICDX_$J(" ",(32-$L(ICDX)))_" ICD-9"
S ICDX=ICDX_$J(" ",(50-$L(ICDX)))_" ICD-10" D BM(ICDX)
S ICD9=$S($O(^LEX(757.02,"ASRC","ICD",0))>0:"Yes",1:"No")
S ICD10=$S($O(^LEX(757.02,"ASRC","10D",0))>0:"Yes",1:"No")
S ICDX=" ICD Diagnosis",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_ICD9
S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_ICD10 D M(ICDX)
S ICD9=$S($O(^LEX(757.02,"ASRC","ICP",0))>0:"Yes",1:"No")
S ICD10=$S($O(^LEX(757.02,"ASRC","10P",0))>0:"Yes",1:"No")
S ICDX=" ICD Procedures",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_ICD9
S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_ICD10 D M(ICDX)
Q
LEGD(X) ; ICD 9 Legacy Data
N ICDI,ICD9 S (ICDI,ICD9)=0 F S ICDI=$O(^ICD9(ICDI)) Q:+ICDI'>0 Q:ICDI>499999 Q:ICD9>0 D Q:ICD9>0
. S:$D(^ICD9(ICDI,"DRG")) ICD9=1 Q:ICD9
. S:$D(^ICD9(ICDI,66,1,"DRG"))!($D(^ICD9(ICDI,66,3,"DRG"))) ICD9=1 Q:ICD9
. S:$L($G(^ICD9(ICDI,0)),"^")>1 ICD9=1
S X=+ICD9
Q X
LEGP(X) ; ICD 0 Legacy Data
N ICDI,ICD0 S (ICDI,ICD0)=0 F S ICDI=$O(^ICD0(ICDI)) Q:+ICDI'>0 Q:ICDI>499999 Q:ICD0>0 D Q:ICD0>0
. S:$L($G(^ICD0(ICDI,0)),"^")>1 ICD0=1 Q:ICD0
. S:$L($G(^ICD0(ICDI,1)))&($P($G(^ICD0(ICDI,1)),"^",1)'?1N.N) ICD0=1 Q:ICD0
. S:$D(^ICD0(ICDI,"MDC")) ICD0=1 Q:ICD0
S X=+ICD0
Q X
FL ; Flouride to Fluoride
Q
I $P($G(^ICPT(108897,0)),"^",2)="TOPICAL FLOURIDE VARNISH" D
. N DA,DIK S DA=108897,DIK="^ICPT(" D IX2^DIK
. S $P(^ICPT(108897,0),"^",2)="TOPICAL FLUORIDE VARNISH"
. S DA=108897,DIK="^ICPT(" D IX1^DIK
I $P($G(^ICPT(108897,61,2,0)),"^",2)="TOPICAL FLOURIDE VARNISH" D
. N DA,DIK S DA=108897,DIK="^ICPT(" D IX2^DIK
. S $P(^ICPT(108897,61,2,0),"^",2)="TOPICAL FLUORIDE VARNISH"
. S DA=108897,DIK="^ICPT(" D IX1^DIK
I $P($G(^ICPT(110825,0)),"^",2)="TOPICAL FLOURIDE" D
. N DA,DIK S DA=110825,DIK="^ICPT(" D IX2^DIK
. S $P(^ICPT(110825,0),"^",2)="TOPICAL FLUORIDE"
. S DA=110825,DIK="^ICPT(" D IX1^DIK
I $P($G(^ICPT(110825,61,1,0)),"^",2)="TOPICAL FLOURIDE" D
. N DA,DIK S DA=110825,DIK="^ICPT(" D IX2^DIK
. S $P(^ICPT(110825,61,1,0),"^",2)="TOPICAL FLUORIDE"
. S DA=110825,DIK="^ICPT(" D IX1^DIK
S DA(1)=306305,DA=207,DIK="^LEX(757.01,"_DA(1)_",5,"
I $D(^LEX(757.01,DA(1),5,DA)) D
. D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
. K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
S DA(1)=309984,DA=21,DIK="^LEX(757.01,"_DA(1)_",5,"
I $D(^LEX(757.01,DA(1),5,DA)) D
. D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
. K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
S DA(1)=306668,DA=52,DIK="^LEX(757.01,"_DA(1)_",5,"
I $D(^LEX(757.01,DA(1),5,DA)) D
. D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
. K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
S DA(1)=309999,DA=22,DIK="^LEX(757.01,"_DA(1)_",5,"
I $D(^LEX(757.01,DA(1),5,DA)) D
. D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
. K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
S DA(1)=312701,DA=5,DIK="^LEX(757.01,"_DA(1)_",5,"
I $D(^LEX(757.01,DA(1),5,DA)) D
. D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
. K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
S DA(1)=312704,DA=7,DIK="^LEX(757.01,"_DA(1)_",5,"
I $D(^LEX(757.01,DA(1),5,DA)) D
. D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
. K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
S DA=7205819,DIK="^LEX(757.01,"
I $$UP^XLFSTR($G(^LEX(757.01,DA,0)))["FLOURIDE" D
. D IX2^DIK S ^LEX(757.01,DA,0)="Deuterium fluoride pumped carbon dioxide laser device" D IX1^DIK
S DA=7205820,DIK="^LEX(757.01,"
I $$UP^XLFSTR($G(^LEX(757.01,DA,0)))["FLOURIDE" D
. D IX2^DIK S ^LEX(757.01,DA,0)="Deuterium fluoride pumped carbon dioxide laser device (physical object)" D IX1^DIK
I $D(^LEX(757.21,"AOBJ","FLOURIDE",7102910)) D
. K ^LEX(757.21,"AOBJ","FLOURIDE",7102910)
. S ^LEX(757.21,"AOBJ","FLUORIDE",7102910)=""
I $D(^LEX(757.21,"ASCT","FLOURIDE",7409747)) D
. K ^LEX(757.21,"ASCT","FLOURIDE",7409747)
. S ^LEX(757.21,"ASCT","FLUORIDE",7409747)=""
I $D(^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)) D
. K ^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)
. S ^LEX(757.21,"C","DEUTERIUM FLUORIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)=""
I $D(^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)) D
. K ^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)
. S ^LEX(757.21,"C","DEUTERIUM FLUORIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)=""
K ^LEX(757.01,"ASL","FLOURIDE")
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
LEX2080A ;ISL/KER - LEX*2.0*80 Pre/Post Install (cont) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^%ZOSF("UCI") ICR 10096
+5 ; ^ICD0( ICR 4486
+6 ; ^ICD0(1535) ICR 4486
+7 ; ^ICD0(1548) ICR 4486
+8 ; ^ICD0(366) ICR 4486
+9 ; ^ICD9( ICR 4485
+10 ; ^ICD9(11938) ICR 4485
+11 ; ^ICD9(3066) ICR 4485
+12 ; ^TMP("LEXKID") SACC 2.3.2.5.1
+13 ;
+14 ; External References
+15 ; $$FMTE^XLFDT ICR 10103
+16 ; FIELD^DID ICR 2052
+17 ; FILE^DID ICR 2052
+18 ; BMES^XPDUTL ICR 10141
+19 ; MES^XPDUTL ICR 10141
+20 ;
STATUS ; ICD-9/10 Status in files 80/80.1 and Lexicon
+1 NEW LEX10,ICD10,ICD9,LEGD,LEGP,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)
SET LEGD=$$LEGD
SET LEGP=$$LEGP
+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 FIELD^DID(757.03,11,"N","LABEL","LEX10","ICDM")
+7 DO BM(" Data Dictionary:")
DO M(" ")
+8 IF '$DATA(ICD9)
DO M(" Legacy ICD Data Dictionary does not exist")
+9 IF $DATA(ICD9)
DO M(" Remnants of the legacy ICD Data Dictionary found")
IF $DATA(ICD9)
SET ICDDD(1)=""
+10 IF '$DATA(ICD10)
DO M(" ICD Data Dictionary updates for ICD-10 not found")
IF '$DATA(ICD10)
SET ICDDD(2)=""
+11 IF $DATA(ICD10)
DO M(" ICD Data Dictionary updates for ICD-10 found")
+12 IF '$DATA(LEX10)
DO M(" Lexicon Data Dictionary updates for ICD-10 not found")
+13 IF $DATA(LEX10)
DO M(" Lexicon Data Dictionary updates for ICD-10 found")
+14 DO BM(" Global:")
DO M(" ")
+15 FOR ICDT=80,80.1,80.4,757,757.001,757.01,757.02,757.03,757.033,757.1,757.3,757.31
Begin DoDot:1
+16 KILL ICDF,ICDM
DO FILE^DID(ICDT,"N","DATE;GLOBAL NAME;NAME;PACKAGE REVISION DATA;VERSION;LOOKUP PROGRAM","ICDF","ICDM")
+17 NEW ICDRT,ICDFI,ICDNM,ICDVR,ICDPK,ICDRV,ICDDT,ICDPT,ICDIEN,ICDENT
+18 SET ICDNM=$EXTRACT($GET(ICDF("NAME")),1,24)
+19 SET ICDNM=$GET(ICDF("NAME"))
+20 SET ICDNM=ICDNM_$JUSTIFY(" ",(36-$LENGTH(ICDNM)))
SET ICDVR=$GET(ICDF("VERSION"))
+21 SET ICDFI=$GET(ICDT)
SET ICDFI=ICDFI_$JUSTIFY(" ",(10-$LENGTH(ICDFI)))
+22 SET ICDRT=$GET(ICDF("GLOBAL NAME"))
SET ICDRT=ICDRT_$JUSTIFY(" ",(15-$LENGTH(ICDRT)))
+23 SET ICDPK=$SELECT($PIECE(ICDT,".",1)=80:"ICD",$PIECE(ICDT,".",1)=757:"LEX",1:"")
IF '$LENGTH(ICDPK)
QUIT
+24 SET ICDRV=$GET(ICDF("PACKAGE REVISION DATA"))
SET ICDDT=$PIECE(ICDRV,"^",2)
SET ICDRV=$PIECE(ICDRV,"^",1)
+25 SET ICDPT=""
IF $LENGTH(ICDPK)&(+($GET(ICDVR))>0)&(+($GET(ICDRV))>0)
SET ICDPT=ICDPK_"*"_ICDVR_"*"_ICDRV
+26 SET ICDPT=ICDPT_$JUSTIFY(" ",(14-$LENGTH(ICDPT)))
SET ICDDT=$SELECT(ICDDT?7N:$TRANSLATE($$FMTE^XLFDT(ICDDT,"5DZ"),"@"," "),1:"")
+27 IF ICDT=80
DO M(" Global Name File # Patched Effective")
+28 DO M((" "_ICDNM_ICDFI_ICDPT_ICDDT))
End DoDot:1
+29 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 "
+30 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"
+31 IF '$DATA(^ICD9(3066,7,1,0))
SET ICDGBL(2)=""
SET ICDATA(80,10)="No "
+32 IF $DATA(^ICD9(3066,7,1,0))
SET ICDATA(80,10)="Yes"
+33 IF '$DATA(^ICD0(366,"MDC"))&($LENGTH($GET(^ICD0(1535,0)),"^")'>1)
SET ICDATA(80.1,9)="No "
+34 IF $DATA(^ICD0(366,"MDC"))!($LENGTH($GET(^ICD0(1535,0)),"^")>1)
SET ICDGBL(1)=""
SET ICDATA(80.1,9)="Yes"
+35 IF '$DATA(^ICD0(1548,3,1,0))&($LENGTH($GET(^ICD0(1548,1)),"^")'>1)
SET ICDGBL(2)=""
SET ICDATA(80.1,10)="No "
+36 IF $DATA(^ICD0(1548,3,1,0))&($LENGTH($GET(^ICD0(1548,1)),"^")>1)
SET ICDATA(80.1,10)="Yes"
+37 IF +LEGD>0
SET ICDATA(80,9)="Yes"
IF +LEGP>0
SET ICDATA(80.1,9)="Yes"
+38 SET ICDX=" "
SET ICDX=ICDX_$JUSTIFY(" ",(32-$LENGTH(ICDX)))_"Legacy ICD-9"
+39 SET ICDX=ICDX_$JUSTIFY(" ",(50-$LENGTH(ICDX)))_"Updated ICD-10"
DO M(ICDX)
+40 SET ICDX=" Coding System Data"
SET ICDX=ICDX_$JUSTIFY(" ",(32-$LENGTH(ICDX)))_"Data Format"
+41 SET ICDX=ICDX_$JUSTIFY(" ",(50-$LENGTH(ICDX)))_"Data Format"
DO M(ICDX)
+42 SET ICDX=" ICD Diagnosis Data"
SET ICDX=ICDX_$JUSTIFY(" ",(37-$LENGTH(ICDX)))_$GET(ICDATA(80,9))
+43 SET ICDX=ICDX_$JUSTIFY(" ",(55-$LENGTH(ICDX)))_$GET(ICDATA(80,10))
DO M(ICDX)
+44 SET ICDX=" ICD Procedure Data"
SET ICDX=ICDX_$JUSTIFY(" ",(37-$LENGTH(ICDX)))_$GET(ICDATA(80.1,9))
+45 SET ICDX=ICDX_$JUSTIFY(" ",(55-$LENGTH(ICDX)))_$GET(ICDATA(80.1,10))
DO M(ICDX)
+46 SET ICDX=" Lexicon Data "
SET ICDX=ICDX_$JUSTIFY(" ",(32-$LENGTH(ICDX)))_" ICD-9"
+47 SET ICDX=ICDX_$JUSTIFY(" ",(50-$LENGTH(ICDX)))_" ICD-10"
DO BM(ICDX)
+48 SET ICD9=$SELECT($ORDER(^LEX(757.02,"ASRC","ICD",0))>0:"Yes",1:"No")
+49 SET ICD10=$SELECT($ORDER(^LEX(757.02,"ASRC","10D",0))>0:"Yes",1:"No")
+50 SET ICDX=" ICD Diagnosis"
SET ICDX=ICDX_$JUSTIFY(" ",(37-$LENGTH(ICDX)))_ICD9
+51 SET ICDX=ICDX_$JUSTIFY(" ",(55-$LENGTH(ICDX)))_ICD10
DO M(ICDX)
+52 SET ICD9=$SELECT($ORDER(^LEX(757.02,"ASRC","ICP",0))>0:"Yes",1:"No")
+53 SET ICD10=$SELECT($ORDER(^LEX(757.02,"ASRC","10P",0))>0:"Yes",1:"No")
+54 SET ICDX=" ICD Procedures"
SET ICDX=ICDX_$JUSTIFY(" ",(37-$LENGTH(ICDX)))_ICD9
+55 SET ICDX=ICDX_$JUSTIFY(" ",(55-$LENGTH(ICDX)))_ICD10
DO M(ICDX)
+56 QUIT
LEGD(X) ; ICD 9 Legacy Data
+1 NEW ICDI,ICD9
SET (ICDI,ICD9)=0
FOR
SET ICDI=$ORDER(^ICD9(ICDI))
IF +ICDI'>0
QUIT
IF ICDI>499999
QUIT
IF ICD9>0
QUIT
Begin DoDot:1
+2 IF $DATA(^ICD9(ICDI,"DRG"))
SET ICD9=1
IF ICD9
QUIT
+3 IF $DATA(^ICD9(ICDI,66,1,"DRG"))!($DATA(^ICD9(ICDI,66,3,"DRG")))
SET ICD9=1
IF ICD9
QUIT
+4 IF $LENGTH($GET(^ICD9(ICDI,0)),"^")>1
SET ICD9=1
End DoDot:1
IF ICD9>0
QUIT
+5 SET X=+ICD9
+6 QUIT X
LEGP(X) ; ICD 0 Legacy Data
+1 NEW ICDI,ICD0
SET (ICDI,ICD0)=0
FOR
SET ICDI=$ORDER(^ICD0(ICDI))
IF +ICDI'>0
QUIT
IF ICDI>499999
QUIT
IF ICD0>0
QUIT
Begin DoDot:1
+2 IF $LENGTH($GET(^ICD0(ICDI,0)),"^")>1
SET ICD0=1
IF ICD0
QUIT
+3 IF $LENGTH($GET(^ICD0(ICDI,1)))&($PIECE($GET(^ICD0(ICDI,1)),"^",1)'?1N.N)
SET ICD0=1
IF ICD0
QUIT
+4 IF $DATA(^ICD0(ICDI,"MDC"))
SET ICD0=1
IF ICD0
QUIT
End DoDot:1
IF ICD0>0
QUIT
+5 SET X=+ICD0
+6 QUIT X
FL ; Flouride to Fluoride
+1 QUIT
+2 IF $PIECE($GET(^ICPT(108897,0)),"^",2)="TOPICAL FLOURIDE VARNISH"
Begin DoDot:1
+3 NEW DA,DIK
SET DA=108897
SET DIK="^ICPT("
DO IX2^DIK
+4 SET $PIECE(^ICPT(108897,0),"^",2)="TOPICAL FLUORIDE VARNISH"
+5 SET DA=108897
SET DIK="^ICPT("
DO IX1^DIK
End DoDot:1
+6 IF $PIECE($GET(^ICPT(108897,61,2,0)),"^",2)="TOPICAL FLOURIDE VARNISH"
Begin DoDot:1
+7 NEW DA,DIK
SET DA=108897
SET DIK="^ICPT("
DO IX2^DIK
+8 SET $PIECE(^ICPT(108897,61,2,0),"^",2)="TOPICAL FLUORIDE VARNISH"
+9 SET DA=108897
SET DIK="^ICPT("
DO IX1^DIK
End DoDot:1
+10 IF $PIECE($GET(^ICPT(110825,0)),"^",2)="TOPICAL FLOURIDE"
Begin DoDot:1
+11 NEW DA,DIK
SET DA=110825
SET DIK="^ICPT("
DO IX2^DIK
+12 SET $PIECE(^ICPT(110825,0),"^",2)="TOPICAL FLUORIDE"
+13 SET DA=110825
SET DIK="^ICPT("
DO IX1^DIK
End DoDot:1
+14 IF $PIECE($GET(^ICPT(110825,61,1,0)),"^",2)="TOPICAL FLOURIDE"
Begin DoDot:1
+15 NEW DA,DIK
SET DA=110825
SET DIK="^ICPT("
DO IX2^DIK
+16 SET $PIECE(^ICPT(110825,61,1,0),"^",2)="TOPICAL FLUORIDE"
+17 SET DA=110825
SET DIK="^ICPT("
DO IX1^DIK
End DoDot:1
+18 SET DA(1)=306305
SET DA=207
SET DIK="^LEX(757.01,"_DA(1)_",5,"
+19 IF $DATA(^LEX(757.01,DA(1),5,DA))
Begin DoDot:1
+20 DO ^DIK
KILL ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
+21 KILL ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
End DoDot:1
+22 SET DA(1)=309984
SET DA=21
SET DIK="^LEX(757.01,"_DA(1)_",5,"
+23 IF $DATA(^LEX(757.01,DA(1),5,DA))
Begin DoDot:1
+24 DO ^DIK
KILL ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
+25 KILL ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
End DoDot:1
+26 SET DA(1)=306668
SET DA=52
SET DIK="^LEX(757.01,"_DA(1)_",5,"
+27 IF $DATA(^LEX(757.01,DA(1),5,DA))
Begin DoDot:1
+28 DO ^DIK
KILL ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
+29 KILL ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
End DoDot:1
+30 SET DA(1)=309999
SET DA=22
SET DIK="^LEX(757.01,"_DA(1)_",5,"
+31 IF $DATA(^LEX(757.01,DA(1),5,DA))
Begin DoDot:1
+32 DO ^DIK
KILL ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
+33 KILL ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
End DoDot:1
+34 SET DA(1)=312701
SET DA=5
SET DIK="^LEX(757.01,"_DA(1)_",5,"
+35 IF $DATA(^LEX(757.01,DA(1),5,DA))
Begin DoDot:1
+36 DO ^DIK
KILL ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
+37 KILL ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
End DoDot:1
+38 SET DA(1)=312704
SET DA=7
SET DIK="^LEX(757.01,"_DA(1)_",5,"
+39 IF $DATA(^LEX(757.01,DA(1),5,DA))
Begin DoDot:1
+40 DO ^DIK
KILL ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
+41 KILL ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
End DoDot:1
+42 SET DA=7205819
SET DIK="^LEX(757.01,"
+43 IF $$UP^XLFSTR($GET(^LEX(757.01,DA,0)))["FLOURIDE"
Begin DoDot:1
+44 DO IX2^DIK
SET ^LEX(757.01,DA,0)="Deuterium fluoride pumped carbon dioxide laser device"
DO IX1^DIK
End DoDot:1
+45 SET DA=7205820
SET DIK="^LEX(757.01,"
+46 IF $$UP^XLFSTR($GET(^LEX(757.01,DA,0)))["FLOURIDE"
Begin DoDot:1
+47 DO IX2^DIK
SET ^LEX(757.01,DA,0)="Deuterium fluoride pumped carbon dioxide laser device (physical object)"
DO IX1^DIK
End DoDot:1
+48 IF $DATA(^LEX(757.21,"AOBJ","FLOURIDE",7102910))
Begin DoDot:1
+49 KILL ^LEX(757.21,"AOBJ","FLOURIDE",7102910)
+50 SET ^LEX(757.21,"AOBJ","FLUORIDE",7102910)=""
End DoDot:1
+51 IF $DATA(^LEX(757.21,"ASCT","FLOURIDE",7409747))
Begin DoDot:1
+52 KILL ^LEX(757.21,"ASCT","FLOURIDE",7409747)
+53 SET ^LEX(757.21,"ASCT","FLUORIDE",7409747)=""
End DoDot:1
+54 IF $DATA(^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910))
Begin DoDot:1
+55 KILL ^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)
+56 SET ^LEX(757.21,"C","DEUTERIUM FLUORIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)=""
End DoDot:1
+57 IF $DATA(^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747))
Begin DoDot:1
+58 KILL ^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)
+59 SET ^LEX(757.21,"C","DEUTERIUM FLUORIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)=""
End DoDot:1
+60 KILL ^LEX(757.01,"ASL","FLOURIDE")
+61 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
