Routine: ADE0603

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)

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

DASH D RSLT(""),RSLT($TR($J("",$S($G(IOM):IOM-10,1:70))," ","-")),RSLT("")

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

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))

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

ADE0603.m