ADECD4 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
;;6.0;ADE;**12**;MAR 25, 1999
S U="^"
D ADA
D ^ADECD44 ;ADA CODE EDIT GROUPS
D ^ADECD45 ;DENTAL EDITS
Q
;
ADA ;
;
S ADEFILE=9999999.31,ADEWPFLD=1101,ADEIENST="?+1,",ADECNT=0,ADEDONE=0,ADEMOD=0
;Copy ^AUTTADA to ^ADEOCD4 to backup ADA Codes before the update
I '$D(^ADEOCD4) S %X="^AUTTADA(",%Y="^ADEOCD4(" D %XY^%RCR K %X,%Y
S DIK="^AUTTADA(" D IXALL^DIK K DIK
;Update ADA codes with CDT4 Update
F ADERN=1:1:3 D ADA1(ADERN) Q:ADEDONE
D ADAUPD
;Deactivated Codes
D NOW^%DTC S ADETDT=X
F ADEADA="0501","2110","2120","2130","2131","2336","2337","2380","2381","2382","2385" D DEACT(ADEADA)
F ADEADA="2386","2387","2388","4220","6519","6520","6530","6543","6544","7110","7120" D DEACT(ADEADA)
F ADEADA="7130","7420","7430","7431","7480" D DEACT(ADEADA)
D KILL
Q
;
DEACT(ADEADA) ;Deactivate Code
S DIC=ADEFILE,DIC(0)="X",X=ADEADA
D ^DIC
I Y>0 D
. S DIE=ADEFILE,DA=+Y,DR=".08////"_ADETDT
. D ^DIE
. Q
Q
;
ADA1(ADERN) ;
S ADERTN="ADECD4"_ADERN
F ADERLN=4:1 S X=$T(+ADERLN^@ADERTN) Q:X="" D Q:ADEDONE
.S X=$P(X,";",3,$L(X,";")) Q:X=""
.S ADEID=$P(X,U) I ADEID="***END***" S ADEDONE=1 Q
.I ADEID="CODE" D:ADECNT ADAUPD S ADECODE=$P(X,U,2),ADEDESC=$P(X,U,3),ADECNT=ADECNT+1,ADEUSE=0,ADETXT=0,(ADELEV,ADESYN,ADEMNE,ADENOP)=""
.I ADEID="SVC" D Q
. . S ADELEV=$P(X,U,2),ADEMIN=$P(X,U,3),ADEICD9=$P(X,U,4)
. . Q:ADEICD9=""
. . S ADEICD9=+$O(^ICD9("AB",ADEICD9,0))
. . S:'+ADEICD9 ADEICD9=""
. . Q
.I ADEID="SYN" S ADESYN=$P(X,U,2) Q
.I ADEID="MNE" S ADEMNE=$P(X,U,2) Q
.I ADEID="NOP" S ADENOP="n" Q
.I ADEID="USE" S ADEUSE=1 Q
.I ADEUSE S ADETXT=ADETXT+1,ADETEXT(ADETXT)=X Q
I X="",ADERLN=4,$T(+ADERLN^@ADERTN)="" S ADEDONE=1
Q
;
ADAUPD ;
S ADEMOD=0,ADEIENST="?+1,"
I $D(^AUTTADA("B",ADECODE)) S ADEIENST=+$O(^AUTTADA("B",ADECODE,0))_",",ADEMOD=1
S ADEFDA(ADEFILE,ADEIENST,.01)=ADECODE,ADEFDA(ADEFILE,ADEIENST,.02)=ADEDESC
S:ADEICD9'="" ADEFDA(ADEFILE,ADEIENST,.03)=ADEICD9
S:ADEMIN'="" ADEFDA(ADEFILE,ADEIENST,.04)=ADEMIN
S:ADELEV'="" ADEFDA(ADEFILE,ADEIENST,.05)=ADELEV
S:ADESYN'="" ADEFDA(ADEFILE,ADEIENST,.06)=ADESYN
S:ADENOP'="" ADEFDA(ADEFILE,ADEIENST,.09)=ADENOP
S:ADEMNE'="" ADEFDA(ADEFILE,ADEIENST,8801)=ADEMNE
S ADEFDA(ADEFILE,ADEIENST,.08)="@" ;Inactivation date
D UPDATE
Q
;
UPDATE ;
I ADEMOD=0 D
. D UPDATE^DIE(,"ADEFDA","ADEIEN","ADEEMSG")
. K ADEFDA,ADEEMSG
I ADEMOD=1 D
. D FILE^DIE(,"ADEFDA","ADEEMSG")
. S ADEIEN(1)=+ADEIENST
. K ADEFDA,ADEEMSG
I ADETXT,ADETXT>1!(ADETEXT(1)'="") D WP^DIE(ADEFILE,ADEIEN(1)_",",ADEWPFLD,,"ADETEXT","ADEEMSG")
K ADETEXT,ADEEMSG,ADEIEN
Q
KILL ;
K ADEADA,ADECNT,ADECODE,ADEDESC,ADEDONE,ADEFDA,ADEFILE,ADEICD9,ADEID,ADEIENST,ADELEV,ADEMIN,ADEMNE,ADEMOD,ADERLN,ADERN,ADERTN,ADESYN,ADETDT,ADETEXT,ADETXT,ADEUSE,ADEWPFLD,ADENOP,DA,DIC,DIE,DR,X
Q
ADECD4 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
+1 ;;6.0;ADE;**12**;MAR 25, 1999
+2 SET U="^"
+3 DO ADA
+4 ;ADA CODE EDIT GROUPS
DO ^ADECD44
+5 ;DENTAL EDITS
DO ^ADECD45
+6 QUIT
+7 ;
ADA ;
+1 ;
+2 SET ADEFILE=9999999.31
SET ADEWPFLD=1101
SET ADEIENST="?+1,"
SET ADECNT=0
SET ADEDONE=0
SET ADEMOD=0
+3 ;Copy ^AUTTADA to ^ADEOCD4 to backup ADA Codes before the update
+4 IF '$DATA(^ADEOCD4)
SET %X="^AUTTADA("
SET %Y="^ADEOCD4("
DO %XY^%RCR
KILL %X,%Y
+5 SET DIK="^AUTTADA("
DO IXALL^DIK
KILL DIK
+6 ;Update ADA codes with CDT4 Update
+7 FOR ADERN=1:1:3
DO ADA1(ADERN)
IF ADEDONE
QUIT
+8 DO ADAUPD
+9 ;Deactivated Codes
+10 DO NOW^%DTC
SET ADETDT=X
+11 FOR ADEADA="0501","2110","2120","2130","2131","2336","2337","2380","2381","2382","2385"
DO DEACT(ADEADA)
+12 FOR ADEADA="2386","2387","2388","4220","6519","6520","6530","6543","6544","7110","7120"
DO DEACT(ADEADA)
+13 FOR ADEADA="7130","7420","7430","7431","7480"
DO DEACT(ADEADA)
+14 DO KILL
+15 QUIT
+16 ;
DEACT(ADEADA) ;Deactivate Code
+1 SET DIC=ADEFILE
SET DIC(0)="X"
SET X=ADEADA
+2 DO ^DIC
+3 IF Y>0
Begin DoDot:1
+4 SET DIE=ADEFILE
SET DA=+Y
SET DR=".08////"_ADETDT
+5 DO ^DIE
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
ADA1(ADERN) ;
+1 SET ADERTN="ADECD4"_ADERN
+2 FOR ADERLN=4:1
SET X=$TEXT(+ADERLN^@ADERTN)
IF X=""
QUIT
Begin DoDot:1
+3 SET X=$PIECE(X,";",3,$LENGTH(X,";"))
IF X=""
QUIT
+4 SET ADEID=$PIECE(X,U)
IF ADEID="***END***"
SET ADEDONE=1
QUIT
+5 IF ADEID="CODE"
IF ADECNT
DO ADAUPD
SET ADECODE=$PIECE(X,U,2)
SET ADEDESC=$PIECE(X,U,3)
SET ADECNT=ADECNT+1
SET ADEUSE=0
SET ADETXT=0
SET (ADELEV,ADESYN,ADEMNE,ADENOP)=""
+6 IF ADEID="SVC"
Begin DoDot:2
+7 SET ADELEV=$PIECE(X,U,2)
SET ADEMIN=$PIECE(X,U,3)
SET ADEICD9=$PIECE(X,U,4)
+8 IF ADEICD9=""
QUIT
+9 SET ADEICD9=+$ORDER(^ICD9("AB",ADEICD9,0))
+10 IF '+ADEICD9
SET ADEICD9=""
+11 QUIT
End DoDot:2
QUIT
+12 IF ADEID="SYN"
SET ADESYN=$PIECE(X,U,2)
QUIT
+13 IF ADEID="MNE"
SET ADEMNE=$PIECE(X,U,2)
QUIT
+14 IF ADEID="NOP"
SET ADENOP="n"
QUIT
+15 IF ADEID="USE"
SET ADEUSE=1
QUIT
+16 IF ADEUSE
SET ADETXT=ADETXT+1
SET ADETEXT(ADETXT)=X
QUIT
End DoDot:1
IF ADEDONE
QUIT
+17 IF X=""
IF ADERLN=4
IF $TEXT(+ADERLN^@ADERTN)=""
SET ADEDONE=1
+18 QUIT
+19 ;
ADAUPD ;
+1 SET ADEMOD=0
SET ADEIENST="?+1,"
+2 IF $DATA(^AUTTADA("B",ADECODE))
SET ADEIENST=+$ORDER(^AUTTADA("B",ADECODE,0))_","
SET ADEMOD=1
+3 SET ADEFDA(ADEFILE,ADEIENST,.01)=ADECODE
SET ADEFDA(ADEFILE,ADEIENST,.02)=ADEDESC
+4 IF ADEICD9'=""
SET ADEFDA(ADEFILE,ADEIENST,.03)=ADEICD9
+5 IF ADEMIN'=""
SET ADEFDA(ADEFILE,ADEIENST,.04)=ADEMIN
+6 IF ADELEV'=""
SET ADEFDA(ADEFILE,ADEIENST,.05)=ADELEV
+7 IF ADESYN'=""
SET ADEFDA(ADEFILE,ADEIENST,.06)=ADESYN
+8 IF ADENOP'=""
SET ADEFDA(ADEFILE,ADEIENST,.09)=ADENOP
+9 IF ADEMNE'=""
SET ADEFDA(ADEFILE,ADEIENST,8801)=ADEMNE
+10 ;Inactivation date
SET ADEFDA(ADEFILE,ADEIENST,.08)="@"
+11 DO UPDATE
+12 QUIT
+13 ;
UPDATE ;
+1 IF ADEMOD=0
Begin DoDot:1
+2 DO UPDATE^DIE(,"ADEFDA","ADEIEN","ADEEMSG")
+3 KILL ADEFDA,ADEEMSG
End DoDot:1
+4 IF ADEMOD=1
Begin DoDot:1
+5 DO FILE^DIE(,"ADEFDA","ADEEMSG")
+6 SET ADEIEN(1)=+ADEIENST
+7 KILL ADEFDA,ADEEMSG
End DoDot:1
+8 IF ADETXT
IF ADETXT>1!(ADETEXT(1)'="")
DO WP^DIE(ADEFILE,ADEIEN(1)_",",ADEWPFLD,,"ADETEXT","ADEEMSG")
+9 KILL ADETEXT,ADEEMSG,ADEIEN
+10 QUIT
KILL ;
+1 KILL ADEADA,ADECNT,ADECODE,ADEDESC,ADEDONE,ADEFDA,ADEFILE,ADEICD9,ADEID,ADEIENST,ADELEV,ADEMIN,ADEMNE,ADEMOD,ADERLN,ADERN,ADERTN,ADESYN,ADETDT,ADETEXT,ADETXT,ADEUSE,ADEWPFLD,ADENOP,DA,DIC,DIE,DR,X
+2 QUIT
