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
