Routine: ADEMNG

ADEMNG ; IHS/HQT/MJL - DENTAL FOLLOWUP MGMT ;  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;S ADEREF=0,ADEREC=1,ADEWAI=0 ;SET IN CALLING OPTION

 ;------->INITIALIZE

 Q:'$D(ADEREF)!'$D(ADEREC)!'$D(ADEWAI)  S ADEINT=0,$P(ADELIN,"*",79)=""

 S ADETYP=$S(ADEREF:"rf",ADEREC:"rc",ADEWAI:"w")

 D ^XBKVAR I '$D(DUZ(2)) W !,"DIVISION NOT SET IN USER FILE -- CONTACT SITE MANAGER OR ISC" Q

 I DUZ(2)=0 W !,"DIVISION SET TO ZERO (UNIVERSAL). DIVISION MUST BE SET TO ONE OF THE ",!,"SITES IN THE DENTAL SITE PARAMETER FILE. -- CONTACT SITE MANAGER" Q

ONE ;------->RESET CONSTANT FOLLOWUP SUBTYPE

 ;        RETURN ADESUB=DFN IN ^ADETYP(

 D RESET^ADEMNG1 G:Y<1 END

TWO ;------->LOOK UP A PATIENT

 ;        RETURN ADENEWM=1 IF NEW =0 IF EDIT

 D PTLOOK^ADEMNG1 G:Y<1 ONE

FOUR ;------->CHECK IF ALREADY ON LIST ;***ASK IF SHOULD BE REMOVED

 I $D(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB)) D MOD

ADDR ;------->EDIT ADDRESS

 D P2^ADEMNG1

 I $D(Y) W !,"***FOLLOWUP DATA ENTRY ABORTED***" H 2 G:ADEINT END1 K ^ADEUTL("ADELOCK",ADEPAT) G TWO

FIVE ;------->COLLECT FOLLOWUP INFO

 D ^ADEMNG3

SIX ;------->WRITE DATA TO DISK, QUIT IF CALLED INTERNALLY

 D:Y ^ADEMNG6 G:ADEINT END1

SEVEN ;------->GET ANOTHER PATIENT

 K ^ADEUTL("ADELOCK",ADEPAT)

 K ADENEWM,ADEPAT,ADEPRI,ADEMPRO,ADEMPROD,ADEMDAT,ADEMACT,ADEMDFN,ADENOD

 G TWO

END D ^ADECLS K ADELIN

END1 K ADEDICS,ADEFUNC,ADEINT,ADEMDAT,ADEMDFN,ADEMDUZ,ADEMPRO,ADEMPROD,ADENEWM,ADEPRI,ADEREC,ADEREF,ADESUB,ADESUBN,ADETITL,ADETYP,ADEWAI

MOD ;------->LOAD LOCALS WITH EDIT DATA

 W !?5,*7,$P(^DPT(ADEPAT,0),U)," IS ALREADY ON THE ",$P(^ADETYP(ADESUB,0),U)," ",$S(ADEWAI:"WAITING",ADEREC:"RECALL",1:"REFERRAL")," LIST!"

 S ADENOD=^ADEFOL(ADEMDFN,0),ADEPRI=$P(ADENOD,U,5),ADEMDAT=$P(ADENOD,U,3),ADEMPROD=$P(ADENOD,U,7),ADEMACT=$P(ADENOD,U,4)

 F J="ADEMDAT","ADEMACT" S Y=@J X ^DD("DD") S @J=Y

 I ADEMPROD'="",$D(^DIC(16,ADEMPROD,0)) S ADEMPRO=$P(^DIC(16,ADEMPROD,0),U) ;IHS/HMW ADDED CONDITIONAL SET 6-20-90

Z S ADEPRI=$S(ADEPRI="u":"URGENT",ADEPRI="r":"ROUTINE",1:"HIGH")

EN ;EP

 ;------->GET A FOLLOWUP SUBTYPE IF CALLED INTERNALLY --ENDO,PROS

 ;        THIS IS INTERNAL ENTRY POINT -- TYPE SET BY CALLING ROUTINE

 ;        RETURN ADENEWM=1 IF NEW, 0 IF EDIT

 S ADEINT=1 D R2^ADEMNG1 G:Y<1 END1

 S ADENEWM=1

 I $D(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB)) S ADEMDFN=$O(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB,0)),ADENEWM=0 D MOD

 G ADDR

ADEMNG    ; IHS/HQT/MJL - DENTAL FOLLOWUP MGMT ;  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;S ADEREF=0,ADEREC=1,ADEWAI=0 ;SET IN CALLING OPTION

 +3       ;------->INITIALIZE

 +4        IF '$DATA(ADEREF)!'$DATA(ADEREC)!'$DATA(ADEWAI)

               QUIT

           SET ADEINT=0

           SET $PIECE(ADELIN,"*",79)=""

 +5        SET ADETYP=$SELECT(ADEREF:"rf",ADEREC:"rc",ADEWAI:"w")

 +6        DO ^XBKVAR

           IF '$DATA(DUZ(2))

               WRITE !,"DIVISION NOT SET IN USER FILE -- CONTACT SITE MANAGER OR ISC"

               QUIT

 +7        IF DUZ(2)=0

               WRITE !,"DIVISION SET TO ZERO (UNIVERSAL). DIVISION MUST BE SET TO ONE OF THE ",!,"SITES IN THE DENTAL SITE PARAMETER FILE. -- CONTACT SITE MANAGER"

               QUIT

ONE       ;------->RESET CONSTANT FOLLOWUP SUBTYPE

 +1       ;        RETURN ADESUB=DFN IN ^ADETYP(

 +2        DO RESET^ADEMNG1

           IF Y<1

               GOTO END

TWO       ;------->LOOK UP A PATIENT

 +1       ;        RETURN ADENEWM=1 IF NEW =0 IF EDIT

 +2        DO PTLOOK^ADEMNG1

           IF Y<1

               GOTO ONE

FOUR      ;------->CHECK IF ALREADY ON LIST ;***ASK IF SHOULD BE REMOVED

 +1        IF $DATA(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB))

               DO MOD

ADDR      ;------->EDIT ADDRESS

 +1        DO P2^ADEMNG1

 +2        IF $DATA(Y)

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

               HANG 2

               IF ADEINT

                   GOTO END1

               KILL ^ADEUTL("ADELOCK",ADEPAT)

               GOTO TWO

FIVE      ;------->COLLECT FOLLOWUP INFO

 +1        DO ^ADEMNG3

SIX       ;------->WRITE DATA TO DISK, QUIT IF CALLED INTERNALLY

 +1        IF Y

               DO ^ADEMNG6

           IF ADEINT

               GOTO END1

SEVEN     ;------->GET ANOTHER PATIENT

 +1        KILL ^ADEUTL("ADELOCK",ADEPAT)

 +2        KILL ADENEWM,ADEPAT,ADEPRI,ADEMPRO,ADEMPROD,ADEMDAT,ADEMACT,ADEMDFN,ADENOD

 +3        GOTO TWO

END        DO ^ADECLS

           KILL ADELIN

END1       KILL ADEDICS,ADEFUNC,ADEINT,ADEMDAT,ADEMDFN,ADEMDUZ,ADEMPRO,ADEMPROD,ADENEWM,ADEPRI,ADEREC,ADEREF,ADESUB,ADESUBN,ADETITL,ADETYP,ADEWAI

 +1        QUIT

MOD       ;------->LOAD LOCALS WITH EDIT DATA

 +1        WRITE !?5,*7,$PIECE(^DPT(ADEPAT,0),U)," IS ALREADY ON THE ",$PIECE(^ADETYP(ADESUB,0),U)," ",$SELECT(ADEWAI:"WAITING",ADEREC:"RECALL",1:"REFERRAL")," LIST!"

 +2        SET ADENOD=^ADEFOL(ADEMDFN,0)

           SET ADEPRI=$PIECE(ADENOD,U,5)

           SET ADEMDAT=$PIECE(ADENOD,U,3)

           SET ADEMPROD=$PIECE(ADENOD,U,7)

           SET ADEMACT=$PIECE(ADENOD,U,4)

 +3        FOR J="ADEMDAT","ADEMACT"

               SET Y=@J

               XECUTE ^DD("DD")

               SET @J=Y

 +4       ;IHS/HMW ADDED CONDITIONAL SET 6-20-90

           IF ADEMPROD'=""

               IF $DATA(^DIC(16,ADEMPROD,0))

                   SET ADEMPRO=$PIECE(^DIC(16,ADEMPROD,0),U)

Z          SET ADEPRI=$SELECT(ADEPRI="u":"URGENT",ADEPRI="r":"ROUTINE",1:"HIGH")

 +1        QUIT

EN        ;EP

 +1       ;------->GET A FOLLOWUP SUBTYPE IF CALLED INTERNALLY --ENDO,PROS

 +2       ;        THIS IS INTERNAL ENTRY POINT -- TYPE SET BY CALLING ROUTINE

 +3       ;        RETURN ADENEWM=1 IF NEW, 0 IF EDIT

 +4        SET ADEINT=1

           DO R2^ADEMNG1

           IF Y<1

               GOTO END1

 +5        SET ADENEWM=1

 +6        IF $DATA(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB))

               SET ADEMDFN=$ORDER(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB,0))

               SET ADENEWM=0

               DO MOD

 +7        GOTO ADDR

ADEMNG.m