ADEGRL3 ; IHS/HQT/MJL - DENTAL ENTRY PART 4 ;
;;6.0;ADE;**10,12,23,26**;JUN 6, 2011;Build 13
;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
;------->INIT
D HRN
S ADETITL="CURRENT VISIT ENTRIES TABLE"_$S(ADEDIR:" (DIRECT",1:" (CONTRACT")_" MODE)"
;------->GET CUR VIS STAT
;/IHS/OIT/GAB 11.2014 Patch #26 Changed the below two lines & added following two - update 9130 & 9140 codes to 9986 & 9987, but don't remove old codes yet!
;I '$D(ADEV("0000")),'$D(ADEV("0190")),'$D(ADEV("9130")),'$D(ADEV("9140")) D VSTAT^ADEGRL4 I Y=-1 S ADENOUPD=1 W !!,"***DATA ENTRY ABORTED***" G END
;I 'ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))) D LIST S ADENOUPD=1 W !!,"***UNEDITABLE RECORD (FAILED APPOINTMENT) -- USE DELETE OPTION TO DELETE***",*7 H 2 G END
I '$D(ADEV("0000")),'$D(ADEV("0190")),'$D(ADEV("9130")),'$D(ADEV("9140")),'$D(ADEV("9986")),'$D(ADEV("9987")) D VSTAT^ADEGRL4 I Y=-1 S ADENOUPD=1 W !!,"***DATA ENTRY ABORTED***" G END
I 'ADENEWVS,$D(ADEV("9130"))!$D(ADEV("9140"))!$D(ADEV("9986"))!$D(ADEV("9987")) D LIST S ADENOUPD=1 W !!,"***UNEDITABLE RECORD (FAILED APPOINTMENT) -- USE DELETE OPTION TO DELETE***",*7 H 2 G END
;------->GET TREATMENT HISTORY
K ADEHXC,ADEHXO,ADEHXF
D ^ADEGRL33
;Patch **12** removed call to IH^ADEGRL34 IHS/HMW 1-15-2003
;Begin IH Code Patch **10** IHS/ANMC/HMW 11-2-2001
;I '$$IH^ADEGRL34(ADEPAT,ADEVDATE) S ADENOUPD=1 W !!,"***DATA ENTRY ABORTED***" G END
;End IH Code Patch
CTRL ;------->CTRL
S ADEY=1
D LIST
;------->READ
W !!,"Select ADA CODE (or Action): " R X:DTIME S:'$T X="^"
;------->CHECK FOR END OF DATA ENTRY, CONSISTENCY CHECKS
I X=""!(X="^Q")!(X="^") S Y=0 D EXIT^ADEGRL31 G:Y END G CTRL
;IHS;SD;TPF 4/22/2011 WO 2011 CNI-100 PATCH 23
;DO DEPENDENCY CHECK
G CTRL:$$DEPEND(X,.ADEV)
;END WO 2011 CNI-100
D CHECKEX G:'ADEY CTRL
D VERIFY^ADEGRL32 G:'ADEY CTRL
;------->I CON
I ADECON D FEE^ADEGRL31 G:'ADEY CTRL
I ADECON,$P(Y(0),U,9)="n" D QUANT G VALID
I ADECON,$P(Y(0),U,9)'="n" D ^ADEGRL5 G VALID
;------->I DIR
I 'ADEFAST,$P(Y(0),U,9)'="n" D ^ADEGRL5 G VALID
D QUANT
;
VALID ;VALIDITY CHECKS -- Check that code is reportable given Pt Tx Hx.
I $D(ADEV(ADECOD)) D ^ADEGRL5A D:$D(ADEXFLG) RETURN^ADEGRL5B K ADEREDO,ADEXFLG,ADENRP
G CTRL
END Q
;
DEPEND(X,ADEV) ;DEPENDENCY CHECK
I X=9221,'$D(ADEV(9220)) D Q 1
.W !!!,"CODE 9221 REQUIRES ENTRY OF CODE 9220 FIRST!" D DIRE
I X=9242,'$D(ADEV(9241)) D Q 1
.W !!!,"CODE 9242 REQUIRES ENTRY OF CODE 9241 FIRST!" D DIRE
Q 0
DIRE ;PRESS RETURN
K DIR S DIR(0)="E" D ^DIR
Q
;
CHECKEX I X="?" S XQH="ADE-DVIS-ADACODES" D EN^XQH K XQH D ^ADECLS,^ADEHELP S ADEY=0 Q
I X="??" D ^ADEHELP S ADEY=0 Q
;I X="^L" D FAC^ADEGRL4 K DIC S ADEY=0 Q
I X="^D" D REPD^ADEGRL4 K DIC S ADEY=0 Q
I X="^H",'ADECON D PROV^ADEGRL4 K DIC S ADEY=0 Q
I X="^N" D NOTE^ADEGRL4 S ADEY=0 Q
I X="^W",'ADECON N ADETITL S ADETITL=" WAITING",ADEWAI=1,ADEREC=0,ADEREF=0,ADETYP="w" D EN^ADEMNG S ADEY=0 Q
I X="^R",'ADECON N ADETITL S ADETITL=" RECALL",ADEWAI=0,ADEREC=1,ADEREF=0,ADETYP="rc" D EN^ADEMNG S ADEY=0 Q
I ADECON,X="^C" D TFEE^ADEGRL31 S ADEY=0 Q
I ADEDIR,X="^S" D EN^ADEATT S ADEY=0 Q
I X="^P",'$D(ADEPLET) S ADEPLET=1,ADEY=0 Q
I X="^P" K ADEPLET S ADEY=0 Q
I X="^V" D EN2^ADERVW Q
I X="@" D DEL^ADEGRL31 S ADEY=0 Q
I X["@",$P(X,"@",2)]"",$D(ADEV($P(X,"@",2))) K ADEV($P(X,"@",2)),ADEDES($P(X,"@",2)) S ADEY=0 Q
Q
QUANT ;
S $P(ADEV(ADECOD),U)=1 ;IHS/HMW 9-24-90 IF 'NO OPSITE' STUFF QTY=1
;IHS/SD/TPF 4/22/2010 WO 2011 CNI-100 PATCH
I ADECOD="0240"!(ADECOD=9221)!(ADECOD=9242) D
.K DIR,DTOUT,DTOUT
.S DIR("B")="Enter Quntity"
.S DIR(0)="N^1:6"
.D ^DIR
.Q:$D(DTOUT)!($D(DUOUT))
.S $P(ADEV(ADECOD),U)=Y
;END WO 2011 CNI-100
Q
LIST ;EP
N ADENONR
D ^ADECLS,LINE
W !,"Patient: ",ADEPNM,?40,"Chart#: ",ADEHRN,?57,"Date: ",ADEVDATE,!,"Location: ",ADELOE W:('ADEFAST)&ADEDIR !,"Hygienist/Therapist: ",ADEPVNM W !,"Attending Dentist: ",ADERDNM,!
I $D(ADENOTE),ADENOTE]"",ADENOTE'="@" W "Dental Note: ",ADENOTE,!
I ADECON S (ADETFE,L)=0 F K=0:0 S L=$O(ADEV(L)) Q:L="" S ADETFE=ADETFE+($P(ADEV(L),U,3)*$P(ADEV(L),U))
I ADECON S:'ADETCHF ADETCH=ADETFE W "Total Fees: $",$J(ADETFE,4,2),?30,"Total Charge this Visit: $",$J(ADETCH,4,2),!
W !,"ADA CODE",?10,"DESCRIPTION",?27,"QTY"
W:ADECON ?32,"UNIT",?40,"TOTAL"
W:ADECON ?50,"OPSITE" W:ADEDIR ?35,"OPSITE"
S J=0
L1 S J=$O(ADEV(J)) G:J="" L2
W !?2,J
I $P(ADEV(J),U,2)="",$P(ADEV(J),U,5)]"" W "*" S ADENONR=1
W ?10,ADEDES(J),?27,$J($P(ADEV(J),U),3) W:ADECON ?32,$P(ADEV(J),U,3),?40,$P(ADEV(J),U,3)*$P(ADEV(J),U)
S ADECNT=0 F K=1:1:$L($P(ADEV(J),U,2),",") S ADEPC=$P($P(ADEV(J),U,2),",",K) D L3
G L1
L2 K J W:$D(ADENONR) !,"*=Unreportable Procedures" W !,ADELIN Q
L3 ;DISPLAY OP SITE
Q:ADEPC="" ;IHS/HMW 5-12-90
I $D(ADEPLET),$P(^ADEOPS(ADEPC,0),U,4)]"" S ADEPC=$P(^ADEOPS(ADEPC,0),U,4) ;IHS/HMW 5-12-90
E S ADEPC=^ADEOPS(ADEPC,88) ;IHS/HMW 5-12-90
I $P($P(ADEV(J),U,4),",",K)]"" S ADEPC=ADEPC_"["_$P($P(ADEV(J),U,4),",",K)_"]"
I $P($P(ADEV(J),U,5),",",K)]"" S ADEPC=ADEPC_"*",ADENONR=1
S ADECNT=$L(ADEPC)+ADECNT+1
I ADECNT>$S(ADECON:15,ADEDIR:30) S ADECNT=0 W:ADEDIR !,?35,ADEPC_" " W:ADECON !,?50,ADEPC_" " Q
W:ADEDIR ?35,ADEPC_" " W:ADECON ?50,ADEPC_" " Q
LINE W $E(ADELIN,1,40-($L(ADETITL)/2)),ADETITL,$E(ADELIN,1,39-($L(ADETITL)/2)) Q
CON ;EP
R !,"(Press ENTER to continue) ",X:DTIME K X Q
HRN ;EP
S ADEPNM=$P(^DPT(ADEPAT,0),U) S ADENOUPD=0
S ADEHRN="" I $D(^AUPNPAT(ADEPAT,41,DUZ(2),0)) S ADEHRN=$P(^(0),U,2)
Q
ADEGRL3 ; IHS/HQT/MJL - DENTAL ENTRY PART 4 ;
+1 ;;6.0;ADE;**10,12,23,26**;JUN 6, 2011;Build 13
+2 ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
+3 ;------->INIT
+4 DO HRN
+5 SET ADETITL="CURRENT VISIT ENTRIES TABLE"_$SELECT(ADEDIR:" (DIRECT",1:" (CONTRACT")_" MODE)"
+6 ;------->GET CUR VIS STAT
+7 ;/IHS/OIT/GAB 11.2014 Patch #26 Changed the below two lines & added following two - update 9130 & 9140 codes to 9986 & 9987, but don't remove old codes yet!
+8 ;I '$D(ADEV("0000")),'$D(ADEV("0190")),'$D(ADEV("9130")),'$D(ADEV("9140")) D VSTAT^ADEGRL4 I Y=-1 S ADENOUPD=1 W !!,"***DATA ENTRY ABORTED***" G END
+9 ;I 'ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))) D LIST S ADENOUPD=1 W !!,"***UNEDITABLE RECORD (FAILED APPOINTMENT) -- USE DELETE OPTION TO DELETE***",*7 H 2 G END
+10 IF '$DATA(ADEV("0000"))
IF '$DATA(ADEV("0190"))
IF '$DATA(ADEV("9130"))
IF '$DATA(ADEV("9140"))
IF '$DATA(ADEV("9986"))
IF '$DATA(ADEV("9987"))
DO VSTAT^ADEGRL4
IF Y=-1
SET ADENOUPD=1
WRITE !!,"***DATA ENTRY ABORTED***"
GOTO END
+11 IF 'ADENEWVS
IF $DATA(ADEV("9130"))!$DATA(ADEV("9140"))!$DATA(ADEV("9986"))!$DATA(ADEV("9987"))
DO LIST
SET ADENOUPD=1
WRITE !!,"***UNEDITABLE RECORD (FAILED APPOINTMENT) -- USE DELETE OPTION TO DELETE***",*7
HANG 2
GOTO END
+12 ;------->GET TREATMENT HISTORY
+13 KILL ADEHXC,ADEHXO,ADEHXF
+14 DO ^ADEGRL33
+15 ;Patch **12** removed call to IH^ADEGRL34 IHS/HMW 1-15-2003
+16 ;Begin IH Code Patch **10** IHS/ANMC/HMW 11-2-2001
+17 ;I '$$IH^ADEGRL34(ADEPAT,ADEVDATE) S ADENOUPD=1 W !!,"***DATA ENTRY ABORTED***" G END
+18 ;End IH Code Patch
CTRL ;------->CTRL
+1 SET ADEY=1
+2 DO LIST
+3 ;------->READ
+4 WRITE !!,"Select ADA CODE (or Action): "
READ X:DTIME
IF '$TEST
SET X="^"
+5 ;------->CHECK FOR END OF DATA ENTRY, CONSISTENCY CHECKS
+6 IF X=""!(X="^Q")!(X="^")
SET Y=0
DO EXIT^ADEGRL31
IF Y
GOTO END
GOTO CTRL
+7 ;IHS;SD;TPF 4/22/2011 WO 2011 CNI-100 PATCH 23
+8 ;DO DEPENDENCY CHECK
+9 IF $$DEPEND(X,.ADEV)
GOTO CTRL
+10 ;END WO 2011 CNI-100
+11 DO CHECKEX
IF 'ADEY
GOTO CTRL
+12 DO VERIFY^ADEGRL32
IF 'ADEY
GOTO CTRL
+13 ;------->I CON
+14 IF ADECON
DO FEE^ADEGRL31
IF 'ADEY
GOTO CTRL
+15 IF ADECON
IF $PIECE(Y(0),U,9)="n"
DO QUANT
GOTO VALID
+16 IF ADECON
IF $PIECE(Y(0),U,9)'="n"
DO ^ADEGRL5
GOTO VALID
+17 ;------->I DIR
+18 IF 'ADEFAST
IF $PIECE(Y(0),U,9)'="n"
DO ^ADEGRL5
GOTO VALID
+19 DO QUANT
+20 ;
VALID ;VALIDITY CHECKS -- Check that code is reportable given Pt Tx Hx.
+1 IF $DATA(ADEV(ADECOD))
DO ^ADEGRL5A
IF $DATA(ADEXFLG)
DO RETURN^ADEGRL5B
KILL ADEREDO,ADEXFLG,ADENRP
+2 GOTO CTRL
END QUIT
+1 ;
DEPEND(X,ADEV) ;DEPENDENCY CHECK
+1 IF X=9221
IF '$DATA(ADEV(9220))
Begin DoDot:1
+2 WRITE !!!,"CODE 9221 REQUIRES ENTRY OF CODE 9220 FIRST!"
DO DIRE
End DoDot:1
QUIT 1
+3 IF X=9242
IF '$DATA(ADEV(9241))
Begin DoDot:1
+4 WRITE !!!,"CODE 9242 REQUIRES ENTRY OF CODE 9241 FIRST!"
DO DIRE
End DoDot:1
QUIT 1
+5 QUIT 0
DIRE ;PRESS RETURN
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
+2 QUIT
+3 ;
CHECKEX IF X="?"
SET XQH="ADE-DVIS-ADACODES"
DO EN^XQH
KILL XQH
DO ^ADECLS
DO ^ADEHELP
SET ADEY=0
QUIT
+1 IF X="??"
DO ^ADEHELP
SET ADEY=0
QUIT
+2 ;I X="^L" D FAC^ADEGRL4 K DIC S ADEY=0 Q
+3 IF X="^D"
DO REPD^ADEGRL4
KILL DIC
SET ADEY=0
QUIT
+4 IF X="^H"
IF 'ADECON
DO PROV^ADEGRL4
KILL DIC
SET ADEY=0
QUIT
+5 IF X="^N"
DO NOTE^ADEGRL4
SET ADEY=0
QUIT
+6 IF X="^W"
IF 'ADECON
NEW ADETITL
SET ADETITL=" WAITING"
SET ADEWAI=1
SET ADEREC=0
SET ADEREF=0
SET ADETYP="w"
DO EN^ADEMNG
SET ADEY=0
QUIT
+7 IF X="^R"
IF 'ADECON
NEW ADETITL
SET ADETITL=" RECALL"
SET ADEWAI=0
SET ADEREC=1
SET ADEREF=0
SET ADETYP="rc"
DO EN^ADEMNG
SET ADEY=0
QUIT
+8 IF ADECON
IF X="^C"
DO TFEE^ADEGRL31
SET ADEY=0
QUIT
+9 IF ADEDIR
IF X="^S"
DO EN^ADEATT
SET ADEY=0
QUIT
+10 IF X="^P"
IF '$DATA(ADEPLET)
SET ADEPLET=1
SET ADEY=0
QUIT
+11 IF X="^P"
KILL ADEPLET
SET ADEY=0
QUIT
+12 IF X="^V"
DO EN2^ADERVW
QUIT
+13 IF X="@"
DO DEL^ADEGRL31
SET ADEY=0
QUIT
+14 IF X["@"
IF $PIECE(X,"@",2)]""
IF $DATA(ADEV($PIECE(X,"@",2)))
KILL ADEV($PIECE(X,"@",2)),ADEDES($PIECE(X,"@",2))
SET ADEY=0
QUIT
+15 QUIT
QUANT ;
+1 ;IHS/HMW 9-24-90 IF 'NO OPSITE' STUFF QTY=1
SET $PIECE(ADEV(ADECOD),U)=1
+2 ;IHS/SD/TPF 4/22/2010 WO 2011 CNI-100 PATCH
+3 IF ADECOD="0240"!(ADECOD=9221)!(ADECOD=9242)
Begin DoDot:1
+4 KILL DIR,DTOUT,DTOUT
+5 SET DIR("B")="Enter Quntity"
+6 SET DIR(0)="N^1:6"
+7 DO ^DIR
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+9 SET $PIECE(ADEV(ADECOD),U)=Y
End DoDot:1
+10 ;END WO 2011 CNI-100
+11 QUIT
LIST ;EP
+1 NEW ADENONR
+2 DO ^ADECLS
DO LINE
+3 WRITE !,"Patient: ",ADEPNM,?40,"Chart#: ",ADEHRN,?57,"Date: ",ADEVDATE,!,"Location: ",ADELOE
IF ('ADEFAST)&ADEDIR
WRITE !,"Hygienist/Therapist: ",ADEPVNM
WRITE !,"Attending Dentist: ",ADERDNM,!
+4 IF $DATA(ADENOTE)
IF ADENOTE]""
IF ADENOTE'="@"
WRITE "Dental Note: ",ADENOTE,!
+5 IF ADECON
SET (ADETFE,L)=0
FOR K=0:0
SET L=$ORDER(ADEV(L))
IF L=""
QUIT
SET ADETFE=ADETFE+($PIECE(ADEV(L),U,3)*$PIECE(ADEV(L),U))
+6 IF ADECON
IF 'ADETCHF
SET ADETCH=ADETFE
WRITE "Total Fees: $",$JUSTIFY(ADETFE,4,2),?30,"Total Charge this Visit: $",$JUSTIFY(ADETCH,4,2),!
+7 WRITE !,"ADA CODE",?10,"DESCRIPTION",?27,"QTY"
+8 IF ADECON
WRITE ?32,"UNIT",?40,"TOTAL"
+9 IF ADECON
WRITE ?50,"OPSITE"
IF ADEDIR
WRITE ?35,"OPSITE"
+10 SET J=0
L1 SET J=$ORDER(ADEV(J))
IF J=""
GOTO L2
+1 WRITE !?2,J
+2 IF $PIECE(ADEV(J),U,2)=""
IF $PIECE(ADEV(J),U,5)]""
WRITE "*"
SET ADENONR=1
+3 WRITE ?10,ADEDES(J),?27,$JUSTIFY($PIECE(ADEV(J),U),3)
IF ADECON
WRITE ?32,$PIECE(ADEV(J),U,3),?40,$PIECE(ADEV(J),U,3)*$PIECE(ADEV(J),U)
+4 SET ADECNT=0
FOR K=1:1:$LENGTH($PIECE(ADEV(J),U,2),",")
SET ADEPC=$PIECE($PIECE(ADEV(J),U,2),",",K)
DO L3
+5 GOTO L1
L2 KILL J
IF $DATA(ADENONR)
WRITE !,"*=Unreportable Procedures"
WRITE !,ADELIN
QUIT
L3 ;DISPLAY OP SITE
+1 ;IHS/HMW 5-12-90
IF ADEPC=""
QUIT
+2 ;IHS/HMW 5-12-90
IF $DATA(ADEPLET)
IF $PIECE(^ADEOPS(ADEPC,0),U,4)]""
SET ADEPC=$PIECE(^ADEOPS(ADEPC,0),U,4)
+3 ;IHS/HMW 5-12-90
IF '$TEST
SET ADEPC=^ADEOPS(ADEPC,88)
+4 IF $PIECE($PIECE(ADEV(J),U,4),",",K)]""
SET ADEPC=ADEPC_"["_$PIECE($PIECE(ADEV(J),U,4),",",K)_"]"
+5 IF $PIECE($PIECE(ADEV(J),U,5),",",K)]""
SET ADEPC=ADEPC_"*"
SET ADENONR=1
+6 SET ADECNT=$LENGTH(ADEPC)+ADECNT+1
+7 IF ADECNT>$SELECT(ADECON:15,ADEDIR:30)
SET ADECNT=0
IF ADEDIR
WRITE !,?35,ADEPC_" "
IF ADECON
WRITE !,?50,ADEPC_" "
QUIT
+8 IF ADEDIR
WRITE ?35,ADEPC_" "
IF ADECON
WRITE ?50,ADEPC_" "
QUIT
LINE WRITE $EXTRACT(ADELIN,1,40-($LENGTH(ADETITL)/2)),ADETITL,$EXTRACT(ADELIN,1,39-($LENGTH(ADETITL)/2))
QUIT
CON ;EP
+1 READ !,"(Press ENTER to continue) ",X:DTIME
KILL X
QUIT
HRN ;EP
+1 SET ADEPNM=$PIECE(^DPT(ADEPAT,0),U)
SET ADENOUPD=0
+2 SET ADEHRN=""
IF $DATA(^AUPNPAT(ADEPAT,41,DUZ(2),0))
SET ADEHRN=$PIECE(^(0),U,2)
+3 QUIT
