Routine: ADEGRL1

ADEGRL1 ; IHS/HQT/MJL - DENTAL ENTRY PART 2 ;12:36 PM  [ 03/26/2003  11:22 AM ]

 ;;6.0;ADE;**26**;APRIL 1999;Build 13

 ;IHS/MFD FAC SUBRTN REDONE FOR MULTI-FACILITY LOOKUP PER DG/OHPRD

 ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26

FAC ;EP

 W !,"Select Location of Encounter: ",$S($D(ADEFAC):ADEFAC_"// ",1:"") R X:DTIME

 K DIC,Y S DIC="^ADEPARAM(DUZ(2),1,",DIC(0)="EZMQ" D ^DIC K DIC Q:"^"[X

 I Y<0 W !,*7,"Only facilities entered into the LOCAL FACILITY field of the DENTAL SITE",!,"PARAMETERS file may be selected." G FAC

 S ADETMP=+Y(0)

 K AUPNLK("ALL") D UNIV^ADEGRL0 G:'Y FAC

 S (ADEFACD,DUZ(2))=+Y(0),ADEFAC=Y(0,0)

REPD K DIC,Y S DIC=6,DIC("A")="Select Attending Dentist: ",DIC(0)="MAEZQ"

 S DIC("S")="D SCRN1^ADEGRL1"

 S:$D(ADEREP) DIC("B")=ADEREP D ^DIC K DIC Q:Y=-1

 S (ADEREPD)=$P(Y,U),(ADEREP)=Y(0,0)

 ;I $D(^DIC(6,Y,9999999)),$P(^DIC(6,Y,9999999),U)=$S(ADECON:"2",1:"1"),$P(^DIC(6,Y,0),U,4)]"",^DIC(7,$P(^DIC(6,Y,0),U,4),9999999)=52,$P(^DIC(16,Y,0),U,9)]""

SCRN1 I $D(^DIC(6,Y,9999999)),$S(ADECON:"2",1:"138")[$P(^DIC(6,Y,9999999),U),$P(^DIC(6,Y,0),U,4)]"",+^DIC(7,$P(^DIC(6,Y,0),U,4),9999999)=52,$P(^DIC(16,Y,0),U,9)]""

 E  Q

 I $S('$D(^DIC(6,Y,"I")):1,^DIC(6,Y,"I")']"":1,1:0)

SCRN2 I $P(^DIC(6,Y,0),U,4)]"",$D(^DIC(7,$P(^DIC(6,Y,0),U,4),9999999)),+^(9999999)=46

 E  Q

 I $S('$D(^DIC(6,Y,"I")):1,^DIC(6,Y,"I")']"":1,1:0)

LINE W $E(ADELIN,1,40-($L(ADETITL)/2)),ADETITL,$E(ADELIN,1,39-($L(ADETITL)/2)) Q

RESET ;EP

 D ^ADECLS

 S:'$D(ADEPRO) (ADEPRO,ADEPROD)=""

 S:'$D(ADEREP) (ADEREP,ADEREPD)=""

 S:ADEDIR&(ADEREP="") ADEREPD=$P(^ADEPARAM($P(^AUTTSITE(1,0),U),0),U,3)

 I ADEDIR,ADEREPD]"" S Y=ADEREPD D SCRN1 S:'$T (ADEREPD,ADEREP)=""

 S:ADEREPD]"" ADEREP=$P(^DIC(16,ADEREPD,0),U)

RESET3 N DIR

 ;S ADEFACD=$O(^ADEPARAM(0))  ;IHS/NPO/FBD-3/26/2003-ORIGINAL LINE - COMMENTED OUT

 S ADEFACD=DUZ(2)  ;IHS/NPO/FBD-3/26/2003-PICKING THE RIGHT FACILITY

 S DIR(0)="PO^ADEPARAM(ADEFACD,1,:QEMZ"

 S DIR("A")="Select Location of Encounter"

 ;     ENTER A LOCATION

 S DIR("A",1)="DENTAL VISIT DATA ENTRY STARTUP SCREEN"

 S DIR("A",2)=""

 S DIR("A",3)="The LOCATION OF ENCOUNTER selected from those listed below"

 S DIR("A",4)="applies to every dental visit until you change it to another location.  You"

 S DIR("A",4.1)="may change the LOCATION before selecting the patient name for each visit."

 S DIR("A",5)=""

 S DIR("A",6)="DENTAL CARE PROVIDERS are selected from the CURRENT VISIT"

 S DIR("A",7)="ENTRIES TABLE.  Provider names can be edited to apply only to the"

 S DIR("A",8)="current visit data or to subsequent visits entered during this session."

 S DIR("A",9)=""

 ;/IHS/OIT/GAB 12.2014 Changed below for 2015 Code Updates patch #26

 S DIR("A",10)="*************Notice**************"

 S DIR("A",11)="Cancelled and Broken appointment codes have been changed to the following:  "

 S DIR("A",12)="  Missed Appointment (9986) has replaced code (9130)"

 S DIR("A",13)="  Cancelled Appointment (9987) has replaced code (9140)"

 S DIR("A",14)=""

 S DIR("A",15)=""

RESET4 D ^DIR

 I $$HAT()!(X="")!(X[U) K DIR Q  ;S Y=-1 Q

 I Y<1 G RESET4

 S ADEFACD=$P(Y,U,2),ADEFAC=Y(0,0) ;Q  ;,Y=1 Q

 I '$$UNIV^ADEGRL0(ADEFACD) G RESET3

HAT() ;EP - Returns 1 if dtout,duout,dirout

 I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q 1

Q 0

PTLOOK ;EP

 K DIC,Y,ADEPAT

 W !,"Enter the Health Record Number of a Patient: "

 R X:DTIME

 I '$T!(X="")!(X["^") S Y=-1 Q

 I X["?" S XQH="ADE-DVIS-PATIENT" D EN^XQH K XQH G PTLOOK

 S DIC="^AUPNPAT(",DIC(0)="MEZQ" D ^DIC K DIC

 G:Y<1 PTLOOK

 S ADEPAT=$P(Y,U)

 I $D(^ADEUTL("ADELOCK",ADEPAT)) W !!,"PATIENT'S RECORD CURRENTLY BEING EDITED.  TRY LATER." H 3 K ADEPAT,X G PTLOOK

 S ^ADEUTL("ADELOCK",ADEPAT)=""

 S Y=1 Q

ADEGRL1   ; IHS/HQT/MJL - DENTAL ENTRY PART 2 ;12:36 PM  [ 03/26/2003  11:22 AM ]

 +1       ;;6.0;ADE;**26**;APRIL 1999;Build 13

 +2       ;IHS/MFD FAC SUBRTN REDONE FOR MULTI-FACILITY LOOKUP PER DG/OHPRD

 +3       ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26

FAC       ;EP

 +1        WRITE !,"Select Location of Encounter: ",$SELECT($DATA(ADEFAC):ADEFAC_"// ",1:"")

           READ X:DTIME

 +2        KILL DIC,Y

           SET DIC="^ADEPARAM(DUZ(2),1,"

           SET DIC(0)="EZMQ"

           DO ^DIC

           KILL DIC

           IF "^"[X

               QUIT

 +3        IF Y<0

               WRITE !,*7,"Only facilities entered into the LOCAL FACILITY field of the DENTAL SITE",!,"PARAMETERS file may be selected."

               GOTO FAC

 +4        SET ADETMP=+Y(0)

 +5        KILL AUPNLK("ALL")

           DO UNIV^ADEGRL0

           IF 'Y

               GOTO FAC

 +6        SET (ADEFACD,DUZ(2))=+Y(0)

           SET ADEFAC=Y(0,0)

 +7        QUIT

REPD       KILL DIC,Y

           SET DIC=6

           SET DIC("A")="Select Attending Dentist: "

           SET DIC(0)="MAEZQ"

 +1        SET DIC("S")="D SCRN1^ADEGRL1"

 +2        IF $DATA(ADEREP)

               SET DIC("B")=ADEREP

           DO ^DIC

           KILL DIC

           IF Y=-1

               QUIT

 +3        SET (ADEREPD)=$PIECE(Y,U)

           SET (ADEREP)=Y(0,0)

 +4        QUIT

 +5       ;I $D(^DIC(6,Y,9999999)),$P(^DIC(6,Y,9999999),U)=$S(ADECON:"2",1:"1"),$P(^DIC(6,Y,0),U,4)]"",^DIC(7,$P(^DIC(6,Y,0),U,4),9999999)=52,$P(^DIC(16,Y,0),U,9)]""

SCRN1      IF $DATA(^DIC(6,Y,9999999))

               IF $SELECT(ADECON:"2",1:"138")[$PIECE(^DIC(6,Y,9999999),U)

                   IF $PIECE(^DIC(6,Y,0),U,4)]""

                       IF +^DIC(7,$PIECE(^DIC(6,Y,0),U,4),9999999)=52

                           IF $PIECE(^DIC(16,Y,0),U,9)]""

 +1       IF '$TEST

               QUIT

 +2        IF $SELECT('$DATA(^DIC(6,Y,"I")):1,^DIC(6,Y,"I")']"":1,1:0)

 +3        QUIT

 +4       ;

SCRN2      IF $PIECE(^DIC(6,Y,0),U,4)]""

               IF $DATA(^DIC(7,$PIECE(^DIC(6,Y,0),U,4),9999999))

                   IF +^(9999999)=46

 +1       IF '$TEST

               QUIT

 +2        IF $SELECT('$DATA(^DIC(6,Y,"I")):1,^DIC(6,Y,"I")']"":1,1:0)

 +3        QUIT

LINE       WRITE $EXTRACT(ADELIN,1,40-($LENGTH(ADETITL)/2)),ADETITL,$EXTRACT(ADELIN,1,39-($LENGTH(ADETITL)/2))

           QUIT

RESET     ;EP

 +1        DO ^ADECLS

 +2        IF '$DATA(ADEPRO)

               SET (ADEPRO,ADEPROD)=""

 +3        IF '$DATA(ADEREP)

               SET (ADEREP,ADEREPD)=""

 +4        IF ADEDIR&(ADEREP="")

               SET ADEREPD=$PIECE(^ADEPARAM($PIECE(^AUTTSITE(1,0),U),0),U,3)

 +5        IF ADEDIR

               IF ADEREPD]""

                   SET Y=ADEREPD

                   DO SCRN1

                   IF '$TEST

                       SET (ADEREPD,ADEREP)=""

 +6        IF ADEREPD]""

               SET ADEREP=$PIECE(^DIC(16,ADEREPD,0),U)

RESET3     NEW DIR

 +1       ;S ADEFACD=$O(^ADEPARAM(0))  ;IHS/NPO/FBD-3/26/2003-ORIGINAL LINE - COMMENTED OUT

 +2       ;IHS/NPO/FBD-3/26/2003-PICKING THE RIGHT FACILITY

           SET ADEFACD=DUZ(2)

 +3        SET DIR(0)="PO^ADEPARAM(ADEFACD,1,:QEMZ"

 +4        SET DIR("A")="Select Location of Encounter"

 +5       ;     ENTER A LOCATION

 +6        SET DIR("A",1)="DENTAL VISIT DATA ENTRY STARTUP SCREEN"

 +7        SET DIR("A",2)=""

 +8        SET DIR("A",3)="The LOCATION OF ENCOUNTER selected from those listed below"

 +9        SET DIR("A",4)="applies to every dental visit until you change it to another location.  You"

 +10       SET DIR("A",4.1)="may change the LOCATION before selecting the patient name for each visit."

 +11       SET DIR("A",5)=""

 +12       SET DIR("A",6)="DENTAL CARE PROVIDERS are selected from the CURRENT VISIT"

 +13       SET DIR("A",7)="ENTRIES TABLE.  Provider names can be edited to apply only to the"

 +14       SET DIR("A",8)="current visit data or to subsequent visits entered during this session."

 +15       SET DIR("A",9)=""

 +16      ;/IHS/OIT/GAB 12.2014 Changed below for 2015 Code Updates patch #26

 +17       SET DIR("A",10)="*************Notice**************"

 +18       SET DIR("A",11)="Cancelled and Broken appointment codes have been changed to the following:  "

 +19       SET DIR("A",12)="  Missed Appointment (9986) has replaced code (9130)"

 +20       SET DIR("A",13)="  Cancelled Appointment (9987) has replaced code (9140)"

 +21       SET DIR("A",14)=""

 +22       SET DIR("A",15)=""

RESET4     DO ^DIR

 +1       ;S Y=-1 Q

           IF $$HAT()!(X="")!(X[U)

               KILL DIR

               QUIT

 +2        IF Y<1

               GOTO RESET4

 +3       ;Q  ;,Y=1 Q

           SET ADEFACD=$PIECE(Y,U,2)

           SET ADEFAC=Y(0,0)

 +4        IF '$$UNIV^ADEGRL0(ADEFACD)

               GOTO RESET3

 +5        QUIT

 +6       ;

HAT()     ;EP - Returns 1 if dtout,duout,dirout

 +1        IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               QUIT 1

 +2        QUIT 0

PTLOOK    ;EP

 +1        KILL DIC,Y,ADEPAT

 +2        WRITE !,"Enter the Health Record Number of a Patient: "

 +3        READ X:DTIME

 +4        IF '$TEST!(X="")!(X["^")

               SET Y=-1

               QUIT

 +5        IF X["?"

               SET XQH="ADE-DVIS-PATIENT"

               DO EN^XQH

               KILL XQH

               GOTO PTLOOK

 +6        SET DIC="^AUPNPAT("

           SET DIC(0)="MEZQ"

           DO ^DIC

           KILL DIC

 +7        IF Y<1

               GOTO PTLOOK

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

 +9        IF $DATA(^ADEUTL("ADELOCK",ADEPAT))

               WRITE !!,"PATIENT'S RECORD CURRENTLY BEING EDITED.  TRY LATER."

               HANG 3

               KILL ADEPAT,X

               GOTO PTLOOK

 +10       SET ^ADEUTL("ADELOCK",ADEPAT)=""

 +11       SET Y=1

           QUIT

ADEGRL1.m