ADE697A ; IHS/DIR/FHL - DENTAL TABLE UPDATES ; [ 03/24/1999 8:35 AM ]
;;6.0;ADE;;APRIL 1999
;;This is the Post-Init routine
;Q
;
START ;EP
;
NEW A,C,DIC,DIE,DLAYGO,DR,E,L,M,N,O,P,R,S,T
K ^TMP("ADE697",$J)
;
D DASH,RSLT($J("",15)_"IHS DENTAL TABLE UPDATES")
D DASH,MOD,DASH,ADD,DASH,USE
D DASH,OPSITE^ADE697B
D DASH,GROUP^ADE697B,DASH,EDIT^ADE697B
D DASH,COMPILE^ADE697C
Q
;
ADDOK(L) ;EP
D RSLT($J("",5)_"Added : "_L) Q
ADDFAIL(L) ;EP
D RSLT($J("",5)_"Error: "_"Add Failed => "_L) Q
MODOK(L) ;EP
D RSLT($J("",5)_"Changed : "_L) Q
RSLT(%) ;EP
S ^TMP("ADE697",$J,0)=$G(^TMP("ADE697",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
W:'$D(ZTQUEUED) !,% Q
DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q
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
;
ADD ;
N T,L,ADEJ
D RSLT("Add ADA Code")
F ADEJ=1:1:2 S ADERTN="^ADE6A"_ADEJ D
. F T=1:1 S ADELINE="S L=$T(ADAADD+T"_ADERTN_")" X ADELINE S L=$P(L,";",3) Q:L="END" D ADAADD(L)
. 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 ADDFAIL(N(1)):Y<0,ADDOK(N(1)):Y>0
Q
;
USE ;EP
N ADET,ADEC,ADEWP,ADECNT,ADECOD,ADERET,ADEDA,ADENEXT,ADERR
D RSLT("Modify ADA CODE 'RECOMMENDED USE' WP Field")
S ADECOD="",ADERR=""
F ADET=1:1 S ADEC=$T(ADAUSE+ADET^ADE6U1) S ADEC=$P(ADEC,";",3) D Q:ADEC="END"
. S ADENEXT=$E(ADEC,1,4)
. I (ADECOD'=ADENEXT) D
. . I (ADECOD]"") D
. . . I ADEDA D
. . . . D WP^DIE(9999999.31,ADEDA_",",1101,"","ADEWP","ADERET")
. . . . D RSLT($J("",5)_ADECOD_" 'USE' added")
. . . K ADECNT,ADEWP
. . Q:ADENEXT="END"
. . S ADECOD=ADENEXT
. . S ADEDA=$O(^AUTTADA("B",$E(ADECOD,1,4),0))
. . I 'ADEDA&(ADERR'=ADECOD) D RSLT($J("",5)_"Code "_ADECOD_" Doesn't exist to add 'USE' field")
. . S:'ADEDA ADERR=ADECOD
. . S ADECNT=0
. . Q
. Q:ADENEXT="END"
. S ADECNT=ADECNT+1
. S ADEWP(ADECNT)=$P(ADEC,U,2)
. Q
Q
;
MOD ;
N ADET,ADEFROM,ADETO,ADEJ,ADELINE,ADERTN
D RSLT("ADA Code Changes")
D CHECK
F ADEJ=1:1:9 S ADERTN="^ADE6M"_ADEJ D
. F ADET=1:2 S ADELINE="S ADEFROM=$T(ADAMOD+"_ADET_ADERTN_")" X ADELINE Q:$P(ADEFROM,";",3)="END" S ADELINE="S ADETO=$T(ADAMOD+"_(ADET+1)_ADERTN_")" X ADELINE D ADAMOD(ADEFROM,ADETO)
. Q
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))
;FHL 09/09/98 I 'ADEDA B S ADEDA=$O(^AUTTADA("B",ADE("TO",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
;
CHECK ;Check for exam code changes
;
N ADEDA,ADE
D CHK1,CHK2,CHK3
Q
CHK1 S ADEDA=$O(^AUTTADA("B","0140",0))
Q:'+ADEDA
Q:'$D(^AUTTADA(ADEDA,0))
Q:$P(^AUTTADA(ADEDA,0),U,2)'["SCREEN"
S ADE("FROM")="FROM^0140^SCREENING ORAL EXAM^V72.2^1^0^SCREEN EXAM^^^n^"
S ADE("TO")="TO^0114^SCREENING ORAL EXAM^V72.2^1^0^SCREEN EXAM^^^n^"
D ADAMOD(ADE("FROM"),ADE("TO"))
Q
;
CHK2 S ADEDA=$O(^AUTTADA("B","0130",0))
Q:'+ADEDA
Q:$D(^AUTTADA("B","0140"))
S ADE("FROM")="FROM^0130^ORAL EXAMINATION, EMERGENCY^V72.2^5^1^EMERG. EXAM^^^n^EOE"
S ADE("TO")="TO^0140^ORAL EXAMINATION, EMERGENCY^V72.2^5^1^EMERG. EXAM^^^n^EOE"
D ADAMOD(ADE("FROM"),ADE("TO"))
Q
;
CHK3 S ADEDA=$O(^AUTTADA("B","0110",0))
Q:'+ADEDA
Q:$D(^AUTTADA("B","0150"))
S ADE("FROM")="FROM^0110^ORAL EXAMINATION, INITIAL^V72.2^15^3^ORAL EXAM INIT.^^^n^IOE"
S ADE("TO")="TO^0150^ORAL EXAMINATION, INITIAL^V72.2^15^3^ORAL EXAM INIT.^^^n^IOE"
D ADAMOD(ADE("FROM"),ADE("TO"))
Q
ADE697A ; IHS/DIR/FHL - DENTAL TABLE UPDATES ; [ 03/24/1999 8:35 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;;This is the Post-Init routine
+3 ;Q
+4 ;
START ;EP
+1 ;
+2 NEW A,C,DIC,DIE,DLAYGO,DR,E,L,M,N,O,P,R,S,T
+3 KILL ^TMP("ADE697",$JOB)
+4 ;
+5 DO DASH
DO RSLT($JUSTIFY("",15)_"IHS DENTAL TABLE UPDATES")
+6 DO DASH
DO MOD
DO DASH
DO ADD
DO DASH
DO USE
+7 DO DASH
DO OPSITE^ADE697B
+8 DO DASH
DO GROUP^ADE697B
DO DASH
DO EDIT^ADE697B
+9 DO DASH
DO COMPILE^ADE697C
+10 QUIT
+11 ;
ADDOK(L) ;EP
+1 DO RSLT($JUSTIFY("",5)_"Added : "_L)
QUIT
ADDFAIL(L) ;EP
+1 DO RSLT($JUSTIFY("",5)_"Error: "_"Add Failed => "_L)
QUIT
MODOK(L) ;EP
+1 DO RSLT($JUSTIFY("",5)_"Changed : "_L)
QUIT
RSLT(%) ;EP
+1 SET ^TMP("ADE697",$JOB,0)=$GET(^TMP("ADE697",$JOB,0))+1
SET ^(^(0))=%
IF '$DATA(ZTQUEUED)
WRITE !,%
QUIT
+2 IF '$DATA(ZTQUEUED)
WRITE !,%
QUIT
DASH DO RSLT("")
DO RSLT($$REPEAT^XLFSTR("-",$SELECT($GET(IOM):IOM-10,1:70)))
DO RSLT("")
QUIT
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 ;
ADD ;
+1 NEW T,L,ADEJ
+2 DO RSLT("Add ADA Code")
+3 FOR ADEJ=1:1:2
SET ADERTN="^ADE6A"_ADEJ
Begin DoDot:1
+4 FOR T=1:1
SET ADELINE="S L=$T(ADAADD+T"_ADERTN_")"
XECUTE ADELINE
SET L=$PIECE(L,";",3)
IF L="END"
QUIT
DO ADAADD(L)
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
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 IF Y<0
DO ADDFAIL(N(1))
IF Y>0
DO ADDOK(N(1))
+12 QUIT
+13 ;
USE ;EP
+1 NEW ADET,ADEC,ADEWP,ADECNT,ADECOD,ADERET,ADEDA,ADENEXT,ADERR
+2 DO RSLT("Modify ADA CODE 'RECOMMENDED USE' WP Field")
+3 SET ADECOD=""
SET ADERR=""
+4 FOR ADET=1:1
SET ADEC=$TEXT(ADAUSE+ADET^ADE6U1)
SET ADEC=$PIECE(ADEC,";",3)
Begin DoDot:1
+5 SET ADENEXT=$EXTRACT(ADEC,1,4)
+6 IF (ADECOD'=ADENEXT)
Begin DoDot:2
+7 IF (ADECOD]"")
Begin DoDot:3
+8 IF ADEDA
Begin DoDot:4
+9 DO WP^DIE(9999999.31,ADEDA_",",1101,"","ADEWP","ADERET")
+10 DO RSLT($JUSTIFY("",5)_ADECOD_" 'USE' added")
End DoDot:4
+11 KILL ADECNT,ADEWP
End DoDot:3
+12 IF ADENEXT="END"
QUIT
+13 SET ADECOD=ADENEXT
+14 SET ADEDA=$ORDER(^AUTTADA("B",$EXTRACT(ADECOD,1,4),0))
+15 IF 'ADEDA&(ADERR'=ADECOD)
DO RSLT($JUSTIFY("",5)_"Code "_ADECOD_" Doesn't exist to add 'USE' field")
+16 IF 'ADEDA
SET ADERR=ADECOD
+17 SET ADECNT=0
+18 QUIT
End DoDot:2
+19 IF ADENEXT="END"
QUIT
+20 SET ADECNT=ADECNT+1
+21 SET ADEWP(ADECNT)=$PIECE(ADEC,U,2)
+22 QUIT
End DoDot:1
IF ADEC="END"
QUIT
+23 QUIT
+24 ;
MOD ;
+1 NEW ADET,ADEFROM,ADETO,ADEJ,ADELINE,ADERTN
+2 DO RSLT("ADA Code Changes")
+3 DO CHECK
+4 FOR ADEJ=1:1:9
SET ADERTN="^ADE6M"_ADEJ
Begin DoDot:1
+5 FOR ADET=1:2
SET ADELINE="S ADEFROM=$T(ADAMOD+"_ADET_ADERTN_")"
XECUTE ADELINE
IF $PIECE(ADEFROM,";",3)="END"
QUIT
SET ADELINE="S ADETO=$T(ADAMOD+"_(ADET+1)_ADERTN_")"
XECUTE ADELINE
DO ADAMOD(ADEFROM,ADETO)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
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 ;FHL 09/09/98 I 'ADEDA B S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
+10 IF 'ADEDA
SET ADEDA=$ORDER(^AUTTADA("B",ADE("TO",1),0))
+11 IF 'ADEDA
Begin DoDot:1
+12 DO RSLT(ADE("FROM",1)_" NOT PRESENT, "_ADE("TO",1)_" WILL BE ADDED.")
+13 DO ADAADD(U_$PIECE(ADETO,U,2,11))
+14 QUIT
End DoDot:1
QUIT
+15 ; Modify ADA Code
+16 SET ADEDIE="^AUTTADA("
+17 SET ADEDR=".01////"_ADE("TO",1)
+18 FOR ADEJ=2:1:9
SET ADEDR=ADEDR_";.0"_ADEJ_"///"_ADE("TO",ADEJ)
+19 SET ADEDR=ADEDR_";8801///"_ADE("TO",10)
+20 SET ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
+21 IF ADEY["ERR"
DO RSLT("ERROR: EDIT ADA CODE FAILED => "_ADE("FROM",1))
QUIT
+22 QUIT
+23 ;
CHECK ;Check for exam code changes
+1 ;
+2 NEW ADEDA,ADE
+3 DO CHK1
DO CHK2
DO CHK3
+4 QUIT
CHK1 SET ADEDA=$ORDER(^AUTTADA("B","0140",0))
+1 IF '+ADEDA
QUIT
+2 IF '$DATA(^AUTTADA(ADEDA,0))
QUIT
+3 IF $PIECE(^AUTTADA(ADEDA,0),U,2)'["SCREEN"
QUIT
+4 SET ADE("FROM")="FROM^0140^SCREENING ORAL EXAM^V72.2^1^0^SCREEN EXAM^^^n^"
+5 SET ADE("TO")="TO^0114^SCREENING ORAL EXAM^V72.2^1^0^SCREEN EXAM^^^n^"
+6 DO ADAMOD(ADE("FROM"),ADE("TO"))
+7 QUIT
+8 ;
CHK2 SET ADEDA=$ORDER(^AUTTADA("B","0130",0))
+1 IF '+ADEDA
QUIT
+2 IF $DATA(^AUTTADA("B","0140"))
QUIT
+3 SET ADE("FROM")="FROM^0130^ORAL EXAMINATION, EMERGENCY^V72.2^5^1^EMERG. EXAM^^^n^EOE"
+4 SET ADE("TO")="TO^0140^ORAL EXAMINATION, EMERGENCY^V72.2^5^1^EMERG. EXAM^^^n^EOE"
+5 DO ADAMOD(ADE("FROM"),ADE("TO"))
+6 QUIT
+7 ;
CHK3 SET ADEDA=$ORDER(^AUTTADA("B","0110",0))
+1 IF '+ADEDA
QUIT
+2 IF $DATA(^AUTTADA("B","0150"))
QUIT
+3 SET ADE("FROM")="FROM^0110^ORAL EXAMINATION, INITIAL^V72.2^15^3^ORAL EXAM INIT.^^^n^IOE"
+4 SET ADE("TO")="TO^0150^ORAL EXAMINATION, INITIAL^V72.2^15^3^ORAL EXAM INIT.^^^n^IOE"
+5 DO ADAMOD(ADE("FROM"),ADE("TO"))
+6 QUIT
