Routine: ADEGRL6

ADEGRL6 ; IHS/HQT/MJL - FILE DENTAL VISIT DATA ;10:12 PM  [ 03/24/1999   9:04 AM ]

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

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

 K DIC

 ;S J="" F  S J=$O(ADEV(J)) Q:'J  W !,"ADEV(",J,")=",ADEV(J)

 ;R X ;IHS/HMW 5-12-90 REMOVE AFTER TESTING

 I ADENOUPD G END

 I ADENEWVS,'$D(ADEV) G END

 ;------->QUEUE WRITES IF BACKGROUND ENABLED, TASKMAN RUNNING

 G ZTM ;IHS/SET/HMW 2-6-2003 **12** Background writes disabled

 G:$P(^ADEPARAM(+^AUTTSITE(1,0),0),U,4)'="y" ZTM

 I $S($D(^%ZTSCH("RUN"))[0:1,^("RUN")-$H:1,1:$P($H,",",2)-150>$P(^("RUN"),",",2)) W *7,!,"TASK MANAGER NOT RUNNING -- BACKGROUND WRITES DISABLED",!,"PLEASE WAIT WHILE I UPDATE THE DENTAL FILE",! G ZTM

 D ^ADEQUE

 ; ^ADEUTL is a transient, non-fileman working global

 I '$D(^ADEUTL("ADEDQUE")) S ^ADEUTL("ADEDQUE")=1,ZTRTN="^ADEDQUE",ZTDTH=$H,ZTDESC="DENTAL DISC WRITES",ZTIO="" D ^%ZTLOAD

 G END1

ZTM ;------->IF NEW VISIT CREATE ENTRY IN ADEPCD (ENTRY POINT FOR ^ADEDQUE)

 I ADENEWVS D NEWVS

 ;------->IF MODIFICATION OF EXISTING VISIT DELETE OLD SVCS DATA

 I 'ADENEWVS D SDEL

 ;------->NEW LOCATION AND PROVIDER DATA INTO ADEPCD

 K DIE,DA,DR D STUFA

 ;------->NEW SERVICE DATA INTO ADEPCD

 K DIE,DA,DR D STUFB

 ;------->FAILED APPT & FOLLOWUP PROCESSING

 ;/IHS/OIT/GAB 11.2014 Patch #26 modified below line to add 2015 codes 9986 & 9987 (do not remove old codes yet)

 ;I ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))) D FAIL,FOL G END

 I ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))!$D(ADEV("9986"))!$D(ADEV("9987"))) D FAIL,FOL G END

 ;------->UPDATE PCC FILES

 D ^ADEAPC

END K ^ADEUTL("ADELOCK",ADEPAT)

END1 K ADEFLG,ADENOTE,ADEVDATE,ADENOUPD,ADENEWVS,ADEPAT,ADERDNM,ADERDNMD,ADELOE,ADELOED,ADEPVNM,ADEPVNMD,ADEV,ADEDES,ADEPNM,ADEHRN,ADEDENT,ADETITL,ADECOD,ADEDEL,ADEOP,ADECNT,ADEQTY,ADEDEF,ADEI,ADETCH,ADETCHF,ADETFE

 K ADEHXC,ADEHXO,ADEHXF

NEWVS S DIC="^ADEPCD(",DIC(0)="LZ",X=ADEPAT,DIC("DR")="1///"_ADEVDATE K DD,DO D FILE^DICN S ADEDFN=$P(Y,U)

SDEL ;

 S DIE="^ADEPCD(",DA=ADEDFN,DR(2,9002007.01)=".01///@",ADESVC=0

SDEL1 S ADESVC=$O(^ADEPCD(ADEDFN,"ADA",ADESVC))

 I ADESVC="" K ADESVC,DR,DIE,DA Q

 S DR="100///`"_ADESVC D ^DIE G SDEL1

STUFA S DA=ADEDFN,DR="2///`"_ADELOED_";"_$S(ADEPVNMD]"":"4///`"_ADEPVNMD_";",1:"")_$S(ADENOTE]"":"6///^S X=ADENOTE;",1:"")_$S(ADECON:"7///"_ADETCH_";8///c;",1:"8///d;")_"3///`"_ADERDNMD,DIE="^ADEPCD(" D ^DIE Q

STUFB S DA(1)=ADEDFN

 S DIE="^ADEPCD(DA(1),""ADA"",",^ADEPCD(DA(1),"ADA",0)="^9002007.01IPA^^",ADEJ=0,DA=0

ROLL S ADEJ=$O(ADEV(ADEJ)) G:ADEJ="" RO1 S ADEI=$O(^AUTTADA("B",ADEJ,0))

RO1A S ADECNT=0 F DA=DA+1:1:DA+$P(ADEV(ADEJ),U) S ADECNT=ADECNT+1,DR=".01///`"_ADEI D RO1B S:ADECON DR=DR_";3///"_$P(ADEV(ADEJ),U,3) D ^DIE ;IHS/HMW 5-12-90

 G ROLL

RO1B I $P($P(ADEV(ADEJ),U,2),",",ADECNT)]"" S DR=DR_";2///`"_$P($P(ADEV(ADEJ),U,2),",",ADECNT)

 I $P($P(ADEV(ADEJ),U,4),",",ADECNT)]"" S DR=DR_";4///"_$P($P(ADEV(ADEJ),U,4),",",ADECNT)

 I $P($P(ADEV(ADEJ),U,5),",",ADECNT)]"" S DR=DR_";5///y"

RO1 S $P(^ADEPCD(ADEDFN,"ADA",0),U,3)=DA S $P(^(0),U,4)=DA

FAIL ;

 K DIC,DIE,DA,DR,X,Y

 I '$D(^ADEPAT(ADEPAT)) S DIC="^ADEPAT(",DIC(0)="LZ",X=ADEPAT,DINUM=X K DD,DO D FILE^DICN

 S DA(1)=ADEPAT

 S DIE="^ADEPAT(DA(1),""FA"","

 I $D(^ADEPAT(ADEPAT,"FA",0)) S DA=$P(^ADEPAT(ADEPAT,"FA",0),U,3)+1

 E  S ^ADEPAT(ADEPAT,"FA",0)="^9002010.22DA^^",DA=1

 ;/IHS/OIT/GAB 11.2014 Patch #26 Removed below and added the next line to include new code 9986 (do not remove old codes yet)

 ;S DR=".01///"_ADEVDATE_";1///"_$S($D(ADEV("9130")):"b",1:"c")

 S DR=".01///"_ADEVDATE_";1///"_$S($D(ADEV("9130")):"b",$D(ADEV("9986")):"b",1:"c")

 D ^DIE

 S $P(^ADEPAT(ADEPAT,"FA",0),U,3)=DA,$P(^ADEPAT(ADEPAT,"FA",0),U,4)=$P(^ADEPAT(ADEPAT,"FA",0),U,4)+1

FOL ;IF FAILED APPT SEND MESSG IF ON URGENT RECALL

 Q:'$D(^ADEFOL("TYPE",ADEPAT,"rc"))

 S ADETYP=0 F ADEQ=0:0 S ADETYP=$O(^ADEFOL("TYPE",ADEPAT,"rc",ADETYP)) Q:'+ADETYP  S ADEMDFN=0 F ADER=0:0 S ADEMDFN=$O(^ADEFOL("TYPE",ADEPAT,"rc",ADETYP,ADEMDFN)) Q:'+ADEMDFN  D MSG

 K ADETYP,ADEMDFN,ADEQ,ADER,XMB Q

MSG Q:'$D(^ADEFOL(ADEMDFN,0))

 K XMB

 I $P(^ADEFOL(ADEMDFN,0),U,5)="u" S XMB(1)=$P(^DPT(ADEPAT,0),U),XMB(2)=ADEVDATE I $P(^ADEFOL(ADEMDFN,0),U,7)]"",$D(^DIC(16,$P(^ADEFOL(ADEMDFN,0),U,7),0)) S XMB(3)=$P(^DIC(16,$P(^ADEFOL(ADEMDFN,0),U,7),0),U)

 I $D(XMB) D

 . S XMB="ADECALL"

 . S XMDUZ="DENTAL RECALL SYSTEM"

 . D ^XMB

 . K XMB

ADEGRL6   ; IHS/HQT/MJL - FILE DENTAL VISIT DATA ;10:12 PM  [ 03/24/1999   9:04 AM ]

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

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

 +3        KILL DIC

 +4       ;S J="" F  S J=$O(ADEV(J)) Q:'J  W !,"ADEV(",J,")=",ADEV(J)

 +5       ;R X ;IHS/HMW 5-12-90 REMOVE AFTER TESTING

 +6        IF ADENOUPD

               GOTO END

 +7        IF ADENEWVS

               IF '$DATA(ADEV)

                   GOTO END

 +8       ;------->QUEUE WRITES IF BACKGROUND ENABLED, TASKMAN RUNNING

 +9       ;IHS/SET/HMW 2-6-2003 **12** Background writes disabled

           GOTO ZTM

 +10       IF $PIECE(^ADEPARAM(+^AUTTSITE(1,0),0),U,4)'="y"

               GOTO ZTM

 +11       IF $SELECT($DATA(^%ZTSCH("RUN"))[0:1,^("RUN")-$HOROLOG:1,1:$PIECE($HOROLOG,",",2)-150>$PIECE(^("RUN"),",",2))

               WRITE *7,!,"TASK MANAGER NOT RUNNING -- BACKGROUND WRITES DISABLED",!,"PLEASE WAIT WHILE I UPDATE THE DENTAL FILE",!

               GOTO ZTM

 +12       DO ^ADEQUE

 +13      ; ^ADEUTL is a transient, non-fileman working global

 +14       IF '$DATA(^ADEUTL("ADEDQUE"))

               SET ^ADEUTL("ADEDQUE")=1

               SET ZTRTN="^ADEDQUE"

               SET ZTDTH=$HOROLOG

               SET ZTDESC="DENTAL DISC WRITES"

               SET ZTIO=""

               DO ^%ZTLOAD

 +15       GOTO END1

ZTM       ;------->IF NEW VISIT CREATE ENTRY IN ADEPCD (ENTRY POINT FOR ^ADEDQUE)

 +1        IF ADENEWVS

               DO NEWVS

 +2       ;------->IF MODIFICATION OF EXISTING VISIT DELETE OLD SVCS DATA

 +3        IF 'ADENEWVS

               DO SDEL

 +4       ;------->NEW LOCATION AND PROVIDER DATA INTO ADEPCD

 +5        KILL DIE,DA,DR

           DO STUFA

 +6       ;------->NEW SERVICE DATA INTO ADEPCD

 +7        KILL DIE,DA,DR

           DO STUFB

 +8       ;------->FAILED APPT & FOLLOWUP PROCESSING

 +9       ;/IHS/OIT/GAB 11.2014 Patch #26 modified below line to add 2015 codes 9986 & 9987 (do not remove old codes yet)

 +10      ;I ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))) D FAIL,FOL G END

 +11       IF ADENEWVS

               IF ($DATA(ADEV("9130"))!$DATA(ADEV("9140"))!$DATA(ADEV("9986"))!$DATA(ADEV("9987")))

                   DO FAIL

                   DO FOL

                   GOTO END

 +12      ;------->UPDATE PCC FILES

 +13       DO ^ADEAPC

END        KILL ^ADEUTL("ADELOCK",ADEPAT)

END1       KILL ADEFLG,ADENOTE,ADEVDATE,ADENOUPD,ADENEWVS,ADEPAT,ADERDNM,ADERDNMD,ADELOE,ADELOED,ADEPVNM,ADEPVNMD,ADEV,ADEDES,ADEPNM,ADEHRN,ADEDENT,ADETITL,ADECOD,ADEDEL,ADEOP,ADECNT,ADEQTY,ADEDEF,ADEI,ADETCH,ADETCHF,ADETFE

 +1        KILL ADEHXC,ADEHXO,ADEHXF

 +2        QUIT

 +3       ;

NEWVS      SET DIC="^ADEPCD("

           SET DIC(0)="LZ"

           SET X=ADEPAT

           SET DIC("DR")="1///"_ADEVDATE

           KILL DD,DO

           DO FILE^DICN

           SET ADEDFN=$PIECE(Y,U)

 +1        QUIT

 +2       ;

SDEL      ;

 +1        SET DIE="^ADEPCD("

           SET DA=ADEDFN

           SET DR(2,9002007.01)=".01///@"

           SET ADESVC=0

SDEL1      SET ADESVC=$ORDER(^ADEPCD(ADEDFN,"ADA",ADESVC))

 +1        IF ADESVC=""

               KILL ADESVC,DR,DIE,DA

               QUIT

 +2        SET DR="100///`"_ADESVC

           DO ^DIE

           GOTO SDEL1

STUFA      SET DA=ADEDFN

           SET DR="2///`"_ADELOED_";"_$SELECT(ADEPVNMD]"":"4///`"_ADEPVNMD_";",1:"")_$SELECT(ADENOTE]"":"6///^S X=ADENOTE;",1:"")_$SELECT(ADECON:"7///"_ADETCH_";8///c;",1:"8///d;")_"3///`"_ADERDNMD

           SET DIE="^ADEPCD("

           DO ^DIE

           QUIT

STUFB      SET DA(1)=ADEDFN

 +1        SET DIE="^ADEPCD(DA(1),""ADA"","

           SET ^ADEPCD(DA(1),"ADA",0)="^9002007.01IPA^^"

           SET ADEJ=0

           SET DA=0

ROLL       SET ADEJ=$ORDER(ADEV(ADEJ))

           IF ADEJ=""

               GOTO RO1

           SET ADEI=$ORDER(^AUTTADA("B",ADEJ,0))

RO1A      ;IHS/HMW 5-12-90

           SET ADECNT=0

           FOR DA=DA+1:1:DA+$PIECE(ADEV(ADEJ),U)

               SET ADECNT=ADECNT+1

               SET DR=".01///`"_ADEI

               DO RO1B

               IF ADECON

                   SET DR=DR_";3///"_$PIECE(ADEV(ADEJ),U,3)

               DO ^DIE

 +1        GOTO ROLL

RO1B       IF $PIECE($PIECE(ADEV(ADEJ),U,2),",",ADECNT)]""

               SET DR=DR_";2///`"_$PIECE($PIECE(ADEV(ADEJ),U,2),",",ADECNT)

 +1        IF $PIECE($PIECE(ADEV(ADEJ),U,4),",",ADECNT)]""

               SET DR=DR_";4///"_$PIECE($PIECE(ADEV(ADEJ),U,4),",",ADECNT)

 +2        IF $PIECE($PIECE(ADEV(ADEJ),U,5),",",ADECNT)]""

               SET DR=DR_";5///y"

 +3        QUIT

RO1        SET $PIECE(^ADEPCD(ADEDFN,"ADA",0),U,3)=DA

           SET $PIECE(^(0),U,4)=DA

 +1        QUIT

FAIL      ;

 +1        KILL DIC,DIE,DA,DR,X,Y

 +2        IF '$DATA(^ADEPAT(ADEPAT))

               SET DIC="^ADEPAT("

               SET DIC(0)="LZ"

               SET X=ADEPAT

               SET DINUM=X

               KILL DD,DO

               DO FILE^DICN

 +3        SET DA(1)=ADEPAT

 +4        SET DIE="^ADEPAT(DA(1),""FA"","

 +5        IF $DATA(^ADEPAT(ADEPAT,"FA",0))

               SET DA=$PIECE(^ADEPAT(ADEPAT,"FA",0),U,3)+1

 +6       IF '$TEST

               SET ^ADEPAT(ADEPAT,"FA",0)="^9002010.22DA^^"

               SET DA=1

 +7       ;/IHS/OIT/GAB 11.2014 Patch #26 Removed below and added the next line to include new code 9986 (do not remove old codes yet)

 +8       ;S DR=".01///"_ADEVDATE_";1///"_$S($D(ADEV("9130")):"b",1:"c")

 +9        SET DR=".01///"_ADEVDATE_";1///"_$SELECT($DATA(ADEV("9130")):"b",$DATA(ADEV("9986")):"b",1:"c")

 +10       DO ^DIE

 +11       SET $PIECE(^ADEPAT(ADEPAT,"FA",0),U,3)=DA

           SET $PIECE(^ADEPAT(ADEPAT,"FA",0),U,4)=$PIECE(^ADEPAT(ADEPAT,"FA",0),U,4)+1

 +12       QUIT

FOL       ;IF FAILED APPT SEND MESSG IF ON URGENT RECALL

 +1        IF '$DATA(^ADEFOL("TYPE",ADEPAT,"rc"))

               QUIT

 +2        SET ADETYP=0

           FOR ADEQ=0:0

               SET ADETYP=$ORDER(^ADEFOL("TYPE",ADEPAT,"rc",ADETYP))

               IF '+ADETYP

                   QUIT

               SET ADEMDFN=0

               FOR ADER=0:0

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

                   IF '+ADEMDFN

                       QUIT

                   DO MSG

 +3        KILL ADETYP,ADEMDFN,ADEQ,ADER,XMB

           QUIT

MSG        IF '$DATA(^ADEFOL(ADEMDFN,0))

               QUIT

 +1        KILL XMB

 +2        IF $PIECE(^ADEFOL(ADEMDFN,0),U,5)="u"

               SET XMB(1)=$PIECE(^DPT(ADEPAT,0),U)

               SET XMB(2)=ADEVDATE

               IF $PIECE(^ADEFOL(ADEMDFN,0),U,7)]""

                   IF $DATA(^DIC(16,$PIECE(^ADEFOL(ADEMDFN,0),U,7),0))

                       SET XMB(3)=$PIECE(^DIC(16,$PIECE(^ADEFOL(ADEMDFN,0),U,7),0),U)

 +3        IF $DATA(XMB)

               Begin DoDot:1

 +4                SET XMB="ADECALL"

 +5                SET XMDUZ="DENTAL RECALL SYSTEM"

 +6                DO ^XMB

 +7                KILL XMB

               End DoDot:1

 +8        QUIT

ADEGRL6.m