ADE697B ;IHS/HQW/MJL - DENTAL TABLE UPDATES; [ 03/24/1999 8:35 AM ]
;;6.0;ADE;;APRIL 1999
;
;
OPSITE ;EP Dental Operative Site Changes
;
N ADET,ADEFROM,ADETO,ADEJ,ADELINE,ADERTN
Q:'$P($G(^ADEOPS(0)),U,3)
D RSLT^ADE697A("Dental Operative Site Changes")
F ADEJ=1:1:1 S ADERTN="^ADE6O"_ADEJ D
. F ADET=1:2 S ADELINE="S ADEFROM=$T(OPMOD+"_ADET_ADERTN_")" X ADELINE Q:$P(ADEFROM,";",3)="END" S ADELINE="S ADETO=$T(OPMOD+"_(ADET+1)_ADERTN_")" X ADELINE D OPMOD(ADEFROM,ADETO)
. Q
Q
;
OPMOD(ADEFROM,ADETO) ;
;
;ADEFROM and ADETO are in the form:
; ANATOMIC NAME^SYNONYM^MNEMONIC
;
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^ADE697A($J("",15)_ADE("FROM",3)_"---->"_ADE("TO",3))
S ADEDA=$O(^ADEOPS("B",ADE("FROM",3),0))
Q:'ADEDA
Q:'$D(^ADEOPS(ADEDA,0))
S ADEDIE="^ADEOPS("
S ADEDR=".01///"_ADE("TO",1)
S ADEDR=ADEDR_";8802///"_ADE("TO",2)
S ADEDR=ADEDR_";8801///"_ADE("TO",3)
S ADEY=$$DIE^ADE697A(ADEDIE,ADEDA,ADEDR)
I ADEY["ERR" D RSLT^ADE697A("ERROR: EDIT OPSITE FAILED => "_ADE("FROM",1)) Q
Q
;
GROUP ;EP Code Edit Group Mods
;
N ADET,ADEFROM,ADETO,ADEJ,ADELINE,ADERTN
Q:'$P($G(^ADEDIT("GRP",0)),U,3)
D RSLT^ADE697A("Dental Code Group Changes")
D RSLT^ADE697A(" Converting to Primary Letter codes and Bar delimiters")
F ADEJ=1:1:1 S ADERTN="^ADE6G"_ADEJ D
. F ADET=1:2 S ADELINE="S ADEFROM=$T(OPMOD+"_ADET_ADERTN_")" X ADELINE Q:$P(ADEFROM,";",3)="END" S ADELINE="S ADETO=$T(OPMOD+"_(ADET+1)_ADERTN_")" X ADELINE D GRPMOD(ADEFROM,ADETO)
. Q
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^ADE697A($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^ADE697A(ADEDIE,ADEDA,ADEDR)
I ADEY["ERR" D RSLT^ADE697A("ERROR: EDIT GROUP FAILED => "_ADE("FROM",1)) Q
Q
;
EDIT ;EP
;Disable Sealant & prophy age limits, prophy and perio surgery edits
N ADEDJ,ADEDA,ADEDIE,ADEDR,ADEY,DA
D RSLT^ADE697A(" Modifying DENTAL EDIT entries.")
S ADEDIE="^ADEDIT("
S ADEDR="1.4///N"
F ADEDA=15,16,19,10,11,14,17,18 D
. S ADEY=$$DIE^ADE697A(ADEDIE,ADEDA,ADEDR)
;
N T,L,ADEJ
D RSLT^ADE697A("Add New Data Entry Screens and Edits")
F ADEJ=1:1:1 S ADERTN="^ADE6E"_ADEJ D
. F T=1:1 S ADELINE="S L=$T(ADDEDIT+T"_ADERTN_")" X ADELINE S L=$P(L,";",3) Q:L="END" D EDITADD(L)
. Q
;Re-index file
RENDX D RSLT^ADE697A("Re-indexing Dental Edit File")
K ^ADEDIT("AC"),^ADEDIT("AD")
S DA=0,DIK="^ADEDIT(" F S DA=$O(^ADEDIT(DA)) Q:'+DA D
. D IX^DIK
Q
;
EDITADD(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^ADE697A("NOT ADDED: CODE EDIT EXISTS => "_N(1)_" TYPE "_N(2)) Q
S ADEDR="1///"_N(2)
S ADEDR=ADEDR_";3///"_N(3)
S ADEDR=ADEDR_";4///"_N(4)
S ADEDR=ADEDR_";2///"_N(5)
S ADEDR=ADEDR_";2.4///"_N(6)
S ADEDR=ADEDR_";6///"_N(7)
S Y=$$FILE^ADE697A("^ADEDIT(",N(1),ADEDR,9002007.9)
D ADDFAIL^ADE697A(N(1)):Y<0,ADDOK^ADE697A(N(1)):Y>0
Q
ADE697B ;IHS/HQW/MJL - DENTAL TABLE UPDATES; [ 03/24/1999 8:35 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;
+3 ;
OPSITE ;EP Dental Operative Site Changes
+1 ;
+2 NEW ADET,ADEFROM,ADETO,ADEJ,ADELINE,ADERTN
+3 IF '$PIECE($GET(^ADEOPS(0)),U,3)
QUIT
+4 DO RSLT^ADE697A("Dental Operative Site Changes")
+5 FOR ADEJ=1:1:1
SET ADERTN="^ADE6O"_ADEJ
Begin DoDot:1
+6 FOR ADET=1:2
SET ADELINE="S ADEFROM=$T(OPMOD+"_ADET_ADERTN_")"
XECUTE ADELINE
IF $PIECE(ADEFROM,";",3)="END"
QUIT
SET ADELINE="S ADETO=$T(OPMOD+"_(ADET+1)_ADERTN_")"
XECUTE ADELINE
DO OPMOD(ADEFROM,ADETO)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
OPMOD(ADEFROM,ADETO) ;
+1 ;
+2 ;ADEFROM and ADETO are in the form:
+3 ; ANATOMIC NAME^SYNONYM^MNEMONIC
+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^ADE697A($JUSTIFY("",15)_ADE("FROM",3)_"---->"_ADE("TO",3))
+8 SET ADEDA=$ORDER(^ADEOPS("B",ADE("FROM",3),0))
+9 IF 'ADEDA
QUIT
+10 IF '$DATA(^ADEOPS(ADEDA,0))
QUIT
+11 SET ADEDIE="^ADEOPS("
+12 SET ADEDR=".01///"_ADE("TO",1)
+13 SET ADEDR=ADEDR_";8802///"_ADE("TO",2)
+14 SET ADEDR=ADEDR_";8801///"_ADE("TO",3)
+15 SET ADEY=$$DIE^ADE697A(ADEDIE,ADEDA,ADEDR)
+16 IF ADEY["ERR"
DO RSLT^ADE697A("ERROR: EDIT OPSITE FAILED => "_ADE("FROM",1))
QUIT
+17 QUIT
+18 ;
GROUP ;EP Code Edit Group Mods
+1 ;
+2 NEW ADET,ADEFROM,ADETO,ADEJ,ADELINE,ADERTN
+3 IF '$PIECE($GET(^ADEDIT("GRP",0)),U,3)
QUIT
+4 DO RSLT^ADE697A("Dental Code Group Changes")
+5 DO RSLT^ADE697A(" Converting to Primary Letter codes and Bar delimiters")
+6 FOR ADEJ=1:1:1
SET ADERTN="^ADE6G"_ADEJ
Begin DoDot:1
+7 FOR ADET=1:2
SET ADELINE="S ADEFROM=$T(OPMOD+"_ADET_ADERTN_")"
XECUTE ADELINE
IF $PIECE(ADEFROM,";",3)="END"
QUIT
SET ADELINE="S ADETO=$T(OPMOD+"_(ADET+1)_ADERTN_")"
XECUTE ADELINE
DO GRPMOD(ADEFROM,ADETO)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
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^ADE697A($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^ADE697A(ADEDIE,ADEDA,ADEDR)
+16 IF ADEY["ERR"
DO RSLT^ADE697A("ERROR: EDIT GROUP FAILED => "_ADE("FROM",1))
QUIT
+17 QUIT
+18 ;
EDIT ;EP
+1 ;Disable Sealant & prophy age limits, prophy and perio surgery edits
+2 NEW ADEDJ,ADEDA,ADEDIE,ADEDR,ADEY,DA
+3 DO RSLT^ADE697A(" Modifying DENTAL EDIT entries.")
+4 SET ADEDIE="^ADEDIT("
+5 SET ADEDR="1.4///N"
+6 FOR ADEDA=15,16,19,10,11,14,17,18
Begin DoDot:1
+7 SET ADEY=$$DIE^ADE697A(ADEDIE,ADEDA,ADEDR)
End DoDot:1
+8 ;
+9 NEW T,L,ADEJ
+10 DO RSLT^ADE697A("Add New Data Entry Screens and Edits")
+11 FOR ADEJ=1:1:1
SET ADERTN="^ADE6E"_ADEJ
Begin DoDot:1
+12 FOR T=1:1
SET ADELINE="S L=$T(ADDEDIT+T"_ADERTN_")"
XECUTE ADELINE
SET L=$PIECE(L,";",3)
IF L="END"
QUIT
DO EDITADD(L)
+13 QUIT
End DoDot:1
+14 ;Re-index file
RENDX DO RSLT^ADE697A("Re-indexing Dental Edit File")
+1 KILL ^ADEDIT("AC"),^ADEDIT("AD")
+2 SET DA=0
SET DIK="^ADEDIT("
FOR
SET DA=$ORDER(^ADEDIT(DA))
IF '+DA
QUIT
Begin DoDot:1
+3 DO IX^DIK
End DoDot:1
+4 QUIT
+5 ;
EDITADD(L) ;
+1 NEW ADEJ,N,Y,ADEDR
+2 FOR ADEJ=2:1:8
SET N(ADEJ-1)=$PIECE(L,U,ADEJ)
+3 IF $DATA(^ADEDIT("AD",N(1),N(2)))
DO RSLT^ADE697A("NOT ADDED: CODE EDIT EXISTS => "_N(1)_" TYPE "_N(2))
QUIT
+4 SET ADEDR="1///"_N(2)
+5 SET ADEDR=ADEDR_";3///"_N(3)
+6 SET ADEDR=ADEDR_";4///"_N(4)
+7 SET ADEDR=ADEDR_";2///"_N(5)
+8 SET ADEDR=ADEDR_";2.4///"_N(6)
+9 SET ADEDR=ADEDR_";6///"_N(7)
+10 SET Y=$$FILE^ADE697A("^ADEDIT(",N(1),ADEDR,9002007.9)
+11 IF Y<0
DO ADDFAIL^ADE697A(N(1))
IF Y>0
DO ADDOK^ADE697A(N(1))
+12 QUIT
