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

LEX2047B.m

Go to the documentation of this file. 
  1. LEX2047B ; ISL/KER - Post Install LEX*2.0*47 (part 2)  ; 02/05/2007
  1.  ;;2.0;LEXICON UTILITY;**47**;Sep 23, 1996;Build 5
  1.  ;                    
  1.  ; Global Variables
  1.  ;    ^ICPT(           DBIA 4489
  1.  ;    ^LEX(757.01      N/A
  1.  ;    ^LEX(757.02      N/A
  1.  ;    ^DIC(81.3,       DBIA 4492
  1.  ;                    
  1.  ; External References
  1.  ;    FILE^DIE         DBIA 2053
  1.  ;    UPDATE^DIE       DBIA 2053
  1.  ;    ^DIK             DBIA 10013          
  1.  ;    IX1^DIK          DBIA 10013
  1.  ;    $$IENS^DILF      DBIA 2054
  1.  ;    MES^XPDUTL       DBIA 10141
  1.  ;                    
  1. EN ; Main Entry Point
  1.  D C6,C7,C8,C9,C10,C11
  1.  Q
  1. C6 ;   161266 Canalith (HCPCS S9092) is misspelled
  1.  D IND(" "),REMI("CANALITH (S9092) is misspelled","HD0000000 161266")
  1.  D IND("    S9092 - Change CANOLITH to CANALITH")
  1.  N IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE
  1.  K IENS,FDA S (IEN,DA)=329685,IENS=IEN_",",FDA(757.01,IENS,.01)="Canalith Repositioning, per visit" D FILE^DIE("","FDA") S DIK="^LEX(757.01," D IX1^DIK
  1.  S (IEN,DA(1),LEXDA(1))=107092,(IENA,LEXDA,DA)=$O(^ICPT(IEN,61,"B",3030101,0)) I +IEN>0,+IENA>0 D
  1.  . K IENS,FDA S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="CANALITH REPOSITIONING" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
  1.  S (IEN,DA(1),LEXDA(1))=107092,(IENA,LEXDA,DA)=$O(^ICPT(IEN,62,"B",3030101,0)) I +IEN>0,+IENA>0 D
  1.  . K IENS,FDA N DA,I S DA(2)=LEXDA(1),DA(1)=LEXDA S I=0  F  S I=$O(^ICPT(DA(2),62,DA(1),1,I)) Q:+I'>0  D
  1.  . . S DA=I Q:$G(^ICPT(DA(2),62,DA(1),1,DA,0))'["CANOLITH REPOSITIONING, PER VISIT"  N LEXDA S LEXDA(2)=DA(2),LEXDA(1)=DA(1),LEXDA=DA
  1.  . . S IENS=$$IENS^DILF(.LEXDA),FDA(81.621,IENS,.01)="CANALITH REPOSITIONING, PER VISIT" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
  1.  I $D(^ICPT(107092,"D",1,0)) D
  1.  . Q:$G(^ICPT(107092,"D",1,0))'["CANOLITH REPOSITIONING, PER VISIT"
  1.  . S ^ICPT(107092,"D",1,0)="CANALITH REPOSITIONING, PER VISIT" K ^ICPT(107092,"D","B") S ^ICPT(107092,"D","B","CANALITH REPOSITIONING, PER VI",1)=""
  1.  K IENS,DA,FDA S DA=IEN S FDA(81,IEN_",",2)="CANALITH REPOSITIONING" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
  1.  Q
  1. C7 ;   166892 CPT J0585 Botulinum Toxin Quantity
  1.  D IND(" "),REMI("Botulinum Toxin Quantity (J0585)","HD0000000 166892")
  1.  K IENS,FDA S (IEN,LEXDA,DA)=320347 S FDA(757.01,IEN_",",.01)="Botulinum toxin type A, per unit"
  1.  D FILE^DIE("","FDA") S DA=IEN,DIK="^LEX(757.01," D IX1^DIK
  1.  Q
  1. C8 ;   168449 Lookup 038.9 returns 995.91
  1.  D IND(" "),REMI("Lookup ICD 038.9 returns 995.91","HD0000000 168449")
  1.  D REMI("Lookup ICD 038.9 returns 995.91 (dupe)","HD0000000 171316")
  1.  N FDA,DA,DIK S DA=330020
  1.  K FDA S FDA(757.02,(DA_","),6)=0 D FILE^DIE("","FDA")
  1.  K FDA S FDA(757.02,(DA_","),4)=0 D FILE^DIE("","FDA") S DA=324672
  1.  K FDA S FDA(757.02,(DA_","),6)=1 D FILE^DIE("","FDA")
  1.  K FDA S FDA(757.02,(DA_","),4)=1 D FILE^DIE("","FDA")
  1.  K FDA S FDA(757.02,(DA_","),5)="" D FILE^DIE("","FDA")
  1.  S DA(1)=324672,DA=2 I $D(^LEX(757.02,DA(1),4,DA,0)) D
  1.  . S DIK="^LEX(757.02,"_DA(1)_",4," D ^DIK
  1.  K DA S DIK="^LEX(757.02,",DA=330020 D IX1^DIK S DA=324672 D IX1^DIK
  1.  Q
  1. C9 ;   174410 New dental code D2970
  1.  D IND(" "),REMI("New Dental Code D2970","HD0000000 174410")
  1.  N ACT,CPIEN,DA,DIC,DIE,DIK,EFF,EXIEN,EXIST,EXP,FDA,I,IEN,IENS,MSG,SOIEN,TXT S EXIEN=318447,IENS=EXIEN_","
  1.  S EXP="Temporary Crown (Fractured Tooth), usually a preformed artificial Crown, fitted over a damaged tooth as an immediate protective device.  (not to be used as a temporization during crown fabrication)"
  1.  K FDA S FDA(757.01,IENS,.01)=EXP D FILE^DIE("","FDA") K DA S DA=EXIEN,DIK="^LEX(757.01," D IX1^DIK
  1.  K DA,DIK,DIC,FDA,IENS,ACT S SOIEN=254,ACT=3,EFF=3070101,IENS="+"_ACT_","_SOIEN_","
  1.  S EXIST=$O(^LEX(757.02,SOIEN,4,"B",EFF,0)),EXIST=$P($G(^LEX(757.02,SOIEN,4,+EXIST,0)),"^",2)
  1.  S FDA(757.28,IENS,.01)=EFF,FDA(757.28,IENS,1)=1 I '$L(EXIST)!(+EXIST'>0) D UPDATE^DIE("S","FDA",,("MSG("_SOIEN_")"))
  1.  K DA,DIK,DIC,FDA,IENS,ACT S CPIEN=100384,EFF=3070101
  1.  S IENS=CPIEN_",",FDA(81,IENS,2)="TEMPORARY CROWN (FX TOOTH)",FDA(81,IENS,5)="",FDA(81,IENS,7)=""
  1.  S FDA(81,IENS,8)=EFF D UPDATE^DIE("S","FDA",,("MSG("_CPIEN_")"))
  1.  K DA,DIK,DIC,FDA,IENS,ACT S ACT=3,IENS="+"_ACT_","_CPIEN_","
  1.  S EXIST=$O(^ICPT(CPIEN,60,"B",EFF,0)),EXIST=$P($G(^ICPT(CPIEN,60,+EXIST,0)),"^",2)
  1.  S FDA(81.02,IENS,.01)=EFF,FDA(81.02,IENS,.02)=1
  1.  I '$L(EXIST)!(+EXIST'>0) D UPDATE^DIE("S","FDA",,("MSG("_CPIEN_")"))
  1.  K DA,DIK,DIC,FDA,IENS,ACT,TXT S ACT=2,IENS="+"_ACT_","_CPIEN_",",TXT="TEMPORARY CROWN (FX TOOTH)"
  1.  S EXIST=$O(^ICPT(CPIEN,61,"B",EFF,0)),EXIST=$P($G(^ICPT(CPIEN,61,+EXIST,0)),"^",2)
  1.  S FDA(81.061,IENS,.01)=EFF,FDA(81.061,IENS,1)=TXT
  1.  I '$L(EXIST) D UPDATE^DIE("S","FDA",,("MSG("_CPIEN_")"))
  1.  K DA,DIK,DIC,FDA,IENS,ACT,TXT,IEN S ACT=2,IENS="+"_ACT_","_CPIEN_",",IEN=0
  1.  S TXT(1)="TEMPORARY CROWN (FRACTURED TOOTH), USUALLY A PREFORMED ARTIFICIAL CROWN,"
  1.  S TXT(2)="FITTED OVER A DAMAGED TOOTH AS AN IMMEDIATE PROTECTIVE DEVICE.  (NOT TO"
  1.  S TXT(3)="BE USED AS A TEMPORIZATION DURING CROWN FABRICATION)"
  1.  S EXIST=$O(^ICPT(CPIEN,62,"B",EFF,0)),EXIST=$P($G(^ICPT(CPIEN,62,+EXIST,0)),"^",1)
  1.  S FDA(81.062,IENS,.01)=EFF I '$L(EXIST)!(EXIST'=EFF) D UPDATE^DIE("S","FDA",,("MSG("_CPIEN_")"))
  1.  S IEN=$O(^ICPT(CPIEN,62,"B",EFF,0)) I +IEN>0 D
  1.  . N DA,DIK,I S DA(2)=CPIEN,DA(1)=IEN S I=0 F  S I=$O(^ICPT(DA(2),62,DA(1),1,I)) Q:+I'>0  D
  1.  . . S DIK="^ICPT("_DA(2)_",62,"_DA(1)_",1,",DA=I D ^DIK
  1.  . S DA(2)=CPIEN,DA(1)=IEN S I=0 F  S I=$O(TXT(I)) Q:+I'>0  D
  1.  . . Q:'$L($G(TXT(I)))  S ^ICPT(DA(2),62,DA(1),1,I,0)=$G(TXT(I))
  1.  . . S DIK="^ICPT("_DA(2)_",62,"_DA(1)_",1,",DA=I D:+($G(CPIEN))>0&(+($G(IEN))>0)&(+($G(I))>0) IX1^DIK
  1.  K DA,DIK S DA(1)=CPIEN,DA=IEN,DIK="^ICPT("_DA(1)_",62," D:+($G(CPIEN))>0&(+($G(IEN))>0) IX1^DIK
  1.  Q
  1. C10 ;   162142 - 63044 with RT
  1.  ;   169057 - 63043-63044 with RT
  1.  D IND(" "),REMI("CPT Modifier Ranges Added for RT/LT","HD0000000 161142")
  1.  D REMI("CPT Modifier Ranges Added for RT/LT (similar)","HD0000000 169057")
  1.  D IND("    CPT Range 63040")
  1.  N MIEN,RIEN,VAL,NIEN
  1.  S VAL="63040^63040^3070101^",MIEN=83,RIEN=0 F  S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0  D
  1.  . Q:$G(^DIC(81.3,MIEN,10,RIEN,0))'=VAL
  1.  . N DA,DIK S DA(1)=MIEN,DA=RIEN,DIK="^DIC(81.3,"_DA(1)_",10," D ^DIK K ^DIC(81.3,MIEN,10,RIEN,0)
  1.  I '$D(^DIC(81.3,MIEN,"M",63040)) D
  1.  . N NIEN S NIEN=$O(^DIC(81.3,MIEN,10," "),-1)+1,^DIC(81.3,MIEN,10,NIEN,0)=VAL,DA=MIEN,DIK="^DIC(81.3," D IX1^DIK
  1.  S VAL="63042^63044^3070101^",MIEN=83,RIEN=0 F  S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0  D
  1.  . Q:$G(^DIC(81.3,MIEN,10,RIEN,0))'=VAL
  1.  . N DA,DIK S DA(1)=MIEN,DA=RIEN,DIK="^DIC(81.3,"_DA(1)_",10," D ^DIK K ^DIC(81.3,MIEN,10,RIEN,0)
  1.  I '$D(^DIC(81.3,MIEN,"M",63042)) D
  1.  . N NIEN S NIEN=$O(^DIC(81.3,MIEN,10," "),-1)+1,^DIC(81.3,MIEN,10,NIEN,0)=VAL,DA=MIEN,DIK="^DIC(81.3," D IX1^DIK
  1.  D IND("    CPT Range 63042-63044")
  1.  S VAL="63040^63040^3070101^",MIEN=109,RIEN=0 F  S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0  D
  1.  . Q:$G(^DIC(81.3,MIEN,10,RIEN,0))'=VAL
  1.  . N DA,DIK S DA(1)=MIEN,DA=RIEN,DIK="^DIC(81.3,"_DA(1)_",10," D ^DIK K ^DIC(81.3,MIEN,10,RIEN,0)
  1.  I '$D(^DIC(81.3,MIEN,"M",63040)) D
  1.  . N NIEN S NIEN=$O(^DIC(81.3,MIEN,10," "),-1)+1,^DIC(81.3,MIEN,10,NIEN,0)=VAL,DA=MIEN,DIK="^DIC(81.3," D IX1^DIK
  1.  S VAL="63042^63044^3070101^",MIEN=109,RIEN=0 F  S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0  D
  1.  . Q:$G(^DIC(81.3,MIEN,10,RIEN,0))'=VAL
  1.  . N DA,DIK S DA(1)=MIEN,DA=RIEN,DIK="^DIC(81.3,"_DA(1)_",10," D ^DIK K ^DIC(81.3,MIEN,10,RIEN,0)
  1.  I '$D(^DIC(81.3,MIEN,"M",63042)) D
  1.  . N NIEN S NIEN=$O(^DIC(81.3,MIEN,10," "),-1)+1,^DIC(81.3,MIEN,10,NIEN,0)=VAL,DA=MIEN,DIK="^DIC(81.3," D IX1^DIK
  1.  Q
  1. C11 ;   173816 - Re-Code Hyperglycemia as ICD 790.29
  1.  D IND(" "),REMI("Re-Code ""Hyperglycemia"" as ICD Code 790.29","HD0000000 173816")
  1.  N DA,DIE,DIK,EFF,EXIST,FDA,IEN,IENE,IENS,TXT
  1.  K FDA,IENS,IEN,DA,DIK S IEN=63620,IENS=IEN_","
  1.  S FDA(757.02,IENS,1)=790.29 D FILE^DIE("","FDA") S DA=IEN,DIK="^LEX(757.02," D IX1^DIK
  1.  K FDA,IENS,IEN,DA,DIK S IEN=329955,IENS=IEN_","
  1.  S FDA(757.01,IENS,.01)="Abnormal Glucose" D FILE^DIE("","FDA") S DA=IEN,DIK="^LEX(757.01," D IX1^DIK
  1.  Q
  1.  ;                 
  1.  ; Miscellaneous
  1. REMI(X,Y) ;   Remedy Ticket - Indented
  1.  N I S X=$G(X),Y=$G(Y) Q:'$L(X)
  1.  I $L(Y) S X="    "_X F  Q:$L(X)>54  S X=X_" "
  1.  S X=X_" "_Y S:$E(X,1)'=" " X="    "_X D MES^XPDUTL(X) Q
  1. IND(X) ;   Indent Text
  1.  N I S X=$G(X) Q:'$L(X)  S X="    "_X D MES^XPDUTL(X) Q