ADECD46 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
;;6.0;ADE;**14**;MAR 25, 1999
S U="^"
;
ADA ;
;
N ADEFILE,ADEWPFLD,ADEIENST,ADECNT,ADEDONE,ADEMOD,ADERN,ADEDONE,ADERTN
N ADERLN,ADEID,ADECODE,ADEDESC,ADEUSE,ADETXT,ADELEV,ADESYN,ADEMNE,ADENOP
N ADEMIN,ADEICD9,ADEFDA,ADEEMSG
S ADEFILE=9999999.31,ADEWPFLD=1101,ADEIENST="?+1,",ADECNT=0,ADEDONE=0,ADEMOD=0
;Copy ^AUTTADA to ^ADEOCD46 to backup ADA Codes before the update
I '$D(^ADEOCD46) S %X="^AUTTADA(",%Y="^ADEOCD46(" D %XY^%RCR K %X,%Y
S DIK="^AUTTADA(" D IXALL^DIK K DIK
;Update ADA codes
F ADERN=1,2 D ADA1(ADERN) Q:ADEDONE
D ADAUPD
Q
;
ADA1(ADERN) ;
S ADERTN="ADECD47"_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,ADEMIN,ADEICD9,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=$P(X,U,2) 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
ADECD46 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
+1 ;;6.0;ADE;**14**;MAR 25, 1999
+2 SET U="^"
+3 ;
ADA ;
+1 ;
+2 NEW ADEFILE,ADEWPFLD,ADEIENST,ADECNT,ADEDONE,ADEMOD,ADERN,ADEDONE,ADERTN
+3 NEW ADERLN,ADEID,ADECODE,ADEDESC,ADEUSE,ADETXT,ADELEV,ADESYN,ADEMNE,ADENOP
+4 NEW ADEMIN,ADEICD9,ADEFDA,ADEEMSG
+5 SET ADEFILE=9999999.31
SET ADEWPFLD=1101
SET ADEIENST="?+1,"
SET ADECNT=0
SET ADEDONE=0
SET ADEMOD=0
+6 ;Copy ^AUTTADA to ^ADEOCD46 to backup ADA Codes before the update
+7 IF '$DATA(^ADEOCD46)
SET %X="^AUTTADA("
SET %Y="^ADEOCD46("
DO %XY^%RCR
KILL %X,%Y
+8 SET DIK="^AUTTADA("
DO IXALL^DIK
KILL DIK
+9 ;Update ADA codes
+10 FOR ADERN=1,2
DO ADA1(ADERN)
IF ADEDONE
QUIT
+11 DO ADAUPD
+12 QUIT
+13 ;
ADA1(ADERN) ;
+1 SET ADERTN="ADECD47"_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,ADEMIN,ADEICD9,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=$PIECE(X,U,2)
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
