ADEGRL32.m

ADEGRL32 ; IHS/HQT/MJL - DENTAL ENTRY PART 32 ;  [ 03/24/1999   9:04 AM ]

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

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

VERIFY ;EP

 K DIC S DIC="^AUTTADA(",DIC(0)="EZQ"

 S DIC("S")="I '+$P(^AUTTADA(Y,0),U,8)"

 D ^DIC

 K DIC

 I Y=-1 K Y S ADEY=0 Q

 S ADECOD=Y(0,0),ADEDES(ADECOD)=$P(Y(0),U,6)

 I ($D(ADEV("9130")))!($D(ADEV("9140"))) W *7,!,"Delete BROKEN or CANCELLED APPOINTMENT CODES before entering more codes." D CON^ADEGRL3 K Y S ADEY=0 Q

 ;/IHS/OIT/GAB 11.2014 Patch #26 added below line to update 9986 & 9987 for 2015 code updates (will eventually replace 9130 & 9140)

 I ($D(ADEV("9986")))!($D(ADEV("9987"))) W *7,!,"Delete BROKEN or CANCELLED APPOINTMENT CODES before entering more codes." D CON^ADEGRL3 K Y S ADEY=0 Q

 ;I ADECOD="0000" K ADEV("0190"),ADEDES("0190"),Y S ADEV("0000")="1^" S ADEY=0 Q

 I ADECOD="0000"!(ADECOD="0190") D  Q

 . N ADEJ

 . S ADEJ=$$FYVIS^ADEGRL4(ADEPAT,ADEVDATE)

 . I 'ADEJ,ADECOD="0000" K ADEV("0190"),ADEDES("0190"),Y S ADEV("0000")="1^",ADEY=0 Q

 . I 'ADEJ,ADECOD="0190" K ADEV("0000"),ADEDES("0000"),Y S ADEV("0190")="1^",ADEY=0 Q

 . S ADEV($P(ADEJ,U,2))="1^",ADEDES($P(ADEJ,U,2))=$P(ADEJ,U,3)

 . S ADEY=0 Q

 ;I ADECOD="0190" K ADEV("0000"),ADEDES("0000"),Y S ADEV("0190")="1^" S ADEY=0 Q

 I ADECOD="0190" D  Q

 . I '$$FYVIS^ADEGRL4(ADEPAT,ADEVDATE) K ADEV("0000"),ADEDES("0000"),Y S ADEV("0190")="1^"

 . S ADEY=0 Q

 ;/IHS/OIT/GAB 11.2014 Patch #26 Removed below line to replace 9130 & 9140 with 2015 codes 9986 & 9987

 ;I (ADECOD="9140")!(ADECOD="9130") K ADEV,ADEDES,Y S ADEV(ADECOD)="1^",ADEDES(ADECOD)=$S(ADECOD="9140":"CANCELLED",1:"BROKEN")_" APPT" S ADEY=0 Q  ;IHS/HMW **2**

 ;/IHS/OIT/GAB 11.2014 Patch #26 Added below line to change to 9986 & 9987 for 2015 code updates

 I (ADECOD="9140")!(ADECOD="9130")!(ADECOD="9987")!(ADECOD="9986") K ADEV,ADEDES,Y S ADEV(ADECOD)="1^",ADEDES(ADECOD)=$S(ADECOD="9987":"CANCELLED",1:"MISSED")_" APPT" S ADEY=0 Q  ;IHS/HMW **2**

 Q

ADEGRL32  ; IHS/HQT/MJL - DENTAL ENTRY PART 32 ;  [ 03/24/1999   9:04 AM ]

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

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

VERIFY    ;EP

 +1        KILL DIC

           SET DIC="^AUTTADA("

           SET DIC(0)="EZQ"

 +2        SET DIC("S")="I '+$P(^AUTTADA(Y,0),U,8)"

 +3        DO ^DIC

 +4        KILL DIC

 +5        IF Y=-1

               KILL Y

               SET ADEY=0

               QUIT 

 +6        SET ADECOD=Y(0,0)

           SET ADEDES(ADECOD)=$PIECE(Y(0),U,6)

 +7        IF ($DATA(ADEV("9130")))!($DATA(ADEV("9140")))

               WRITE *7,!,"Delete BROKEN or CANCELLED APPOINTMENT CODES before entering more codes."

               DO CON^ADEGRL3

               KILL Y

               SET ADEY=0

               QUIT 

 +8       ;/IHS/OIT/GAB 11.2014 Patch #26 added below line to update 9986 & 9987 for 2015 code updates (will eventually replace 9130 & 9140)

 +9        IF ($DATA(ADEV("9986")))!($DATA(ADEV("9987")))

               WRITE *7,!,"Delete BROKEN or CANCELLED APPOINTMENT CODES before entering more codes."

               DO CON^ADEGRL3

               KILL Y

               SET ADEY=0

               QUIT 

 +10      ;I ADECOD="0000" K ADEV("0190"),ADEDES("0190"),Y S ADEV("0000")="1^" S ADEY=0 Q

 +11       IF ADECOD="0000"!(ADECOD="0190")

               Begin DoDot:1

 +12               NEW ADEJ

 +13               SET ADEJ=$$FYVIS^ADEGRL4(ADEPAT,ADEVDATE)

 +14               IF 'ADEJ

                       IF ADECOD="0000"

                           KILL ADEV("0190"),ADEDES("0190"),Y

                           SET ADEV("0000")="1^"

                           SET ADEY=0

                           QUIT 

 +15               IF 'ADEJ

                       IF ADECOD="0190"

                           KILL ADEV("0000"),ADEDES("0000"),Y

                           SET ADEV("0190")="1^"

                           SET ADEY=0

                           QUIT 

 +16               SET ADEV($PIECE(ADEJ,U,2))="1^"

                   SET ADEDES($PIECE(ADEJ,U,2))=$PIECE(ADEJ,U,3)

 +17               SET ADEY=0

                   QUIT 

               End DoDot:1

               QUIT 

 +18      ;I ADECOD="0190" K ADEV("0000"),ADEDES("0000"),Y S ADEV("0190")="1^" S ADEY=0 Q

 +19       IF ADECOD="0190"

               Begin DoDot:1

 +20               IF '$$FYVIS^ADEGRL4(ADEPAT,ADEVDATE)

                       KILL ADEV("0000"),ADEDES("0000"),Y

                       SET ADEV("0190")="1^"

 +21               SET ADEY=0

                   QUIT 

               End DoDot:1

               QUIT 

 +22      ;/IHS/OIT/GAB 11.2014 Patch #26 Removed below line to replace 9130 & 9140 with 2015 codes 9986 & 9987

 +23      ;I (ADECOD="9140")!(ADECOD="9130") K ADEV,ADEDES,Y S ADEV(ADECOD)="1^",ADEDES(ADECOD)=$S(ADECOD="9140":"CANCELLED",1:"BROKEN")_" APPT" S ADEY=0 Q  ;IHS/HMW **2**

 +24      ;/IHS/OIT/GAB 11.2014 Patch #26 Added below line to change to 9986 & 9987 for 2015 code updates

 +25      ;IHS/HMW **2**

           IF (ADECOD="9140")!(ADECOD="9130")!(ADECOD="9987")!(ADECOD="9986")

               KILL ADEV,ADEDES,Y

               SET ADEV(ADECOD)="1^"

               SET ADEDES(ADECOD)=$SELECT(ADECOD="9987":"CANCELLED",1:"MISSED")_" APPT"

               SET ADEY=0

               QUIT 

 +26       QUIT