ADE0603 ;IHS/HQT/MJL - DENTAL TABLE UPDATES [ 02/08/2000 3:03 PM ]
;;6.0;ADE;**3**;FEBRUARY 2000
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)
Q
;
ADAMODS ;
;;FROM^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY^^^n
;;TO^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY^^^@
;;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))
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
ADE0603 ;IHS/HQT/MJL - DENTAL TABLE UPDATES [ 02/08/2000 3:03 PM ]
+1 ;;6.0;ADE;**3**;FEBRUARY 2000
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 QUIT
+6 ;
ADAMODS ;
+1 ;;FROM^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY^^^n
+2 ;;TO^3220^VITAL PULPOTOMY^2834^18^3^VIT PULPOTOMY^^^@
+3 ;;END
+4 ;
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 IF 'ADEDA
SET ADEDA=$ORDER(^AUTTADA("B",ADE("TO",1),0))
+10 IF 'ADEDA
Begin DoDot:1
+11 DO RSLT(ADE("FROM",1)_" NOT PRESENT, "_ADE("TO",1)_" WILL BE ADDED.")
+12 DO ADAADD(U_$PIECE(ADETO,U,2,11))
+13 QUIT
End DoDot:1
QUIT
+14 ; Modify ADA Code
+15 SET ADEDIE="^AUTTADA("
+16 SET ADEDR=".01////"_ADE("TO",1)
+17 FOR ADEJ=2:1:9
SET ADEDR=ADEDR_";.0"_ADEJ_"///"_ADE("TO",ADEJ)
+18 SET ADEDR=ADEDR_";8801///"_ADE("TO",10)
+19 SET ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
+20 IF ADEY["ERR"
DO RSLT("ERROR: EDIT ADA CODE FAILED => "_ADE("FROM",1))
QUIT
+21 QUIT
+22 ;
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
