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

ADE0602.m

Go to the documentation of this file. 
  1. ADE0602 ;IHS/HQT/MJL - DENTAL TABLE UPDATES [ 12/20/1999  2:19 PM ]
  1.  ;;6.0;ADE;**2**;NOVEMBER 1999
  1. CTL ;
  1.  K ^TMP("ADE697",$J)
  1.  D DASH,RSLT($J("",15)_"IHS DENTAL TABLE UPDATES")
  1.  D RSLT("ADA Code Changes")
  1.  F ADET=1:2 S ADEFROM=$T(ADAMODS+ADET) Q:$P(ADEFROM,";",3)="END"  S ADETO=$T(ADAMODS+(ADET+1)) D ADAMOD(ADEFROM,ADETO)
  1.  ; Changes made to 1351 so that 1351 is not restricted to a particular
  1.  ; op site
  1.  D RSLT("Update Data Entry Screens and Edits")
  1.  F ADET=1:1 S ADEX=$P($T(UPDEDITS+ADET),";",3) Q:ADEX="END"  D EDITUPD(ADEX)
  1.  ; Deactivates the edit codes for 1351
  1.  S ADEDIE="^ADEDIT(",ADEDR="1.4///N"
  1.  F ADEDA=14,17,19 S ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
  1.  ; Modify the DENTAL CODE EDIT GROUP to remove 1351
  1.  D RSLT("Dental Code Group Changes")
  1.  F ADET=1:2 S ADEFROM=$T(GRPMODS+ADET) Q:$P(ADEFROM,";",3)="END"  S ADETO=$T(GRPMODS+(ADET+1)) D GRPMOD(ADEFROM,ADETO)
  1.  D RSLT("Re-indexing Dental Edit File")
  1.  K ^ADEDIT("AC"),^ADEDIT("AD")
  1.  S DA=0,DIK="^ADEDIT(" F  S DA=$O(^ADEDIT(DA)) Q:'+DA  D IX^DIK
  1.  Q
  1.  ;
  1. EDITUPD(L) ;
  1.  N ADEJ,N,Y,ADEDR
  1.  F ADEJ=2:1:8 S N(ADEJ-1)=$P(L,U,ADEJ)
  1.  ;I $D(^ADEDIT("AD",N(1),N(2))) D RSLT("NOT ADDED: CODE EDIT EXISTS => "_N(1)_" TYPE "_N(2)) Q
  1.  I $D(^ADEDIT("AD",N(1),N(2))) S DA=$O(^ADEDIT("AD",N(1),N(2),0)),DIK="^ADEDIT(" D ^DIK
  1.  S ADEDR="1///"_N(2)_";3///"_N(3)_";4///"_N(4)_";2///"_N(5)_";2.4///"_N(6)_";6///"_N(7)
  1.  S Y=$$FILE("^ADEDIT(",N(1),ADEDR,9002007.9)
  1.  D RSLT($J("",5)_$S(Y<0:"Error: Update Failed",1:"Updated")_" : "_N(1))
  1.  Q
  1.  ;
  1. UPDEDITS ;
  1.  ;;^IH71^3^^1^IH71^X<20^W *7,"Patient must be 19 years old or younger"
  1.  ;;^IH72^3^^1^IH72^X<20^W *7,"Patient must be 19 years old or younger"
  1.  ;;END
  1.  ;
  1. ADAMODS ;
  1.  ;;FROM^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY
  1.  ;;TO^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY^^^n
  1.  ;;FROM^3300^PULPECTOMY/ENDO ACCESS PREP, PERM. TOOTH^522.9^15^1^ACCESS PREP
  1.  ;;TO^3300^PULPECTOMY/ENDO ACCESS PREP, PERM. TOOTH^522.9^15^1^ACCESS PREP^^T
  1.  ;;FROM^5850^TISSUE CONDITIONING, MAXILLARY^525.1^30^3^TISSUE CONDIT.^^^^
  1.  ;;TO^5850^TISSUE CONDITIONING, MAXILLARY^525.1^30^3^TISSUE CONDIT.^^^n^
  1.  ;;END
  1.  ;
  1. GRPMODS ;
  1.  ;;FROM^PERMANENT TOOTH PROCEDURES^
  1.  ;;TO^PERMANENT TOOTH PROCEDURES^1355|2140|2150|2160|2161|2385|2540|2740|2750|2790|2810|2950|2952|2954|2960|3310|3311|3320|3321|3330|3331|3346|3347|3348|3351|3352|3353|3410|3421|3425|3430|3470|3950|3960|3961
  1.  ;;FROM^PRIMARY TOOTH PROCEDURES^
  1.  ;;TO^PRIMARY TOOTH PROCEDURES^2110|2120|2121|2130|2131|2380|2381|2382|2930|2932|3230
  1.  ;;END
  1.  ;
  1. DIE(DIE,DA,DR)     ;EP
  1.  K Y
  1.  LOCK +(@(DIE_DA_")")):10
  1.  E  D RSLT($J("",5)_"ERROR: "_"Entry '"_DIE_DA_"' Is locked -- unable to edit.") Q "ERROR"
  1.  D ^DIE
  1.  LOCK -(@(DIE_DA_")"))
  1.  Q "OK"
  1.  ;
  1. FILE(DIC,X,ADEDR,DLAYGO) ;EP
  1.  K DD,DO
  1.  S:ADEDR]"" DIC("DR")=ADEDR
  1.  S DIC(0)="L"
  1.  D FILE^DICN
  1.  Q Y
  1.  ;
  1. RSLT(X) ;EP
  1.  S ^TMP("ADE697",$J,0)=$G(^TMP("ADE697",$J,0))+1,^(^(0))=X W:'$D(ZTQUEUED) !,X Q
  1.  W:'$D(ZTQUEUED) !,X
  1.  Q
  1.  ;
  1. DASH D RSLT(""),RSLT($TR($J("",$S($G(IOM):IOM-10,1:70))," ","-")),RSLT("")
  1.  Q
  1.  ;
  1. ADAMOD(ADEFROM,ADETO)        ;EP
  1.  ;ADEFROM and ADETO are in the form:
  1.  ;  CODE^DESC^DX^EST MIN^
  1.  ;  LVL^SYN^EXC^INACT^NOOPSITE^MN
  1.  ;
  1.  N ADEJ,ADE,ADEDA,ADEDIE,ADEDR,ADEY
  1.  F ADEJ=2:1:11 S ADE("FROM",ADEJ-1)=$P(ADEFROM,U,ADEJ),ADE("TO",ADEJ-1)=$P(ADETO,U,ADEJ)
  1.  D RSLT($J("",15)_ADE("FROM",1)_"---->"_ADE("TO",1))
  1.  S ADEDA=$O(^AUTTADA("B",ADE("FROM",1),0))
  1.  ;FHL 09/09/98 I 'ADEDA B  S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
  1.  I 'ADEDA S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
  1.  I 'ADEDA D  Q
  1.  . D RSLT(ADE("FROM",1)_" NOT PRESENT, "_ADE("TO",1)_" WILL BE ADDED.")
  1.  . D ADAADD(U_$P(ADETO,U,2,11))
  1.  . Q
  1.  ; Modify ADA Code
  1.  S ADEDIE="^AUTTADA("
  1.  S ADEDR=".01////"_ADE("TO",1)
  1.  F ADEJ=2:1:9 S ADEDR=ADEDR_";.0"_ADEJ_"///"_ADE("TO",ADEJ)
  1.  S ADEDR=ADEDR_";8801///"_ADE("TO",10)
  1.  S ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
  1.  I ADEY["ERR" D RSLT("ERROR: EDIT ADA CODE FAILED => "_ADE("FROM",1)) Q
  1.  Q
  1.  ;
  1. ADAADD(L) ;
  1.  N ADEJ,N,Y,ADEDR
  1.  F ADEJ=2:1:11 S N(ADEJ-1)=$P(L,U,ADEJ)
  1.  I $D(^AUTTADA("B",N(1))) D RSLT("NOT ADDED: ADA CODE EXISTS => "_N(1)) Q
  1.  S %=$O(^ICD9("AB",N(3),0))
  1.  I '% D RSLT("NOT ADDED: ICD DIAGNOSIS "_N(3)_" DOES NOT EXIST => "_N(1)) Q
  1.  S ADEDR=".02///"_N(2)
  1.  S:N(4)=0 N(4)=""
  1.  F ADEJ=3:1:9 S ADEDR=ADEDR_";.0"_ADEJ_"///"_N(ADEJ)
  1.  S ADEDR=ADEDR_";8801///"_N(10)
  1.  S Y=$$FILE("^AUTTADA(",N(1),ADEDR,9999999.31)
  1.  D RSLT($J("",5)_$S(Y<0:"Error: Update Failed",1:"Updated")_" : "_N(1))
  1.  Q
  1.  ;
  1. GRPMOD(ADEFROM,ADETO)        ;
  1.  ;
  1.  ;ADEFROM and ADETO are in the form:
  1.  ;  NAME^CODES
  1.  ;
  1.  N ADEJ,ADE,ADEDA,ADEDIE,ADEDR,ADEY
  1.  F ADEJ=2:1:4 S ADE("FROM",ADEJ-1)=$P(ADEFROM,U,ADEJ),ADE("TO",ADEJ-1)=$P(ADETO,U,ADEJ)
  1.  D RSLT($J("",15)_ADE("FROM",1)_"---->Converted")
  1.  S ADEDA=$O(^ADEDIT("GRP","B",ADE("FROM",1),0))
  1.  Q:'ADEDA
  1.  Q:'$D(^ADEDIT("GRP",ADEDA,0))
  1.  S ADEDIE="^ADEDIT(""GRP"","
  1.  S ADEDR=""
  1.  S ADEDR=ADEDR_"1///"_ADE("TO",2)
  1.  I ADE("TO",3)]"" S ADEDR=ADEDR_";4///"_ADE("TO",3)
  1.  S ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
  1.  I ADEY["ERR" D RSLT("ERROR: EDIT GROUP FAILED => "_ADE("FROM",1)) Q
  1.  Q
  1.  ;