AMHRNSM.m

AMHRNSM ; IHS/CMI/LAB - report of a patient's no show visits ;

 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 ;

 ;

START ;EP - called from option

 D XIT

 W:$D(IOF) @IOF

 S X="BEHAVIORAL HEALTH NO SHOW REPORT FOR MULTIPLE PATIENTS" W !,$$CTR^AMHLEIN(X,80)

 W !!,"This option will print a list of visits with POVs related to No Shows"

 W !,"and Cancellations for multiple patients.  Date range, program and"

 W !,"provider can be specified by the user.",!!

 D DBHUSR^AMHUTIL

GETDATES ;

 W !!,"Please enter the range of dates for the No Show visits"

BD ;get beginning date

 S DIR(0)="D^:DT:EP",DIR("A")="Enter Beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S AMHBD=Y

ED ;get ending date

 W ! S DIR(0)="D^"_AMHBD_":DT:EP",DIR("A")="Enter Ending Date" S Y=AMHBD D DD^%DT D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S AMHED=Y

 S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y

PROG ;

 S AMHPROG=""

 S DIR(0)="S^O:ONE Program;A:ALL Programs",DIR("A")="Run the Report for which PROGRAM",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) GETDATES

 I Y="A" G PROV

 S DIR(0)="9002011,.02",DIR("A")="Which PROGRAM" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) PROG

 I X="" G PROG

 S AMHPROG=Y

PROV ;

 S AMHPROV=""

 S DIR(0)="S^A:All Providers;O:One Provider",DIR("A")="Include visits for",DIR("B")="A" K DA D ^DIR K DIR

 G:$D(DIRUT) PROG

 I Y="A" G SORT

 S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Which PROVIDER: " D ^DIC

 K DIC,DA

 I Y=-1 G PROV

 S AMHPROV=+Y

SORT ;

 S AMHSORT=""

 S DIR(0)="S^P:Patient Name;D:Date of Visit",DIR("A")="How would you like the report sorted",DIR("B")="P" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) PROV

 S AMHSORT=Y

DEMO ;

 D DEMOCHK^AMHUTIL1(.AMHDEMO)

 I AMHDEMO=-1 G SORT

ZIS ;

 S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) G XIT

 I $G(Y)="B" D BROWSE,XIT Q

 W !! S XBRP="PRINT^AMHRNSM",XBRC="PROC^AMHRNSM",XBNS="AMH*",XBRX="XIT^AMHRNSM"

 D ^XBDBQUE

 D XIT

 Q

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^AMHRNSM"")"

 S XBNS="AMH",XBRC="PROC^AMHRNSM",XBRX="XIT^AMHRNSM",XBIOP=0 D ^XBDBQUE

 Q

 ;

PROC ;EP - called from xbdbque

 ;loop through all visits in date range and look for problem 8-8.9 or visit type of N

 S AMHJOB=$J,AMHTOT=0,AMHBT=$H,AMHPTOT=0

 D XTMP^AMHUTIL("AMHRNSM","BH - NO SHOW VISITS")

 S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X

 S AMHODAT=AMHSD_".9999" F  S AMHODAT=$O(^AMHREC("B",AMHODAT)) Q:AMHODAT=""!((AMHODAT\1)>AMHED)  D

 .S AMHR=0 F  S AMHR=$O(^AMHREC("B",AMHODAT,AMHR)) Q:AMHR'=+AMHR  D

 ..I AMHPROG]"",$P(^AMHREC(AMHR,0),U,2)'=AMHPROG Q

 ..I AMHPROV,$$PPINT^AMHUTIL(AMHR)'=AMHPROV Q

 ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHR)

 ..S DFN=$P(^AMHREC(AMHR,0),U,8) Q:'DFN

 ..Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)

 ..Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))

 ..;if any dx is 8 then do set and q

 ..S (AMHX,AMHDNKA)=0 F  S AMHX=$O(^AMHRPRO("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHDNKA)  D

 ...I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8 S AMHDNKA=1 D SET Q  ;do not pass dnka

 ...I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.1 S AMHDNKA=1 D SET Q  ;do not pass dnka

 ...I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.11 S AMHDNKA=1 D SET Q  ;do not pass dnka

 ...I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.2 S AMHDNKA=1 D SET Q  ;do not pass dnka

 ...I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.21 S AMHDNKA=1 D SET Q

 ...I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.3 S AMHDNKA=1 D SET Q  ;do not pass dnka

 ...I $P(^AMHREC(AMHR,0),U,33)="N" D SET Q

 ...Q

 ..Q

 .Q

 Q

SET ;

 S ^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS",$S(AMHSORT="P":$P(^DPT(DFN,0),U),1:(9999999-$P(AMHODAT,"."))),AMHR)="",AMHTOT=AMHTOT+1

 I $D(^XTMP("AMHRNSM",AMHJOB,AMHBT,"PATIENTS",DFN)) Q

 S AMHPTOT=AMHPTOT+1

 S ^XTMP("AMHRNSM",AMHJOB,AMHBT,"PATIENTS",DFN)=""

 Q

PRINT ;EP - called from xbdbque

 D PRINT1

 K ^XTMP("AMHRNSM",AMHJOB,AMHBT)

 Q

PRINT1 ;

 K AMHQ S AMHPG=0

 I '$D(^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS")) D HEADER W !!,"There were no NO SHOW visits during the time period.",! Q

 D HEADER

 S AMHSORT="" F  S AMHSORT=$O(^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS",AMHSORT)) Q:AMHSORT=""!($D(AMHQ))  D

 .S AMHR=0 F  S AMHR=$O(^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS",AMHSORT,AMHR)) Q:AMHR'=+AMHR!($D(AMHQ))  D

 ..I $Y>(IOSL-4) D HEADER Q:$D(AMHQ)

 ..S DFN=$P(^AMHREC(AMHR,0),U,8)

 ..W !,$E($P(^DPT(DFN,0),U),1,18),?20,$$HRN^AUPNPAT(DFN,DUZ(2)),?27,$$FMTE^XLFDT($P(^AMHREC(AMHR,0),U)),?46,$E($$PPNAME^AMHUTIL(AMHR),1,12)

 ..W ?59,$E($$VAL^XBDIQ1(9002011,AMHR,.02),1,1),?62,$$PRIMPOV^AMHUTIL1(AMHR,"C")_"-"

 ..S X=$$PRIMPOV^AMHUTIL1(AMHR,"I") I X W $E($P(^AMHPROB(X,0),U,2),1,12)

 .Q

 Q:$D(AMHQ)

 I $Y>(IOSL-4) D HEADER Q:$D(AMHQ)

 W !!,"Total # of Patients: ",AMHPTOT,"     Total # of No Show Visits: ",AMHTOT,!

 Q

XIT ;

 D EN^XBVK("AMH")

 D KILL^AUPNPAT

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

HEADER ;EP

 I 'AMHPG G HEADER1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQ="" Q

HEADER1 ;

 W:$D(IOF) @IOF S AMHPG=AMHPG+1

 W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?($S(80=132:120,1:72)),"Page ",AMHPG,!

 S AMHTEXT="BEHAVIORAL HEALTH NO SHOW APPOINTMENT LISTING"

 W !?(80-$L(AMHTEXT)/2),AMHTEXT,!

 S AMHTEXT="Appointment Dates:  "_AMHBDD_" and "_AMHEDD

 W ?(80-$L(AMHTEXT)/2),AMHTEXT,!

 I AMHPROG]"" S X="Program: "_$$EXTSET^XBFUNC(9002011,.02,AMHPROG) W $$CTR^AMHLEIN(X,80),!

 I AMHPROV S X="Provider: "_$P(^VA(200,AMHPROV,0),U) W $$CTR^AMHLEIN(X,80),!

 W !,"PATIENT NAME",?20,"HRN",?27,"DATE/TIME",?46,"PROVIDER",?59,"PG",?63,"POV"

 W !,$TR($J(" ",80)," ","-")

 Q

AMHRNSM   ; IHS/CMI/LAB - report of a patient's no show visits ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 +2       ;

 +3       ;

START     ;EP - called from option

 +1        DO XIT

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        SET X="BEHAVIORAL HEALTH NO SHOW REPORT FOR MULTIPLE PATIENTS"

           WRITE !,$$CTR^AMHLEIN(X,80)

 +4        WRITE !!,"This option will print a list of visits with POVs related to No Shows"

 +5        WRITE !,"and Cancellations for multiple patients.  Date range, program and"

 +6        WRITE !,"provider can be specified by the user.",!!

 +7        DO DBHUSR^AMHUTIL

GETDATES  ;

 +1        WRITE !!,"Please enter the range of dates for the No Show visits"

BD        ;get beginning date

 +1        SET DIR(0)="D^:DT:EP"

           SET DIR("A")="Enter Beginning Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        SET AMHBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="D^"_AMHBD_":DT:EP"

           SET DIR("A")="Enter Ending Date"

           SET Y=AMHBD

           DO DD^%DT

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET AMHED=Y

 +4        SET X1=AMHBD

           SET X2=-1

           DO C^%DTC

           SET AMHSD=X

           SET Y=AMHBD

           DO DD^%DT

           SET AMHBDD=Y

           SET Y=AMHED

           DO DD^%DT

           SET AMHEDD=Y

PROG      ;

 +1        SET AMHPROG=""

 +2        SET DIR(0)="S^O:ONE Program;A:ALL Programs"

           SET DIR("A")="Run the Report for which PROGRAM"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO GETDATES

 +4        IF Y="A"

               GOTO PROV

 +5        SET DIR(0)="9002011,.02"

           SET DIR("A")="Which PROGRAM"

           KILL DA

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)

               GOTO PROG

 +7        IF X=""

               GOTO PROG

 +8        SET AMHPROG=Y

PROV      ;

 +1        SET AMHPROV=""

 +2        SET DIR(0)="S^A:All Providers;O:One Provider"

           SET DIR("A")="Include visits for"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO PROG

 +4        IF Y="A"

               GOTO SORT

 +5        SET DIC="^VA(200,"

           SET DIC(0)="AEMQ"

           SET DIC("A")="Which PROVIDER: "

           DO ^DIC

 +6        KILL DIC,DA

 +7        IF Y=-1

               GOTO PROV

 +8        SET AMHPROV=+Y

SORT      ;

 +1        SET AMHSORT=""

 +2        SET DIR(0)="S^P:Patient Name;D:Date of Visit"

           SET DIR("A")="How would you like the report sorted"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO PROV

 +4        SET AMHSORT=Y

DEMO      ;

 +1        DO DEMOCHK^AMHUTIL1(.AMHDEMO)

 +2        IF AMHDEMO=-1

               GOTO SORT

ZIS       ;

 +1        SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to "

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        IF $GET(Y)="B"

               DO BROWSE

               DO XIT

               QUIT 

 +4        WRITE !!

           SET XBRP="PRINT^AMHRNSM"

           SET XBRC="PROC^AMHRNSM"

           SET XBNS="AMH*"

           SET XBRX="XIT^AMHRNSM"

 +5        DO ^XBDBQUE

 +6        DO XIT

 +7        QUIT 

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""PRINT^AMHRNSM"")"

 +2        SET XBNS="AMH"

           SET XBRC="PROC^AMHRNSM"

           SET XBRX="XIT^AMHRNSM"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

 +4       ;

PROC      ;EP - called from xbdbque

 +1       ;loop through all visits in date range and look for problem 8-8.9 or visit type of N

 +2        SET AMHJOB=$JOB

           SET AMHTOT=0

           SET AMHBT=$HOROLOG

           SET AMHPTOT=0

 +3        DO XTMP^AMHUTIL("AMHRNSM","BH - NO SHOW VISITS")

 +4        SET X1=AMHBD

           SET X2=-1

           DO C^%DTC

           SET AMHSD=X

 +5        SET AMHODAT=AMHSD_".9999"

           FOR 

               SET AMHODAT=$ORDER(^AMHREC("B",AMHODAT))

               IF AMHODAT=""!((AMHODAT\1)>AMHED)

                   QUIT 

               Begin DoDot:1

 +6                SET AMHR=0

                   FOR 

                       SET AMHR=$ORDER(^AMHREC("B",AMHODAT,AMHR))

                       IF AMHR'=+AMHR

                           QUIT 

                       Begin DoDot:2

 +7                        IF AMHPROG]""

                               IF $PIECE(^AMHREC(AMHR,0),U,2)'=AMHPROG

                                   QUIT 

 +8                        IF AMHPROV

                               IF $$PPINT^AMHUTIL(AMHR)'=AMHPROV

                                   QUIT 

 +9                        IF '$$ALLOWVI^AMHUTIL(DUZ,AMHR)

                               QUIT 

 +10                       SET DFN=$PIECE(^AMHREC(AMHR,0),U,8)

                           IF 'DFN

                               QUIT 

 +11                       IF '$$ALLOWP^AMHUTIL(DUZ,DFN)

                               QUIT 

 +12                       IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))

                               QUIT 

 +13      ;if any dx is 8 then do set and q

 +14                       SET (AMHX,AMHDNKA)=0

                           FOR 

                               SET AMHX=$ORDER(^AMHRPRO("AD",AMHR,AMHX))

                               IF AMHX'=+AMHX!(AMHDNKA)

                                   QUIT 

                               Begin DoDot:3

 +15      ;do not pass dnka

                                   IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8

                                       SET AMHDNKA=1

                                       DO SET

                                       QUIT 

 +16      ;do not pass dnka

                                   IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.1

                                       SET AMHDNKA=1

                                       DO SET

                                       QUIT 

 +17      ;do not pass dnka

                                   IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.11

                                       SET AMHDNKA=1

                                       DO SET

                                       QUIT 

 +18      ;do not pass dnka

                                   IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.2

                                       SET AMHDNKA=1

                                       DO SET

                                       QUIT 

 +19                               IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.21

                                       SET AMHDNKA=1

                                       DO SET

                                       QUIT 

 +20      ;do not pass dnka

                                   IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.3

                                       SET AMHDNKA=1

                                       DO SET

                                       QUIT 

 +21                               IF $PIECE(^AMHREC(AMHR,0),U,33)="N"

                                       DO SET

                                       QUIT 

 +22                               QUIT 

                               End DoDot:3

 +23                       QUIT 

                       End DoDot:2

 +24               QUIT 

               End DoDot:1

 +25       QUIT 

SET       ;

 +1        SET ^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS",$SELECT(AMHSORT="P":$PIECE(^DPT(DFN,0),U),1:(9999999-$PIECE(AMHODAT,"."))),AMHR)=""

           SET AMHTOT=AMHTOT+1

 +2        IF $DATA(^XTMP("AMHRNSM",AMHJOB,AMHBT,"PATIENTS",DFN))

               QUIT 

 +3        SET AMHPTOT=AMHPTOT+1

 +4        SET ^XTMP("AMHRNSM",AMHJOB,AMHBT,"PATIENTS",DFN)=""

 +5        QUIT 

PRINT     ;EP - called from xbdbque

 +1        DO PRINT1

 +2        KILL ^XTMP("AMHRNSM",AMHJOB,AMHBT)

 +3        QUIT 

PRINT1    ;

 +1        KILL AMHQ

           SET AMHPG=0

 +2        IF '$DATA(^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS"))

               DO HEADER

               WRITE !!,"There were no NO SHOW visits during the time period.",!

               QUIT 

 +3        DO HEADER

 +4        SET AMHSORT=""

           FOR 

               SET AMHSORT=$ORDER(^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS",AMHSORT))

               IF AMHSORT=""!($DATA(AMHQ))

                   QUIT 

               Begin DoDot:1

 +5                SET AMHR=0

                   FOR 

                       SET AMHR=$ORDER(^XTMP("AMHRNSM",AMHJOB,AMHBT,"NO SHOWS",AMHSORT,AMHR))

                       IF AMHR'=+AMHR!($DATA(AMHQ))

                           QUIT 

                       Begin DoDot:2

 +6                        IF $Y>(IOSL-4)

                               DO HEADER

                               IF $DATA(AMHQ)

                                   QUIT 

 +7                        SET DFN=$PIECE(^AMHREC(AMHR,0),U,8)

 +8                        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,18),?20,$$HRN^AUPNPAT(DFN,DUZ(2)),?27,$$FMTE^XLFDT($PIECE(^AMHREC(AMHR,0),U)),?46,$EXTRACT($$PPNAME^AMHUTIL(AMHR),1,12)

 +9                        WRITE ?59,$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.02),1,1),?62,$$PRIMPOV^AMHUTIL1(AMHR,"C")_"-"

 +10                       SET X=$$PRIMPOV^AMHUTIL1(AMHR,"I")

                           IF X

                               WRITE $EXTRACT($PIECE(^AMHPROB(X,0),U,2),1,12)

                       End DoDot:2

 +11               QUIT 

               End DoDot:1

 +12       IF $DATA(AMHQ)

               QUIT 

 +13       IF $Y>(IOSL-4)

               DO HEADER

               IF $DATA(AMHQ)

                   QUIT 

 +14       WRITE !!,"Total # of Patients: ",AMHPTOT,"     Total # of No Show Visits: ",AMHTOT,!

 +15       QUIT 

XIT       ;

 +1        DO EN^XBVK("AMH")

 +2        DO KILL^AUPNPAT

 +3        QUIT 

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

HEADER    ;EP

 +1        IF 'AMHPG

               GOTO HEADER1

 +2        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET AMHQ=""

                       QUIT 

HEADER1   ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET AMHPG=AMHPG+1

 +2        WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 +3        WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?($SELECT(80=132:120,1:72)),"Page ",AMHPG,!

 +4        SET AMHTEXT="BEHAVIORAL HEALTH NO SHOW APPOINTMENT LISTING"

 +5        WRITE !?(80-$LENGTH(AMHTEXT)/2),AMHTEXT,!

 +6        SET AMHTEXT="Appointment Dates:  "_AMHBDD_" and "_AMHEDD

 +7        WRITE ?(80-$LENGTH(AMHTEXT)/2),AMHTEXT,!

 +8        IF AMHPROG]""

               SET X="Program: "_$$EXTSET^XBFUNC(9002011,.02,AMHPROG)

               WRITE $$CTR^AMHLEIN(X,80),!

 +9        IF AMHPROV

               SET X="Provider: "_$PIECE(^VA(200,AMHPROV,0),U)

               WRITE $$CTR^AMHLEIN(X,80),!

 +10       WRITE !,"PATIENT NAME",?20,"HRN",?27,"DATE/TIME",?46,"PROVIDER",?59,"PG",?63,"POV"

 +11       WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")

 +12       QUIT