ADEPV1.m

ADEPV1 ; IHS/HQT/MJL - DENTAL VISIT REPORT PT 2 ;09:25 AM  [ 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

START ;EP - TASKMAN PROCESSING PHASE

 I $D(ZTQUEUED) L +@ADEGBL:1 I '$T S ZTREQ="@" G END

 D ^XBKVAR S ADEDT=ADEBDT-1,ADEDT=ADEDT_".9999"

 W:'$D(ZTQUEUED) !,"Please wait while I scan the records"

 ;IHS/OIT/GAB 11.2014 Modified below line and added the next for 2015 Code updates - PATCH #26:  added ADEBA1 & ADECA1 for new missed/broken and cancelled appt codes

 ;S ADEFV=$O(^AUTTADA("B","0000",0)),ADEREV=$O(^AUTTADA("B","0190",0)),ADEBA=$O(^AUTTADA("B","9130",0)),ADECA=$O(^AUTTADA("B","9140",0)),ADEPTC=$O(^AUTTADA("B","9990",0))

 S ADEFV=$O(^AUTTADA("B","0000",0)),ADEREV=$O(^AUTTADA("B","0190",0)),ADEBA=$O(^AUTTADA("B","9130",0)),ADECA=$O(^AUTTADA("B","9140",0)),ADEPTC=$O(^AUTTADA("B","9990",0)),ADEBA1=$O(^AUTTADA("B","9986",0)),ADECA1=$O(^AUTTADA("B","9987",0))

ROLL S ADEDFN=0,ADEDT=$O(^ADEPCD("AC",ADEDT)) G:(ADEDT="")!(ADEDT>ADEND) ROLLEND I '$D(ZTQUEUED) W "."

RO1 S ADEDFN=$O(^ADEPCD("AC",ADEDT,ADEDFN)) G:ADEDFN="" ROLL

 G:'$D(^ADEPCD(ADEDFN,0)) RO1

 S ADEPAT=$P(^ADEPCD(ADEDFN,0),U)

 S ADELOE=$P(^ADEPCD(ADEDFN,0),U,3) G:ADELOE=""!('$D(^AUTTLOC(ADELOE))) RO1

 D:ADETITL["TRIB" TRIBE D:ADETITL["COMM" COMMUN D:ADETITL["FACI" FAC G:'ADEY RO1

 S:'$D(@ADEGBL@(ADELOE,ADECOM)) @ADEGBL@(ADELOE,ADECOM)="0^0^0^0"

 I $D(^ADEPCD(ADEDFN,"ADA","B",ADEREV)) S $P(@ADEGBL@(ADELOE,ADECOM),U,2)=$P(@ADEGBL@(ADELOE,ADECOM),U,2)+1

 I $D(^ADEPCD(ADEDFN,"ADA","B",ADEFV)) S $P(@ADEGBL@(ADELOE,ADECOM),U)=$P(@ADEGBL@(ADELOE,ADECOM),U)+1

 ;I $D(^ADEPCD(ADEDFN,"ADA","B",ADECA)) S $P(@ADEGBL@(ADELOE,ADECOM),U,3)=$P(@ADEGBL@(ADELOE,ADECOM),U,3)+1 G RO1

 I $D(^ADEPCD(ADEDFN,"ADA","B",ADEBA)) S $P(@ADEGBL@(ADELOE,ADECOM),U,3)=$P(@ADEGBL@(ADELOE,ADECOM),U,3)+1 ;G RO1

 ;IHS/OIT/GAB 11.2014 added the next for 2015 Code updates - PATCH #26 Added new code 9986 (Broken/missed appt) to count

 I $D(^ADEPCD(ADEDFN,"ADA","B",ADEBA1)) S $P(@ADEGBL@(ADELOE,ADECOM),U,3)=$P(@ADEGBL@(ADELOE,ADECOM),U,3)+1

 I $D(^ADEPCD(ADEDFN,"ADA","B",ADEPTC)) S $P(@ADEGBL@(ADELOE,ADECOM),U,4)=$P(@ADEGBL@(ADELOE,ADECOM),U,4)+1

 G RO1

 ;

ROLLEND S @ADEGBL@(0)=ADEBDT_U_ADEND_U_DT_U_ADETITL

 ;

 I $D(ZTQUEUED),$D(IOT),IOT'="HFS" D  G END2

 . L -@ADEGBL

 . S ZTREQ=$H_U_ADEIOP_U_"DENTAL VISIT REPT PRINTING"_U_"PRINT^ADEPV1"

 I $D(ZTQUEUED) L -@ADEGBL ;MUST BE HFS

 ;

PRINT ;EP - TASKMAN PRINT PHASE

 I $D(ZTQUEUED) L +@ADEGBL:1 I '$T S ADENOLOK=1 G END

 S IOP=ADEIOP

 S %ZIS("IOPAR")=ADEIOPAR

 D ^%ZIS

 U IO

 S (ADEFVTT,ADERVTT,ADEBATT,ADENOCT,ADELOE)=0,ADEPAG=1,$P(ADELIN,"-",79)="",ADEBDT=$P(@ADEGBL@(0),U),ADEND=$P(@ADEGBL@(0),U,2)

 S Y=ADEBDT X ^DD("DD") S ADEBDT=Y,Y=ADEND X ^DD("DD") S ADEND=Y

P1 S ADECOM=0,ADELOE=$O(@ADEGBL@(ADELOE)) G:ADELOE="" FACTOT S ADEFAC=$P(^AUTTLOC(ADELOE,0),U,2)

 S (ADEFVT,ADERVT,ADEBAT,ADENOC,ADEQIT)=0 D EOP1 G:ADEQIT=1 END

P2 S ADECOM=$O(@ADEGBL@(ADELOE,ADECOM)) I ADECOM="" D TOTAL G P1

 W !,ADECOM S ADEDAT=@ADEGBL@(ADELOE,ADECOM)

 S ADEFVT=ADEFVT+$P(ADEDAT,U),ADERVT=ADERVT+$P(ADEDAT,U,2),ADEBAT=ADEBAT+$P(ADEDAT,U,3),ADENOC=ADENOC+$P(ADEDAT,U,4)

 W ?31,$J($P(ADEDAT,U),9),?41,$J($P(ADEDAT,U,2),9),?51,$J($P(ADEDAT,U,3),9),?61,$J($P(ADEDAT,U,4),9)

 S ADEQIT=0 D EOP G:ADEQIT=1 END G P2

FACTOT S ADEQIT=0 D EOP1 G:ADEQIT=1 END W @IOF,"TOTAL FOR ALL FACILITIES",?65,"PAGE ",ADEPAG

 W !,?35,"FIRST",?55,"BROKEN",!?35,"VISIT",?45,"REVISIT",?55,"APPTS",?65,"PTC",!,ADELIN

 W !!,?31,$J(ADEFVTT,9),?41,$J(ADERVTT,9),?51,$J(ADEBATT,9),?61,$J(ADENOCT,9)

 ;

END I $D(ZTQUEUED) S ZTREQ="@"

 L -@ADEGBL

 I '$D(ADENOLOK) K @ADEGBL

END2 ;

 D ^%ZISC

 K ADENOLOK,ADEIOP,ADEIOPAR

 K ADENOC,ADENOCT,ADEFAC,ADEFVT,ADEFVTT,ADERVT,ADERVTT,ADEBAT,ADEBATT,ADELOE,ADEOLD,ADELIN,ADEPAG,ADECOM,ADERPD,ADEDAT,ADEDT,ADEBDT,ADEND,ADEQIT

 ;/IHS/OIT/GAB ADDED ADECA1 AND ADEBA1 BELOW

 K ADEBA,ADECA,ADEBA1,ADECA1,ADEFV,ADEDFN,ADEREV,ADEVIS,ADEGBL,ADETITL,ADEPAT,ADEPTC,ADEY,ZTSK Q

 ;

EOP Q:$Y'>(IOSL-5)

EOP1 I ADEPAG'=1,$P(IOST,"-")["C" W *7 R !,X:DTIME I ('$T)!(X["^") S ADEQIT=1 Q

 D:ADELOE'="" HEADER Q

HEADER W @IOF,ADEFAC,"  ",ADETITL,?65,"PAGE ",ADEPAG,!,"FOR VISITS BETWEEN ",ADEBDT," AND ",$P(ADEND,"@")

 W !!,?35,"FIRST",?55,"BROKEN",!

 W $S(ADETITL["TRIB":"TRIBE",ADETITL["FACIL":"DENTIST",1:"COMMUNITY"),?35,"VISIT",?45,"REVISIT",?55,"APPTS",?65,"PTC",!,ADELIN

 S ADEPAG=ADEPAG+1 Q

TOTAL W !!,"TOTAL:",?31,$J(ADEFVT,9),?41,$J(ADERVT,9),?51,$J(ADEBAT,9),?61,$J(ADENOC,9) S ADEFVTT=ADEFVT+ADEFVTT,ADERVTT=ADERVT+ADERVTT,ADEBATT=ADEBAT+ADEBATT,ADENOCT=ADENOC+ADENOCT Q

 ;

TRIBE S ADEY=0

 Q:'$D(^ADEPCD(ADEDFN,0))

 S ADEPAT=$P(^ADEPCD(ADEDFN,0),U)

 Q:'$D(^AUPNPAT(ADEPAT,11))

 S ADECOM=$P(^AUPNPAT(ADEPAT,11),U,8) Q:ADECOM=""

 Q:'$D(^AUTTTRI(ADECOM,0))

 S ADECOM=$P(^AUTTTRI(ADECOM,0),U),ADECOM=$E(ADECOM,1,30)

 S ADEY=1

 Q

COMMUN S ADEY=0

 S ADEPAT=$P(^ADEPCD(ADEDFN,0),U)

 Q:'$D(^AUPNPAT(ADEPAT,11))

 S ADECOM=$P(^AUPNPAT(ADEPAT,11),U,18) Q:ADECOM=""

 S ADEY=1

 Q

FAC S ADEY=0

 S ADECOM=$P(^ADEPCD(ADEDFN,0),U,4) Q:ADECOM=""

 Q:'$D(^DIC(16,ADECOM,0))

 S ADECOM=$P(^DIC(16,ADECOM,0),U)

 S ADEY=1

 Q

ADEPV1    ; IHS/HQT/MJL - DENTAL VISIT REPORT PT 2 ;09:25 AM  [ 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

START     ;EP - TASKMAN PROCESSING PHASE

 +1        IF $DATA(ZTQUEUED)

               LOCK +@ADEGBL:1

               IF '$TEST

                   SET ZTREQ="@"

                   GOTO END

 +2        DO ^XBKVAR

           SET ADEDT=ADEBDT-1

           SET ADEDT=ADEDT_".9999"

 +3        IF '$DATA(ZTQUEUED)

               WRITE !,"Please wait while I scan the records"

 +4       ;IHS/OIT/GAB 11.2014 Modified below line and added the next for 2015 Code updates - PATCH #26:  added ADEBA1 & ADECA1 for new missed/broken and cancelled appt codes

 +5       ;S ADEFV=$O(^AUTTADA("B","0000",0)),ADEREV=$O(^AUTTADA("B","0190",0)),ADEBA=$O(^AUTTADA("B","9130",0)),ADECA=$O(^AUTTADA("B","9140",0)),ADEPTC=$O(^AUTTADA("B","9990",0))

 +6        SET ADEFV=$ORDER(^AUTTADA("B","0000",0))

           SET ADEREV=$ORDER(^AUTTADA("B","0190",0))

           SET ADEBA=$ORDER(^AUTTADA("B","9130",0))

           SET ADECA=$ORDER(^AUTTADA("B","9140",0))

           SET ADEPTC=$ORDER(^AUTTADA("B","9990",0))

           SET ADEBA1=$ORDER(^AUTTADA("B","9986",0))

           SET ADECA1=$ORDER(^AUTTADA("B","9987",0))

ROLL       SET ADEDFN=0

           SET ADEDT=$ORDER(^ADEPCD("AC",ADEDT))

           IF (ADEDT="")!(ADEDT>ADEND)

               GOTO ROLLEND

           IF '$DATA(ZTQUEUED)

               WRITE "."

RO1        SET ADEDFN=$ORDER(^ADEPCD("AC",ADEDT,ADEDFN))

           IF ADEDFN=""

               GOTO ROLL

 +1        IF '$DATA(^ADEPCD(ADEDFN,0))

               GOTO RO1

 +2        SET ADEPAT=$PIECE(^ADEPCD(ADEDFN,0),U)

 +3        SET ADELOE=$PIECE(^ADEPCD(ADEDFN,0),U,3)

           IF ADELOE=""!('$DATA(^AUTTLOC(ADELOE)))

               GOTO RO1

 +4        IF ADETITL["TRIB"

               DO TRIBE

           IF ADETITL["COMM"

               DO COMMUN

           IF ADETITL["FACI"

               DO FAC

           IF 'ADEY

               GOTO RO1

 +5        IF '$DATA(@ADEGBL@(ADELOE,ADECOM))

               SET @ADEGBL@(ADELOE,ADECOM)="0^0^0^0"

 +6        IF $DATA(^ADEPCD(ADEDFN,"ADA","B",ADEREV))

               SET $PIECE(@ADEGBL@(ADELOE,ADECOM),U,2)=$PIECE(@ADEGBL@(ADELOE,ADECOM),U,2)+1

 +7        IF $DATA(^ADEPCD(ADEDFN,"ADA","B",ADEFV))

               SET $PIECE(@ADEGBL@(ADELOE,ADECOM),U)=$PIECE(@ADEGBL@(ADELOE,ADECOM),U)+1

 +8       ;I $D(^ADEPCD(ADEDFN,"ADA","B",ADECA)) S $P(@ADEGBL@(ADELOE,ADECOM),U,3)=$P(@ADEGBL@(ADELOE,ADECOM),U,3)+1 G RO1

 +9       ;G RO1

           IF $DATA(^ADEPCD(ADEDFN,"ADA","B",ADEBA))

               SET $PIECE(@ADEGBL@(ADELOE,ADECOM),U,3)=$PIECE(@ADEGBL@(ADELOE,ADECOM),U,3)+1

 +10      ;IHS/OIT/GAB 11.2014 added the next for 2015 Code updates - PATCH #26 Added new code 9986 (Broken/missed appt) to count

 +11       IF $DATA(^ADEPCD(ADEDFN,"ADA","B",ADEBA1))

               SET $PIECE(@ADEGBL@(ADELOE,ADECOM),U,3)=$PIECE(@ADEGBL@(ADELOE,ADECOM),U,3)+1

 +12       IF $DATA(^ADEPCD(ADEDFN,"ADA","B",ADEPTC))

               SET $PIECE(@ADEGBL@(ADELOE,ADECOM),U,4)=$PIECE(@ADEGBL@(ADELOE,ADECOM),U,4)+1

 +13       GOTO RO1

 +14      ;

ROLLEND    SET @ADEGBL@(0)=ADEBDT_U_ADEND_U_DT_U_ADETITL

 +1       ;

 +2        IF $DATA(ZTQUEUED)

               IF $DATA(IOT)

                   IF IOT'="HFS"

                       Begin DoDot:1

 +3                        LOCK -@ADEGBL

 +4                        SET ZTREQ=$HOROLOG_U_ADEIOP_U_"DENTAL VISIT REPT PRINTING"_U_"PRINT^ADEPV1"

                       End DoDot:1

                       GOTO END2

 +5       ;MUST BE HFS

           IF $DATA(ZTQUEUED)

               LOCK -@ADEGBL

 +6       ;

PRINT     ;EP - TASKMAN PRINT PHASE

 +1        IF $DATA(ZTQUEUED)

               LOCK +@ADEGBL:1

               IF '$TEST

                   SET ADENOLOK=1

                   GOTO END

 +2        SET IOP=ADEIOP

 +3        SET %ZIS("IOPAR")=ADEIOPAR

 +4        DO ^%ZIS

 +5        USE IO

 +6        SET (ADEFVTT,ADERVTT,ADEBATT,ADENOCT,ADELOE)=0

           SET ADEPAG=1

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

           SET ADEBDT=$PIECE(@ADEGBL@(0),U)

           SET ADEND=$PIECE(@ADEGBL@(0),U,2)

 +7        SET Y=ADEBDT

           XECUTE ^DD("DD")

           SET ADEBDT=Y

           SET Y=ADEND

           XECUTE ^DD("DD")

           SET ADEND=Y

P1         SET ADECOM=0

           SET ADELOE=$ORDER(@ADEGBL@(ADELOE))

           IF ADELOE=""

               GOTO FACTOT

           SET ADEFAC=$PIECE(^AUTTLOC(ADELOE,0),U,2)

 +1        SET (ADEFVT,ADERVT,ADEBAT,ADENOC,ADEQIT)=0

           DO EOP1

           IF ADEQIT=1

               GOTO END

P2         SET ADECOM=$ORDER(@ADEGBL@(ADELOE,ADECOM))

           IF ADECOM=""

               DO TOTAL

               GOTO P1

 +1        WRITE !,ADECOM

           SET ADEDAT=@ADEGBL@(ADELOE,ADECOM)

 +2        SET ADEFVT=ADEFVT+$PIECE(ADEDAT,U)

           SET ADERVT=ADERVT+$PIECE(ADEDAT,U,2)

           SET ADEBAT=ADEBAT+$PIECE(ADEDAT,U,3)

           SET ADENOC=ADENOC+$PIECE(ADEDAT,U,4)

 +3        WRITE ?31,$JUSTIFY($PIECE(ADEDAT,U),9),?41,$JUSTIFY($PIECE(ADEDAT,U,2),9),?51,$JUSTIFY($PIECE(ADEDAT,U,3),9),?61,$JUSTIFY($PIECE(ADEDAT,U,4),9)

 +4        SET ADEQIT=0

           DO EOP

           IF ADEQIT=1

               GOTO END

           GOTO P2

FACTOT     SET ADEQIT=0

           DO EOP1

           IF ADEQIT=1

               GOTO END

           WRITE @IOF,"TOTAL FOR ALL FACILITIES",?65,"PAGE ",ADEPAG

 +1        WRITE !,?35,"FIRST",?55,"BROKEN",!?35,"VISIT",?45,"REVISIT",?55,"APPTS",?65,"PTC",!,ADELIN

 +2        WRITE !!,?31,$JUSTIFY(ADEFVTT,9),?41,$JUSTIFY(ADERVTT,9),?51,$JUSTIFY(ADEBATT,9),?61,$JUSTIFY(ADENOCT,9)

 +3       ;

END        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +1        LOCK -@ADEGBL

 +2        IF '$DATA(ADENOLOK)

               KILL @ADEGBL

END2      ;

 +1        DO ^%ZISC

 +2        KILL ADENOLOK,ADEIOP,ADEIOPAR

 +3        KILL ADENOC,ADENOCT,ADEFAC,ADEFVT,ADEFVTT,ADERVT,ADERVTT,ADEBAT,ADEBATT,ADELOE,ADEOLD,ADELIN,ADEPAG,ADECOM,ADERPD,ADEDAT,ADEDT,ADEBDT,ADEND,ADEQIT

 +4       ;/IHS/OIT/GAB ADDED ADECA1 AND ADEBA1 BELOW

 +5        KILL ADEBA,ADECA,ADEBA1,ADECA1,ADEFV,ADEDFN,ADEREV,ADEVIS,ADEGBL,ADETITL,ADEPAT,ADEPTC,ADEY,ZTSK

           QUIT 

 +6       ;

EOP        IF $Y'>(IOSL-5)

               QUIT 

EOP1       IF ADEPAG'=1

               IF $PIECE(IOST,"-")["C"

                   WRITE *7

                   READ !,X:DTIME

                   IF ('$TEST)!(X["^")

                       SET ADEQIT=1

                       QUIT 

 +1        IF ADELOE'=""

               DO HEADER

           QUIT 

HEADER     WRITE @IOF,ADEFAC,"  ",ADETITL,?65,"PAGE ",ADEPAG,!,"FOR VISITS BETWEEN ",ADEBDT," AND ",$PIECE(ADEND,"@")

 +1        WRITE !!,?35,"FIRST",?55,"BROKEN",!

 +2        WRITE $SELECT(ADETITL["TRIB":"TRIBE",ADETITL["FACIL":"DENTIST",1:"COMMUNITY"),?35,"VISIT",?45,"REVISIT",?55,"APPTS",?65,"PTC",!,ADELIN

 +3        SET ADEPAG=ADEPAG+1

           QUIT 

TOTAL      WRITE !!,"TOTAL:",?31,$JUSTIFY(ADEFVT,9),?41,$JUSTIFY(ADERVT,9),?51,$JUSTIFY(ADEBAT,9),?61,$JUSTIFY(ADENOC,9)

           SET ADEFVTT=ADEFVT+ADEFVTT

           SET ADERVTT=ADERVT+ADERVTT

           SET ADEBATT=ADEBAT+ADEBATT

           SET ADENOCT=ADENOC+ADENOCT

           QUIT 

 +1       ;

TRIBE      SET ADEY=0

 +1        IF '$DATA(^ADEPCD(ADEDFN,0))

               QUIT 

 +2        SET ADEPAT=$PIECE(^ADEPCD(ADEDFN,0),U)

 +3        IF '$DATA(^AUPNPAT(ADEPAT,11))

               QUIT 

 +4        SET ADECOM=$PIECE(^AUPNPAT(ADEPAT,11),U,8)

           IF ADECOM=""

               QUIT 

 +5        IF '$DATA(^AUTTTRI(ADECOM,0))

               QUIT 

 +6        SET ADECOM=$PIECE(^AUTTTRI(ADECOM,0),U)

           SET ADECOM=$EXTRACT(ADECOM,1,30)

 +7        SET ADEY=1

 +8        QUIT 

COMMUN     SET ADEY=0

 +1        SET ADEPAT=$PIECE(^ADEPCD(ADEDFN,0),U)

 +2        IF '$DATA(^AUPNPAT(ADEPAT,11))

               QUIT 

 +3        SET ADECOM=$PIECE(^AUPNPAT(ADEPAT,11),U,18)

           IF ADECOM=""

               QUIT 

 +4        SET ADEY=1

 +5        QUIT 

FAC        SET ADEY=0

 +1        SET ADECOM=$PIECE(^ADEPCD(ADEDFN,0),U,4)

           IF ADECOM=""

               QUIT 

 +2        IF '$DATA(^DIC(16,ADECOM,0))

               QUIT 

 +3        SET ADECOM=$PIECE(^DIC(16,ADECOM,0),U)

 +4        SET ADEY=1

 +5        QUIT