ADEMNG3.m

ADEMNG3 ; IHS/HQT/MJL  - DENTAL FOLLOWUP MGT PT 3 ;  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

CTRL ;------->GET PRIORITY

1 S Y=1 D PRIO G:'Y END

 ;------->GET ADD DATE & COMPUTE ACTION DATE ADEMACT

2 D ADAT G:X[U 1 G:'Y END

21 D ACT G:X[U 1 G:'Y END

 ;------->GET PROVIDER

3 D PROV G:X[U 1 G:'Y END

 ;------->END

END I 'Y W !,"***FOLLOWUP DATA ENTRY ABORTED***",*7 H 2

 Q

PRIO ;I $D(ADEPRI) S ADEPRI=$S(ADEPRI="u":"URGENT",ADEPRI="r":"ROUTINE",1:"HIGH")

 W !!,"PRIORITY: "_$S($D(ADEPRI):ADEPRI_"// ",1:"") R X:DTIME S:'$T X=U

 I X="",$D(ADEPRI) S X=$E(ADEPRI,1)

 I X="" W " <Required -- type `^' to abort>",*7 G PRIO

 I X[U S Y=0 Q

 I X="R"!(X="r") W " ROUTINE" S Y=1,ADEPRI="r" Q

 I X="H"!(X="h") W " HIGH" S Y=1,ADEPRI="h" Q

 I X="U"!(X="h") W " URGENT" S Y=1,ADEPRI="u" Q

 W:X'["?" " ??",*7

 W !?5,"Enter H for High Priority, R for Routine, U for Urgent"

 G PRIO

 ;

ADAT Q:X[U

 I $D(ADEMDAT) S Y=ADEMDAT X ^DD("DD") S ADEMDAT=Y

 S %DT("A")="DATE ADDED: ",%DT("B")=$S($D(ADEMDAT):ADEMDAT,1:"TODAY"),%DT(0)=-DT,%DT="AEPX"

 D ^%DT ;G:Y<1 ADAT

 I Y<1 S Y=0 Q

 S ADEMDAT=Y

 Q

PROV K DIC,Y S DIC=6,DIC(0)="QMEZ",DIC("S")="I $P(^DIC(6,Y,0),U,4)]"""" S ADEDICS=+^DIC(7,$P(^DIC(6,Y,0),U,4),9999999) X $S((ADEDICS=52)!(ADEDICS=46):""I 1"",1:""I 0"")"

 W !,"Select PROVIDER: ",$S($D(ADEMPRO):ADEMPRO_"// ",1:"") R X:DTIME

 I '$T S X="",Y=0 Q

 I X["^" S Y=0 Q

 I X="",$D(ADEMPRO) S X=ADEMPRO

 D ^DIC K DIC,ADEDICS

 I Y=-1,X["?" G PROV

 I Y=-1 G PROV W *7," ??" G PROV

 S ADEPROD=$P(Y,U),ADEMPRO=Y(0,0)

 S Y=1 Q

ACT G:'ADENEWM A1

 S ADEMACT=$P(^ADETYP(ADESUB,0),U,$S(ADEPRI="r":3,1:2))

 S:+ADEMACT=0 ADEMACT=365

 S X2=ADEMACT,X1=ADEMDAT D C^%DTC S Y=X X ^DD("DD") S ADEMACT=Y K X,X1,X2

A1 S Y=ADEMACT X ^DD("DD") S ADEMACT=Y,%DT("A")="RECALL DATE: ",%DT("B")=ADEMACT,%DT(0)=DT,%DT="AEX"

 D ^%DT ;G:Y<1 ACT

 I Y<1 S Y=0 Q

 S ADEMACT=Y

 Q

ADEMNG3   ; IHS/HQT/MJL  - DENTAL FOLLOWUP MGT PT 3 ;  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

CTRL      ;------->GET PRIORITY

1          SET Y=1

           DO PRIO

           IF 'Y

               GOTO END

 +1       ;------->GET ADD DATE & COMPUTE ACTION DATE ADEMACT

2          DO ADAT

           IF X[U

               GOTO 1

           IF 'Y

               GOTO END

21         DO ACT

           IF X[U

               GOTO 1

           IF 'Y

               GOTO END

 +1       ;------->GET PROVIDER

3          DO PROV

           IF X[U

               GOTO 1

           IF 'Y

               GOTO END

 +1       ;------->END

END        IF 'Y

               WRITE !,"***FOLLOWUP DATA ENTRY ABORTED***",*7

               HANG 2

 +1        QUIT 

PRIO      ;I $D(ADEPRI) S ADEPRI=$S(ADEPRI="u":"URGENT",ADEPRI="r":"ROUTINE",1:"HIGH")

 +1        WRITE !!,"PRIORITY: "_$SELECT($DATA(ADEPRI):ADEPRI_"// ",1:"")

           READ X:DTIME

           IF '$TEST

               SET X=U

 +2        IF X=""

               IF $DATA(ADEPRI)

                   SET X=$EXTRACT(ADEPRI,1)

 +3        IF X=""

               WRITE " <Required -- type `^' to abort>",*7

               GOTO PRIO

 +4        IF X[U

               SET Y=0

               QUIT 

 +5        IF X="R"!(X="r")

               WRITE " ROUTINE"

               SET Y=1

               SET ADEPRI="r"

               QUIT 

 +6        IF X="H"!(X="h")

               WRITE " HIGH"

               SET Y=1

               SET ADEPRI="h"

               QUIT 

 +7        IF X="U"!(X="h")

               WRITE " URGENT"

               SET Y=1

               SET ADEPRI="u"

               QUIT 

 +8        IF X'["?"

               WRITE " ??",*7

 +9        WRITE !?5,"Enter H for High Priority, R for Routine, U for Urgent"

 +10       GOTO PRIO

 +11      ;

ADAT       IF X[U

               QUIT 

 +1        IF $DATA(ADEMDAT)

               SET Y=ADEMDAT

               XECUTE ^DD("DD")

               SET ADEMDAT=Y

 +2        SET %DT("A")="DATE ADDED: "

           SET %DT("B")=$SELECT($DATA(ADEMDAT):ADEMDAT,1:"TODAY")

           SET %DT(0)=-DT

           SET %DT="AEPX"

 +3       ;G:Y<1 ADAT

           DO ^%DT

 +4        IF Y<1

               SET Y=0

               QUIT 

 +5        SET ADEMDAT=Y

 +6        QUIT 

PROV       KILL DIC,Y

           SET DIC=6

           SET DIC(0)="QMEZ"

           SET DIC("S")="I $P(^DIC(6,Y,0),U,4)]"""" S ADEDICS=+^DIC(7,$P(^DIC(6,Y,0),U,4),9999999) X $S((ADEDICS=52)!(ADEDICS=46):""I 1"",1:""I 0"")"

 +1        WRITE !,"Select PROVIDER: ",$SELECT($DATA(ADEMPRO):ADEMPRO_"// ",1:"")

           READ X:DTIME

 +2        IF '$TEST

               SET X=""

               SET Y=0

               QUIT 

 +3        IF X["^"

               SET Y=0

               QUIT 

 +4        IF X=""

               IF $DATA(ADEMPRO)

                   SET X=ADEMPRO

 +5        DO ^DIC

           KILL DIC,ADEDICS

 +6        IF Y=-1

               IF X["?"

                   GOTO PROV

 +7        IF Y=-1

               GOTO PROV

               WRITE *7," ??"

               GOTO PROV

 +8        SET ADEPROD=$PIECE(Y,U)

           SET ADEMPRO=Y(0,0)

 +9        SET Y=1

           QUIT 

ACT        IF 'ADENEWM

               GOTO A1

 +1        SET ADEMACT=$PIECE(^ADETYP(ADESUB,0),U,$SELECT(ADEPRI="r":3,1:2))

 +2        IF +ADEMACT=0

               SET ADEMACT=365

 +3        SET X2=ADEMACT

           SET X1=ADEMDAT

           DO C^%DTC

           SET Y=X

           XECUTE ^DD("DD")

           SET ADEMACT=Y

           KILL X,X1,X2

A1         SET Y=ADEMACT

           XECUTE ^DD("DD")

           SET ADEMACT=Y

           SET %DT("A")="RECALL DATE: "

           SET %DT("B")=ADEMACT

           SET %DT(0)=DT

           SET %DT="AEX"

 +1       ;G:Y<1 ACT

           DO ^%DT

 +2        IF Y<1

               SET Y=0

               QUIT 

 +3        SET ADEMACT=Y

 +4        QUIT