Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEX2080A

LEX2080A.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Global Variables
  1. ; ^%ZOSF("UCI") ICR 10096
  1. ; ^ICD0( ICR 4486
  1. ; ^ICD0(1535) ICR 4486
  1. ; ^ICD0(1548) ICR 4486
  1. ; ^ICD0(366) ICR 4486
  1. ; ^ICD9( ICR 4485
  1. ; ^ICD9(11938) ICR 4485
  1. ; ^ICD9(3066) ICR 4485
  1. ; ^TMP("LEXKID") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; $$FMTE^XLFDT ICR 10103
  1. ; FIELD^DID ICR 2052
  1. ; FILE^DID ICR 2052
  1. ; BMES^XPDUTL ICR 10141
  1. ; MES^XPDUTL ICR 10141
  1. ;
  1. STATUS ; ICD-9/10 Status in files 80/80.1 and Lexicon
  1. 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
  1. 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
  1. S ICDX=" Checking "_$S($L(ICDNS):(ICDNS_" "),1:"")_"ICD Data Dictionary/Global/Data Status:" D BM(ICDX)
  1. D FIELD^DID(80.066,60,"N","LABEL","ICD9","ICDM")
  1. D FIELD^DID(80.012,.01,"N","LABEL","ICD10","ICDM")
  1. D FIELD^DID(757.03,11,"N","LABEL","LEX10","ICDM")
  1. D BM(" Data Dictionary:"),M(" ")
  1. D:'$D(ICD9) M(" Legacy ICD Data Dictionary does not exist")
  1. D:$D(ICD9) M(" Remnants of the legacy ICD Data Dictionary found") S:$D(ICD9) ICDDD(1)=""
  1. D:'$D(ICD10) M(" ICD Data Dictionary updates for ICD-10 not found") S:'$D(ICD10) ICDDD(2)=""
  1. D:$D(ICD10) M(" ICD Data Dictionary updates for ICD-10 found")
  1. D:'$D(LEX10) M(" Lexicon Data Dictionary updates for ICD-10 not found")
  1. D:$D(LEX10) M(" Lexicon Data Dictionary updates for ICD-10 found")
  1. D BM(" Global:"),M(" ")
  1. 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
  1. . K ICDF,ICDM D FILE^DID(ICDT,"N","DATE;GLOBAL NAME;NAME;PACKAGE REVISION DATA;VERSION;LOOKUP PROGRAM","ICDF","ICDM")
  1. . N ICDRT,ICDFI,ICDNM,ICDVR,ICDPK,ICDRV,ICDDT,ICDPT,ICDIEN,ICDENT
  1. . S ICDNM=$E($G(ICDF("NAME")),1,24)
  1. . S ICDNM=$G(ICDF("NAME"))
  1. . S ICDNM=ICDNM_$J(" ",(36-$L(ICDNM))) S ICDVR=$G(ICDF("VERSION"))
  1. . S ICDFI=$G(ICDT),ICDFI=ICDFI_$J(" ",(10-$L(ICDFI)))
  1. . S ICDRT=$G(ICDF("GLOBAL NAME")),ICDRT=ICDRT_$J(" ",(15-$L(ICDRT)))
  1. . S ICDPK=$S($P(ICDT,".",1)=80:"ICD",$P(ICDT,".",1)=757:"LEX",1:"") Q:'$L(ICDPK)
  1. . S ICDRV=$G(ICDF("PACKAGE REVISION DATA")),ICDDT=$P(ICDRV,"^",2),ICDRV=$P(ICDRV,"^",1)
  1. . S ICDPT="" S:$L(ICDPK)&(+($G(ICDVR))>0)&(+($G(ICDRV))>0) ICDPT=ICDPK_"*"_ICDVR_"*"_ICDRV
  1. . S ICDPT=ICDPT_$J(" ",(14-$L(ICDPT))),ICDDT=$S(ICDDT?7N:$TR($$FMTE^XLFDT(ICDDT,"5DZ"),"@"," "),1:"")
  1. . D:ICDT=80 M(" Global Name File # Patched Effective")
  1. . D M((" "_ICDNM_ICDFI_ICDPT_ICDDT))
  1. 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 "
  1. I $D(^ICD9(3066,"DRG"))!($D(^ICD9(11938,66,3,"DRG")))!($L($G(^ICD9(3066,0)),"^")>1) S ICDGBL(1)="",ICDATA(80,9)="Yes"
  1. I '$D(^ICD9(3066,7,1,0)) S ICDGBL(2)="",ICDATA(80,10)="No "
  1. I $D(^ICD9(3066,7,1,0)) S ICDATA(80,10)="Yes"
  1. I '$D(^ICD0(366,"MDC"))&($L($G(^ICD0(1535,0)),"^")'>1) S ICDATA(80.1,9)="No "
  1. I $D(^ICD0(366,"MDC"))!($L($G(^ICD0(1535,0)),"^")>1) S ICDGBL(1)="",ICDATA(80.1,9)="Yes"
  1. I '$D(^ICD0(1548,3,1,0))&($L($G(^ICD0(1548,1)),"^")'>1) S ICDGBL(2)="",ICDATA(80.1,10)="No "
  1. I $D(^ICD0(1548,3,1,0))&($L($G(^ICD0(1548,1)),"^")>1) S ICDATA(80.1,10)="Yes"
  1. S:+LEGD>0 ICDATA(80,9)="Yes" S:+LEGP>0 ICDATA(80.1,9)="Yes"
  1. S ICDX=" ",ICDX=ICDX_$J(" ",(32-$L(ICDX)))_"Legacy ICD-9"
  1. S ICDX=ICDX_$J(" ",(50-$L(ICDX)))_"Updated ICD-10" D M(ICDX)
  1. S ICDX=" Coding System Data",ICDX=ICDX_$J(" ",(32-$L(ICDX)))_"Data Format"
  1. S ICDX=ICDX_$J(" ",(50-$L(ICDX)))_"Data Format" D M(ICDX)
  1. S ICDX=" ICD Diagnosis Data",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_$G(ICDATA(80,9))
  1. S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_$G(ICDATA(80,10)) D M(ICDX)
  1. S ICDX=" ICD Procedure Data",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_$G(ICDATA(80.1,9))
  1. S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_$G(ICDATA(80.1,10)) D M(ICDX)
  1. S ICDX=" Lexicon Data ",ICDX=ICDX_$J(" ",(32-$L(ICDX)))_" ICD-9"
  1. S ICDX=ICDX_$J(" ",(50-$L(ICDX)))_" ICD-10" D BM(ICDX)
  1. S ICD9=$S($O(^LEX(757.02,"ASRC","ICD",0))>0:"Yes",1:"No")
  1. S ICD10=$S($O(^LEX(757.02,"ASRC","10D",0))>0:"Yes",1:"No")
  1. S ICDX=" ICD Diagnosis",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_ICD9
  1. S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_ICD10 D M(ICDX)
  1. S ICD9=$S($O(^LEX(757.02,"ASRC","ICP",0))>0:"Yes",1:"No")
  1. S ICD10=$S($O(^LEX(757.02,"ASRC","10P",0))>0:"Yes",1:"No")
  1. S ICDX=" ICD Procedures",ICDX=ICDX_$J(" ",(37-$L(ICDX)))_ICD9
  1. S ICDX=ICDX_$J(" ",(55-$L(ICDX)))_ICD10 D M(ICDX)
  1. Q
  1. LEGD(X) ; ICD 9 Legacy Data
  1. 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
  1. . S:$D(^ICD9(ICDI,"DRG")) ICD9=1 Q:ICD9
  1. . S:$D(^ICD9(ICDI,66,1,"DRG"))!($D(^ICD9(ICDI,66,3,"DRG"))) ICD9=1 Q:ICD9
  1. . S:$L($G(^ICD9(ICDI,0)),"^")>1 ICD9=1
  1. S X=+ICD9
  1. Q X
  1. LEGP(X) ; ICD 0 Legacy Data
  1. 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
  1. . S:$L($G(^ICD0(ICDI,0)),"^")>1 ICD0=1 Q:ICD0
  1. . S:$L($G(^ICD0(ICDI,1)))&($P($G(^ICD0(ICDI,1)),"^",1)'?1N.N) ICD0=1 Q:ICD0
  1. . S:$D(^ICD0(ICDI,"MDC")) ICD0=1 Q:ICD0
  1. S X=+ICD0
  1. Q X
  1. FL ; Flouride to Fluoride
  1. Q
  1. I $P($G(^ICPT(108897,0)),"^",2)="TOPICAL FLOURIDE VARNISH" D
  1. . N DA,DIK S DA=108897,DIK="^ICPT(" D IX2^DIK
  1. . S $P(^ICPT(108897,0),"^",2)="TOPICAL FLUORIDE VARNISH"
  1. . S DA=108897,DIK="^ICPT(" D IX1^DIK
  1. I $P($G(^ICPT(108897,61,2,0)),"^",2)="TOPICAL FLOURIDE VARNISH" D
  1. . N DA,DIK S DA=108897,DIK="^ICPT(" D IX2^DIK
  1. . S $P(^ICPT(108897,61,2,0),"^",2)="TOPICAL FLUORIDE VARNISH"
  1. . S DA=108897,DIK="^ICPT(" D IX1^DIK
  1. I $P($G(^ICPT(110825,0)),"^",2)="TOPICAL FLOURIDE" D
  1. . N DA,DIK S DA=110825,DIK="^ICPT(" D IX2^DIK
  1. . S $P(^ICPT(110825,0),"^",2)="TOPICAL FLUORIDE"
  1. . S DA=110825,DIK="^ICPT(" D IX1^DIK
  1. I $P($G(^ICPT(110825,61,1,0)),"^",2)="TOPICAL FLOURIDE" D
  1. . N DA,DIK S DA=110825,DIK="^ICPT(" D IX2^DIK
  1. . S $P(^ICPT(110825,61,1,0),"^",2)="TOPICAL FLUORIDE"
  1. . S DA=110825,DIK="^ICPT(" D IX1^DIK
  1. S DA(1)=306305,DA=207,DIK="^LEX(757.01,"_DA(1)_",5,"
  1. I $D(^LEX(757.01,DA(1),5,DA)) D
  1. . D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
  1. . K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
  1. S DA(1)=309984,DA=21,DIK="^LEX(757.01,"_DA(1)_",5,"
  1. I $D(^LEX(757.01,DA(1),5,DA)) D
  1. . D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
  1. . K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
  1. S DA(1)=306668,DA=52,DIK="^LEX(757.01,"_DA(1)_",5,"
  1. I $D(^LEX(757.01,DA(1),5,DA)) D
  1. . D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
  1. . K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
  1. S DA(1)=309999,DA=22,DIK="^LEX(757.01,"_DA(1)_",5,"
  1. I $D(^LEX(757.01,DA(1),5,DA)) D
  1. . D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
  1. . K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
  1. S DA(1)=312701,DA=5,DIK="^LEX(757.01,"_DA(1)_",5,"
  1. I $D(^LEX(757.01,DA(1),5,DA)) D
  1. . D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
  1. . K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
  1. S DA(1)=312704,DA=7,DIK="^LEX(757.01,"_DA(1)_",5,"
  1. I $D(^LEX(757.01,DA(1),5,DA)) D
  1. . D ^DIK K ^LEX(757.01,DA(1),5,"B","FLOURIDE",DA)
  1. . K ^LEX(757.01,"AWRD","FLOURIDE",DA(1),DA(1),DA)
  1. S DA=7205819,DIK="^LEX(757.01,"
  1. I $$UP^XLFSTR($G(^LEX(757.01,DA,0)))["FLOURIDE" D
  1. . D IX2^DIK S ^LEX(757.01,DA,0)="Deuterium fluoride pumped carbon dioxide laser device" D IX1^DIK
  1. S DA=7205820,DIK="^LEX(757.01,"
  1. I $$UP^XLFSTR($G(^LEX(757.01,DA,0)))["FLOURIDE" D
  1. . D IX2^DIK S ^LEX(757.01,DA,0)="Deuterium fluoride pumped carbon dioxide laser device (physical object)" D IX1^DIK
  1. I $D(^LEX(757.21,"AOBJ","FLOURIDE",7102910)) D
  1. . K ^LEX(757.21,"AOBJ","FLOURIDE",7102910)
  1. . S ^LEX(757.21,"AOBJ","FLUORIDE",7102910)=""
  1. I $D(^LEX(757.21,"ASCT","FLOURIDE",7409747)) D
  1. . K ^LEX(757.21,"ASCT","FLOURIDE",7409747)
  1. . S ^LEX(757.21,"ASCT","FLUORIDE",7409747)=""
  1. I $D(^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)) D
  1. . K ^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)
  1. . S ^LEX(757.21,"C","DEUTERIUM FLUORIDE PUMPED CARBON DIOXIDE LASER DEVICE",7102910)=""
  1. I $D(^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)) D
  1. . K ^LEX(757.21,"C","DEUTERIUM FLOURIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)
  1. . S ^LEX(757.21,"C","DEUTERIUM FLUORIDE PUMPED CARBON DIOXIDE LASER DEVICE",7409747)=""
  1. K ^LEX(757.01,"ASL","FLOURIDE")
  1. Q
  1. BL ; Blank Line
  1. D TL(" ")
  1. Q
  1. TL(X) ; Text Line
  1. N LEXI S LEXI=$O(^TMP("LEXKID",$J," "),-1),LEXI=LEXI+1,^TMP("LEXKID",$J,LEXI)=$G(X),^TMP("LEXKID",$J,0)=LEXI
  1. Q
  1. M(X) ; Blank/Text
  1. D MES^XPDUTL($G(X)) Q
  1. BM(X) ; Blank/Text
  1. D BMES^XPDUTL($G(X)) Q