- 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