ADEGRL3.m

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