ADE0602 ;IHS/HQT/MJL - DENTAL TABLE UPDATES [ 12/20/1999 2:19 PM ]
;;6.0;ADE;**2**;NOVEMBER 1999
CTL ;
K ^TMP("ADE697",$J)
D DASH,RSLT($J("",15)_"IHS DENTAL TABLE UPDATES")
D RSLT("ADA Code Changes")
F ADET=1:2 S ADEFROM=$T(ADAMODS+ADET) Q:$P(ADEFROM,";",3)="END" S ADETO=$T(ADAMODS+(ADET+1)) D ADAMOD(ADEFROM,ADETO)
; Changes made to 1351 so that 1351 is not restricted to a particular
; op site
D RSLT("Update Data Entry Screens and Edits")
F ADET=1:1 S ADEX=$P($T(UPDEDITS+ADET),";",3) Q:ADEX="END" D EDITUPD(ADEX)
; Deactivates the edit codes for 1351
S ADEDIE="^ADEDIT(",ADEDR="1.4///N"
F ADEDA=14,17,19 S ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
; Modify the DENTAL CODE EDIT GROUP to remove 1351
D RSLT("Dental Code Group Changes")
F ADET=1:2 S ADEFROM=$T(GRPMODS+ADET) Q:$P(ADEFROM,";",3)="END" S ADETO=$T(GRPMODS+(ADET+1)) D GRPMOD(ADEFROM,ADETO)
D RSLT("Re-indexing Dental Edit File")
K ^ADEDIT("AC"),^ADEDIT("AD")
S DA=0,DIK="^ADEDIT(" F S DA=$O(^ADEDIT(DA)) Q:'+DA D IX^DIK
Q
;
EDITUPD(L) ;
N ADEJ,N,Y,ADEDR
F ADEJ=2:1:8 S N(ADEJ-1)=$P(L,U,ADEJ)
;I $D(^ADEDIT("AD",N(1),N(2))) D RSLT("NOT ADDED: CODE EDIT EXISTS => "_N(1)_" TYPE "_N(2)) Q
I $D(^ADEDIT("AD",N(1),N(2))) S DA=$O(^ADEDIT("AD",N(1),N(2),0)),DIK="^ADEDIT(" D ^DIK
S ADEDR="1///"_N(2)_";3///"_N(3)_";4///"_N(4)_";2///"_N(5)_";2.4///"_N(6)_";6///"_N(7)
S Y=$$FILE("^ADEDIT(",N(1),ADEDR,9002007.9)
D RSLT($J("",5)_$S(Y<0:"Error: Update Failed",1:"Updated")_" : "_N(1))
Q
;
UPDEDITS ;
;;^IH71^3^^1^IH71^X<20^W *7,"Patient must be 19 years old or younger"
;;^IH72^3^^1^IH72^X<20^W *7,"Patient must be 19 years old or younger"
;;END
;
ADAMODS ;
;;FROM^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY
;;TO^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY^^^n
;;FROM^3300^PULPECTOMY/ENDO ACCESS PREP, PERM. TOOTH^522.9^15^1^ACCESS PREP
;;TO^3300^PULPECTOMY/ENDO ACCESS PREP, PERM. TOOTH^522.9^15^1^ACCESS PREP^^T
;;FROM^5850^TISSUE CONDITIONING, MAXILLARY^525.1^30^3^TISSUE CONDIT.^^^^
;;TO^5850^TISSUE CONDITIONING, MAXILLARY^525.1^30^3^TISSUE CONDIT.^^^n^
;;END
;
GRPMODS ;
;;FROM^PERMANENT TOOTH PROCEDURES^
;;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
;;FROM^PRIMARY TOOTH PROCEDURES^
;;TO^PRIMARY TOOTH PROCEDURES^2110|2120|2121|2130|2131|2380|2381|2382|2930|2932|3230
;;END
;
DIE(DIE,DA,DR) ;EP
K Y
LOCK +(@(DIE_DA_")")):10
E D RSLT($J("",5)_"ERROR: "_"Entry '"_DIE_DA_"' Is locked -- unable to edit.") Q "ERROR"
D ^DIE
LOCK -(@(DIE_DA_")"))
Q "OK"
;
FILE(DIC,X,ADEDR,DLAYGO) ;EP
K DD,DO
S:ADEDR]"" DIC("DR")=ADEDR
S DIC(0)="L"
D FILE^DICN
Q Y
;
RSLT(X) ;EP
S ^TMP("ADE697",$J,0)=$G(^TMP("ADE697",$J,0))+1,^(^(0))=X W:'$D(ZTQUEUED) !,X Q
W:'$D(ZTQUEUED) !,X
Q
;
DASH D RSLT(""),RSLT($TR($J("",$S($G(IOM):IOM-10,1:70))," ","-")),RSLT("")
Q
;
ADAMOD(ADEFROM,ADETO) ;EP
;ADEFROM and ADETO are in the form:
; CODE^DESC^DX^EST MIN^
; LVL^SYN^EXC^INACT^NOOPSITE^MN
;
N ADEJ,ADE,ADEDA,ADEDIE,ADEDR,ADEY
F ADEJ=2:1:11 S ADE("FROM",ADEJ-1)=$P(ADEFROM,U,ADEJ),ADE("TO",ADEJ-1)=$P(ADETO,U,ADEJ)
D RSLT($J("",15)_ADE("FROM",1)_"---->"_ADE("TO",1))
S ADEDA=$O(^AUTTADA("B",ADE("FROM",1),0))
;FHL 09/09/98 I 'ADEDA B S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
I 'ADEDA S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
I 'ADEDA D Q
. D RSLT(ADE("FROM",1)_" NOT PRESENT, "_ADE("TO",1)_" WILL BE ADDED.")
. D ADAADD(U_$P(ADETO,U,2,11))
. Q
; Modify ADA Code
S ADEDIE="^AUTTADA("
S ADEDR=".01////"_ADE("TO",1)
F ADEJ=2:1:9 S ADEDR=ADEDR_";.0"_ADEJ_"///"_ADE("TO",ADEJ)
S ADEDR=ADEDR_";8801///"_ADE("TO",10)
S ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
I ADEY["ERR" D RSLT("ERROR: EDIT ADA CODE FAILED => "_ADE("FROM",1)) Q
Q
;
ADAADD(L) ;
N ADEJ,N,Y,ADEDR
F ADEJ=2:1:11 S N(ADEJ-1)=$P(L,U,ADEJ)
I $D(^AUTTADA("B",N(1))) D RSLT("NOT ADDED: ADA CODE EXISTS => "_N(1)) Q
S %=$O(^ICD9("AB",N(3),0))
I '% D RSLT("NOT ADDED: ICD DIAGNOSIS "_N(3)_" DOES NOT EXIST => "_N(1)) Q
S ADEDR=".02///"_N(2)
S:N(4)=0 N(4)=""
F ADEJ=3:1:9 S ADEDR=ADEDR_";.0"_ADEJ_"///"_N(ADEJ)
S ADEDR=ADEDR_";8801///"_N(10)
S Y=$$FILE("^AUTTADA(",N(1),ADEDR,9999999.31)
D RSLT($J("",5)_$S(Y<0:"Error: Update Failed",1:"Updated")_" : "_N(1))
Q
;
GRPMOD(ADEFROM,ADETO) ;
;
;ADEFROM and ADETO are in the form:
; NAME^CODES
;
N ADEJ,ADE,ADEDA,ADEDIE,ADEDR,ADEY
F ADEJ=2:1:4 S ADE("FROM",ADEJ-1)=$P(ADEFROM,U,ADEJ),ADE("TO",ADEJ-1)=$P(ADETO,U,ADEJ)
D RSLT($J("",15)_ADE("FROM",1)_"---->Converted")
S ADEDA=$O(^ADEDIT("GRP","B",ADE("FROM",1),0))
Q:'ADEDA
Q:'$D(^ADEDIT("GRP",ADEDA,0))
S ADEDIE="^ADEDIT(""GRP"","
S ADEDR=""
S ADEDR=ADEDR_"1///"_ADE("TO",2)
I ADE("TO",3)]"" S ADEDR=ADEDR_";4///"_ADE("TO",3)
S ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
I ADEY["ERR" D RSLT("ERROR: EDIT GROUP FAILED => "_ADE("FROM",1)) Q
Q
;
ADE0602 ;IHS/HQT/MJL - DENTAL TABLE UPDATES [ 12/20/1999 2:19 PM ]
+1 ;;6.0;ADE;**2**;NOVEMBER 1999
CTL ;
+1 KILL ^TMP("ADE697",$JOB)
+2 DO DASH
DO RSLT($JUSTIFY("",15)_"IHS DENTAL TABLE UPDATES")
+3 DO RSLT("ADA Code Changes")
+4 FOR ADET=1:2
SET ADEFROM=$TEXT(ADAMODS+ADET)
IF $PIECE(ADEFROM,";",3)="END"
QUIT
SET ADETO=$TEXT(ADAMODS+(ADET+1))
DO ADAMOD(ADEFROM,ADETO)
+5 ; Changes made to 1351 so that 1351 is not restricted to a particular
+6 ; op site
+7 DO RSLT("Update Data Entry Screens and Edits")
+8 FOR ADET=1:1
SET ADEX=$PIECE($TEXT(UPDEDITS+ADET),";",3)
IF ADEX="END"
QUIT
DO EDITUPD(ADEX)
+9 ; Deactivates the edit codes for 1351
+10 SET ADEDIE="^ADEDIT("
SET ADEDR="1.4///N"
+11 FOR ADEDA=14,17,19
SET ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
+12 ; Modify the DENTAL CODE EDIT GROUP to remove 1351
+13 DO RSLT("Dental Code Group Changes")
+14 FOR ADET=1:2
SET ADEFROM=$TEXT(GRPMODS+ADET)
IF $PIECE(ADEFROM,";",3)="END"
QUIT
SET ADETO=$TEXT(GRPMODS+(ADET+1))
DO GRPMOD(ADEFROM,ADETO)
+15 DO RSLT("Re-indexing Dental Edit File")
+16 KILL ^ADEDIT("AC"),^ADEDIT("AD")
+17 SET DA=0
SET DIK="^ADEDIT("
FOR
SET DA=$ORDER(^ADEDIT(DA))
IF '+DA
QUIT
DO IX^DIK
+18 QUIT
+19 ;
EDITUPD(L) ;
+1 NEW ADEJ,N,Y,ADEDR
+2 FOR ADEJ=2:1:8
SET N(ADEJ-1)=$PIECE(L,U,ADEJ)
+3 ;I $D(^ADEDIT("AD",N(1),N(2))) D RSLT("NOT ADDED: CODE EDIT EXISTS => "_N(1)_" TYPE "_N(2)) Q
+4 IF $DATA(^ADEDIT("AD",N(1),N(2)))
SET DA=$ORDER(^ADEDIT("AD",N(1),N(2),0))
SET DIK="^ADEDIT("
DO ^DIK
+5 SET ADEDR="1///"_N(2)_";3///"_N(3)_";4///"_N(4)_";2///"_N(5)_";2.4///"_N(6)_";6///"_N(7)
+6 SET Y=$$FILE("^ADEDIT(",N(1),ADEDR,9002007.9)
+7 DO RSLT($JUSTIFY("",5)_$SELECT(Y<0:"Error: Update Failed",1:"Updated")_" : "_N(1))
+8 QUIT
+9 ;
UPDEDITS ;
+1 ;;^IH71^3^^1^IH71^X<20^W *7,"Patient must be 19 years old or younger"
+2 ;;^IH72^3^^1^IH72^X<20^W *7,"Patient must be 19 years old or younger"
+3 ;;END
+4 ;
ADAMODS ;
+1 ;;FROM^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY
+2 ;;TO^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY^^^n
+3 ;;FROM^3300^PULPECTOMY/ENDO ACCESS PREP, PERM. TOOTH^522.9^15^1^ACCESS PREP
+4 ;;TO^3300^PULPECTOMY/ENDO ACCESS PREP, PERM. TOOTH^522.9^15^1^ACCESS PREP^^T
+5 ;;FROM^5850^TISSUE CONDITIONING, MAXILLARY^525.1^30^3^TISSUE CONDIT.^^^^
+6 ;;TO^5850^TISSUE CONDITIONING, MAXILLARY^525.1^30^3^TISSUE CONDIT.^^^n^
+7 ;;END
+8 ;
GRPMODS ;
+1 ;;FROM^PERMANENT TOOTH PROCEDURES^
+2 ;;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
+3 ;;FROM^PRIMARY TOOTH PROCEDURES^
+4 ;;TO^PRIMARY TOOTH PROCEDURES^2110|2120|2121|2130|2131|2380|2381|2382|2930|2932|3230
+5 ;;END
+6 ;
DIE(DIE,DA,DR) ;EP
+1 KILL Y
+2 LOCK +(@(DIE_DA_")")):10
+3 IF '$TEST
DO RSLT($JUSTIFY("",5)_"ERROR: "_"Entry '"_DIE_DA_"' Is locked -- unable to edit.")
QUIT "ERROR"
+4 DO ^DIE
+5 LOCK -(@(DIE_DA_")"))
+6 QUIT "OK"
+7 ;
FILE(DIC,X,ADEDR,DLAYGO) ;EP
+1 KILL DD,DO
+2 IF ADEDR]""
SET DIC("DR")=ADEDR
+3 SET DIC(0)="L"
+4 DO FILE^DICN
+5 QUIT Y
+6 ;
RSLT(X) ;EP
+1 SET ^TMP("ADE697",$JOB,0)=$GET(^TMP("ADE697",$JOB,0))+1
SET ^(^(0))=X
IF '$DATA(ZTQUEUED)
WRITE !,X
QUIT
+2 IF '$DATA(ZTQUEUED)
WRITE !,X
+3 QUIT
+4 ;
DASH DO RSLT("")
DO RSLT($TRANSLATE($JUSTIFY("",$SELECT($GET(IOM):IOM-10,1:70))," ","-"))
DO RSLT("")
+1 QUIT
+2 ;
ADAMOD(ADEFROM,ADETO) ;EP
+1 ;ADEFROM and ADETO are in the form:
+2 ; CODE^DESC^DX^EST MIN^
+3 ; LVL^SYN^EXC^INACT^NOOPSITE^MN
+4 ;
+5 NEW ADEJ,ADE,ADEDA,ADEDIE,ADEDR,ADEY
+6 FOR ADEJ=2:1:11
SET ADE("FROM",ADEJ-1)=$PIECE(ADEFROM,U,ADEJ)
SET ADE("TO",ADEJ-1)=$PIECE(ADETO,U,ADEJ)
+7 DO RSLT($JUSTIFY("",15)_ADE("FROM",1)_"---->"_ADE("TO",1))
+8 SET ADEDA=$ORDER(^AUTTADA("B",ADE("FROM",1),0))
+9 ;FHL 09/09/98 I 'ADEDA B S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
+10 IF 'ADEDA
SET ADEDA=$ORDER(^AUTTADA("B",ADE("TO",1),0))
+11 IF 'ADEDA
Begin DoDot:1
+12 DO RSLT(ADE("FROM",1)_" NOT PRESENT, "_ADE("TO",1)_" WILL BE ADDED.")
+13 DO ADAADD(U_$PIECE(ADETO,U,2,11))
+14 QUIT
End DoDot:1
QUIT
+15 ; Modify ADA Code
+16 SET ADEDIE="^AUTTADA("
+17 SET ADEDR=".01////"_ADE("TO",1)
+18 FOR ADEJ=2:1:9
SET ADEDR=ADEDR_";.0"_ADEJ_"///"_ADE("TO",ADEJ)
+19 SET ADEDR=ADEDR_";8801///"_ADE("TO",10)
+20 SET ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
+21 IF ADEY["ERR"
DO RSLT("ERROR: EDIT ADA CODE FAILED => "_ADE("FROM",1))
QUIT
+22 QUIT
+23 ;
ADAADD(L) ;
+1 NEW ADEJ,N,Y,ADEDR
+2 FOR ADEJ=2:1:11
SET N(ADEJ-1)=$PIECE(L,U,ADEJ)
+3 IF $DATA(^AUTTADA("B",N(1)))
DO RSLT("NOT ADDED: ADA CODE EXISTS => "_N(1))
QUIT
+4 SET %=$ORDER(^ICD9("AB",N(3),0))
+5 IF '%
DO RSLT("NOT ADDED: ICD DIAGNOSIS "_N(3)_" DOES NOT EXIST => "_N(1))
QUIT
+6 SET ADEDR=".02///"_N(2)
+7 IF N(4)=0
SET N(4)=""
+8 FOR ADEJ=3:1:9
SET ADEDR=ADEDR_";.0"_ADEJ_"///"_N(ADEJ)
+9 SET ADEDR=ADEDR_";8801///"_N(10)
+10 SET Y=$$FILE("^AUTTADA(",N(1),ADEDR,9999999.31)
+11 DO RSLT($JUSTIFY("",5)_$SELECT(Y<0:"Error: Update Failed",1:"Updated")_" : "_N(1))
+12 QUIT
+13 ;
GRPMOD(ADEFROM,ADETO) ;
+1 ;
+2 ;ADEFROM and ADETO are in the form:
+3 ; NAME^CODES
+4 ;
+5 NEW ADEJ,ADE,ADEDA,ADEDIE,ADEDR,ADEY
+6 FOR ADEJ=2:1:4
SET ADE("FROM",ADEJ-1)=$PIECE(ADEFROM,U,ADEJ)
SET ADE("TO",ADEJ-1)=$PIECE(ADETO,U,ADEJ)
+7 DO RSLT($JUSTIFY("",15)_ADE("FROM",1)_"---->Converted")
+8 SET ADEDA=$ORDER(^ADEDIT("GRP","B",ADE("FROM",1),0))
+9 IF 'ADEDA
QUIT
+10 IF '$DATA(^ADEDIT("GRP",ADEDA,0))
QUIT
+11 SET ADEDIE="^ADEDIT(""GRP"","
+12 SET ADEDR=""
+13 SET ADEDR=ADEDR_"1///"_ADE("TO",2)
+14 IF ADE("TO",3)]""
SET ADEDR=ADEDR_";4///"_ADE("TO",3)
+15 SET ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
+16 IF ADEY["ERR"
DO RSLT("ERROR: EDIT GROUP FAILED => "_ADE("FROM",1))
QUIT
+17 QUIT
+18 ;
