AMHLETR3.m

AMHLETR3 ; IHS/CMI/LAB - print report of tps needing resolved ;

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

 ;

 ;

 ;

 I '$D(IOF) D HOME^%ZIS

 W @(IOF),!!

 W "**********  LIST CASES OPENED WITH NO TREATMENT PLAN IN PLACE **********",!!

 W "This report will list all patients who have a case open date,"

 W !,"no case closed date and no treatment plan in place."

 W !

 I '$D(^AMHSITE(DUZ(2),16,DUZ)) D

 .W !,"This report will only include Cases on which you are the documented"

 .W !,"provider.",!!

 D DBHUSRP^AMHUTIL

GETDATES ;

BD ;get beginning date

 W !,"Please enter the date range during which the case was opened.",!

 W ! S DIR(0)="D^::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_"::E",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 ;

 W !!,"You can limit the report output to cases opened by one or all Programs",!

 S AMHPROG="" W ! S DIR(0)="S^O:One Program;A:All Programs",DIR("A")="List cases opened by",DIR("B")="O" K DA D ^DIR K DIR

 G:$D(DIRUT) BD

 G:Y="A" THER

 K DIR S DIR(0)="9002011,.02",DIR("A")="Review Cases opened by which Program" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G PROG

 S AMHPROG=Y

THER ;

 W !!,"You can limit the report output to cases opened by one or all Providers",!

 S AMHPROV="" W ! S DIR(0)="S^O:One Provider;A:All Providers",DIR("A")="List cases opened by",DIR("B")="O" K DA D ^DIR K DIR

 G:$D(DIRUT) XIT

 G:Y="A" SORT

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

 I X="" G THER

 I Y<0 G THER

 S AMHPROV=+Y

SORT ;

 S AMHSORT=""

 S DIR(0)="S^P:Responsible Provider;N:Patient Name;C:Case Open Date",DIR("A")="Sort list by",DIR("B")="P" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G THER

 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

 S XBRC="PROC^AMHLETR3",XBRP="PRINT^AMHLETR3",XBNS="AMH",XBRX="XIT^AMHLETR3"

 D ^XBDBQUE

XIT ;

 D EN^XBVK("AMH")

 K DFN

 Q

 ;

BROWSE ;

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

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

 Q

PROC ;EP - entry point for processing

 S AMHJOB=$J,AMHBTH=$H,AMHTOT=0,AMHCASE=0,AMHBT=$H

 F  S AMHCASE=$O(^AMHPCASE(AMHCASE)) Q:AMHCASE'=+AMHCASE  D PROC1

 S AMHET=$H

 K AMHCASE

 Q

PROC1 ;

 Q:'$$ALLOWCD^AMHLCD(DUZ,AMHCASE)

 S DFN=$P(^AMHPCASE(AMHCASE,0),U,2)

 Q:DFN=""

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

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

 Q:$P(^AMHPCASE(AMHCASE,0),U,5)]""  ;CLOSED

 I AMHPROV,$P(^AMHPCASE(AMHCASE,0),U,8)'=AMHPROV Q  ;not this provider

 S AMHCPRV=$P(^AMHPCASE(AMHCASE,0),U,8)

 S AMHCPRG=$P(^AMHPCASE(AMHCASE,0),U,3)

 I AMHPROG]"",AMHCPRG'=AMHPROG Q  ;not a program of interest

 S AMHOD=$P(^AMHPCASE(AMHCASE,0),U)

 I AMHOD<AMHBD Q

 I AMHOD>AMHED Q

 ;is there a tp in place???

 Q:$$TP(AMHOD,DFN,AMHCPRV,AMHCPRG)  ;has a tp

 D @AMHSORT

 S ^XTMP("AMHLETR3",AMHJOB,AMHBTH,AMHSORTV,AMHCASE)=""

 Q

TP(DATE,PAT,PROV,PRG) ;

 I '$D(^AMHPTXP("AC",PAT)) Q 0  ;no tp's

 NEW C,X,G

 S G=0

 S X=0 F  S X=$O(^AMHPTXP("AC",PAT,X)) Q:X'=+X  D

 .Q:$P(^AMHPTXP(X,0),U,17)'=PRG

 .Q:$P(^AMHPTXP(X,0),U,4)'=PROV

 .Q:'$$ALLOWTP^AMHLETP(DUZ,X)

 .I $P(^AMHPTXP(X,0),U,12)]"",$P(^AMHPTXP(X,0),U,12)<DATE Q  ;closed before this case opened

 .Q:$P(^AMHPTXP(X,0),U)<DATE

 .Q:$P(^AMHPTXP(X,0),U,15)="I"

 .S G=1

 .Q

 Q G

P ;

 S AMHSORTV=$P(^AMHPCASE(AMHCASE,0),U,8)

 I AMHSORTV S AMHSORTV=$P(^VA(200,AMHSORTV,0),U) Q

 S AMHSORTV="--"

 Q

N ;

 S P=$P(^AMHPCASE(AMHCASE,0),U,2)

 I P="" S AMHSORVT="--" Q

 S AMHSORTV=$P(^DPT(P,0),U)

 I AMHSORTV="" S AMHSORTV="--"

 Q

C ;

 S AMHSORTV=$P(^AMHPCASE(AMHCASE,0),U,1)

 I AMHSORTV="" S AMHSORTV="--" Q

 Q

PRINT ;EP

 S AMHPG=0 S AMHQUIT=0

 D HEAD

 I '$D(^XTMP("AMHLETR3",AMHJOB,AMHBTH)) W !!,"NO DATA TO REPORT" G DONE

 S AMHSORTV="" F  S AMHSORTV=$O(^XTMP("AMHLETR3",AMHJOB,AMHBTH,AMHSORTV)) Q:AMHSORTV=""!(AMHQUIT)  D PRT2

 D DONE

 Q

PRT2 ;

 S AMHCASE=0 F  S AMHCASE=$O(^XTMP("AMHLETR3",AMHJOB,AMHBTH,AMHSORTV,AMHCASE)) Q:AMHCASE'=+AMHCASE!(AMHQUIT)  D

 .I $Y>(IOSL-4) D HEAD Q:AMHQUIT

 .S DFN=$P(^AMHPCASE(AMHCASE,0),U,2)

 .W !,$E($P(^DPT(DFN,0),U),1,21),?23,$$HRN^AUPNPAT(DFN,DUZ(2))

 .W ?31,$$D($P(^AMHPCASE(AMHCASE,0),U)),?41,$E($$VAL^XBDIQ1(9002011.58,AMHCASE,.03),1,10)

 .W ?53,$E($$VAL^XBDIQ1(9002011.58,AMHCASE,.08),1,15)

 .W ?72,$$D($$LVD^AMHDPEE(DFN,"ID"))

 Q

DONE ;

 K ^XTMP("AMHLETR3",AMHJOB,AMHBTH),AMHJOB,AMHBTH

 Q

D(D) ;

 I $G(D)="" Q ""

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)

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

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

 ;----------

HEAD ;

 I 'AMHPG G HEAD1

 NEW X

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

HEAD1 ;EP

 S AMHPG=AMHPG+1

 W:$D(IOF) @IOF

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

 W !,$P(^VA(200,DUZ,0),U,2),?72,"Page 1 ",!

 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!

 S X="LISTING OF CASES OPENED WITH NO TREATMENT PLAN IN PLACE" W $$CTR(X),!

 S X="Case Open Dates: "_AMHBDD_" to "_AMHEDD W $$CTR(X,80),!

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

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

 W !,"PATIENT NAME",?23,"HRN",?31,"CASE OPEN",?41,"PROGRAM",?53,"PROVIDER",?70,"LAST VISIT"

 W !?31,"DATE",! W $$REPEAT^XLFSTR("-",80),!

 Q

AMHLETR3  ; IHS/CMI/LAB - print report of tps needing resolved ;

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

 +2       ;

 +3       ;

 +4       ;

 +5        IF '$DATA(IOF)

               DO HOME^%ZIS

 +6        WRITE @(IOF),!!

 +7        WRITE "**********  LIST CASES OPENED WITH NO TREATMENT PLAN IN PLACE **********",!!

 +8        WRITE "This report will list all patients who have a case open date,"

 +9        WRITE !,"no case closed date and no treatment plan in place."

 +10       WRITE !

 +11       IF '$DATA(^AMHSITE(DUZ(2),16,DUZ))

               Begin DoDot:1

 +12               WRITE !,"This report will only include Cases on which you are the documented"

 +13               WRITE !,"provider.",!!

               End DoDot:1

 +14       DO DBHUSRP^AMHUTIL

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !,"Please enter the date range during which the case was opened.",!

 +2        WRITE !

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

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

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET AMHBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="D^"_AMHBD_"::E"

           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        WRITE !!,"You can limit the report output to cases opened by one or all Programs",!

 +2        SET AMHPROG=""

           WRITE !

           SET DIR(0)="S^O:One Program;A:All Programs"

           SET DIR("A")="List cases opened by"

           SET DIR("B")="O"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO BD

 +4        IF Y="A"

               GOTO THER

 +5        KILL DIR

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

           SET DIR("A")="Review Cases opened by which Program"

           KILL DA

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)

               GOTO PROG

 +7        SET AMHPROG=Y

THER      ;

 +1        WRITE !!,"You can limit the report output to cases opened by one or all Providers",!

 +2        SET AMHPROV=""

           WRITE !

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

           SET DIR("A")="List cases opened by"

           SET DIR("B")="O"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        IF Y="A"

               GOTO SORT

 +5        SET DIC("A")="Which Provider: "

           SET DIC="^VA(200,"

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA

 +6        IF X=""

               GOTO THER

 +7        IF Y<0

               GOTO THER

 +8        SET AMHPROV=+Y

SORT      ;

 +1        SET AMHSORT=""

 +2        SET DIR(0)="S^P:Responsible Provider;N:Patient Name;C:Case Open Date"

           SET DIR("A")="Sort list by"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO THER

 +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        SET XBRC="PROC^AMHLETR3"

           SET XBRP="PRINT^AMHLETR3"

           SET XBNS="AMH"

           SET XBRX="XIT^AMHLETR3"

 +5        DO ^XBDBQUE

XIT       ;

 +1        DO EN^XBVK("AMH")

 +2        KILL DFN

 +3        QUIT 

 +4       ;

BROWSE    ;

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

 +2        SET XBNS="AMH"

           SET XBRC="PROC^AMHLETR3"

           SET XBRX="XIT^AMHLETR3"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

PROC      ;EP - entry point for processing

 +1        SET AMHJOB=$JOB

           SET AMHBTH=$HOROLOG

           SET AMHTOT=0

           SET AMHCASE=0

           SET AMHBT=$HOROLOG

 +2        FOR 

               SET AMHCASE=$ORDER(^AMHPCASE(AMHCASE))

               IF AMHCASE'=+AMHCASE

                   QUIT 

               DO PROC1

 +3        SET AMHET=$HOROLOG

 +4        KILL AMHCASE

 +5        QUIT 

PROC1     ;

 +1        IF '$$ALLOWCD^AMHLCD(DUZ,AMHCASE)

               QUIT 

 +2        SET DFN=$PIECE(^AMHPCASE(AMHCASE,0),U,2)

 +3        IF DFN=""

               QUIT 

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

               QUIT 

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

               QUIT 

 +6       ;CLOSED

           IF $PIECE(^AMHPCASE(AMHCASE,0),U,5)]""

               QUIT 

 +7       ;not this provider

           IF AMHPROV

               IF $PIECE(^AMHPCASE(AMHCASE,0),U,8)'=AMHPROV

                   QUIT 

 +8        SET AMHCPRV=$PIECE(^AMHPCASE(AMHCASE,0),U,8)

 +9        SET AMHCPRG=$PIECE(^AMHPCASE(AMHCASE,0),U,3)

 +10      ;not a program of interest

           IF AMHPROG]""

               IF AMHCPRG'=AMHPROG

                   QUIT 

 +11       SET AMHOD=$PIECE(^AMHPCASE(AMHCASE,0),U)

 +12       IF AMHOD<AMHBD

               QUIT 

 +13       IF AMHOD>AMHED

               QUIT 

 +14      ;is there a tp in place???

 +15      ;has a tp

           IF $$TP(AMHOD,DFN,AMHCPRV,AMHCPRG)

               QUIT 

 +16       DO @AMHSORT

 +17       SET ^XTMP("AMHLETR3",AMHJOB,AMHBTH,AMHSORTV,AMHCASE)=""

 +18       QUIT 

TP(DATE,PAT,PROV,PRG) ;

 +1       ;no tp's

           IF '$DATA(^AMHPTXP("AC",PAT))

               QUIT 0

 +2        NEW C,X,G

 +3        SET G=0

 +4        SET X=0

           FOR 

               SET X=$ORDER(^AMHPTXP("AC",PAT,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                IF $PIECE(^AMHPTXP(X,0),U,17)'=PRG

                       QUIT 

 +6                IF $PIECE(^AMHPTXP(X,0),U,4)'=PROV

                       QUIT 

 +7                IF '$$ALLOWTP^AMHLETP(DUZ,X)

                       QUIT 

 +8       ;closed before this case opened

                   IF $PIECE(^AMHPTXP(X,0),U,12)]""

                       IF $PIECE(^AMHPTXP(X,0),U,12)<DATE

                           QUIT 

 +9                IF $PIECE(^AMHPTXP(X,0),U)<DATE

                       QUIT 

 +10               IF $PIECE(^AMHPTXP(X,0),U,15)="I"

                       QUIT 

 +11               SET G=1

 +12               QUIT 

               End DoDot:1

 +13       QUIT G

P         ;

 +1        SET AMHSORTV=$PIECE(^AMHPCASE(AMHCASE,0),U,8)

 +2        IF AMHSORTV

               SET AMHSORTV=$PIECE(^VA(200,AMHSORTV,0),U)

               QUIT 

 +3        SET AMHSORTV="--"

 +4        QUIT 

N         ;

 +1        SET P=$PIECE(^AMHPCASE(AMHCASE,0),U,2)

 +2        IF P=""

               SET AMHSORVT="--"

               QUIT 

 +3        SET AMHSORTV=$PIECE(^DPT(P,0),U)

 +4        IF AMHSORTV=""

               SET AMHSORTV="--"

 +5        QUIT 

C         ;

 +1        SET AMHSORTV=$PIECE(^AMHPCASE(AMHCASE,0),U,1)

 +2        IF AMHSORTV=""

               SET AMHSORTV="--"

               QUIT 

 +3        QUIT 

PRINT     ;EP

 +1        SET AMHPG=0

           SET AMHQUIT=0

 +2        DO HEAD

 +3        IF '$DATA(^XTMP("AMHLETR3",AMHJOB,AMHBTH))

               WRITE !!,"NO DATA TO REPORT"

               GOTO DONE

 +4        SET AMHSORTV=""

           FOR 

               SET AMHSORTV=$ORDER(^XTMP("AMHLETR3",AMHJOB,AMHBTH,AMHSORTV))

               IF AMHSORTV=""!(AMHQUIT)

                   QUIT 

               DO PRT2

 +5        DO DONE

 +6        QUIT 

PRT2      ;

 +1        SET AMHCASE=0

           FOR 

               SET AMHCASE=$ORDER(^XTMP("AMHLETR3",AMHJOB,AMHBTH,AMHSORTV,AMHCASE))

               IF AMHCASE'=+AMHCASE!(AMHQUIT)

                   QUIT 

               Begin DoDot:1

 +2                IF $Y>(IOSL-4)

                       DO HEAD

                       IF AMHQUIT

                           QUIT 

 +3                SET DFN=$PIECE(^AMHPCASE(AMHCASE,0),U,2)

 +4                WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,21),?23,$$HRN^AUPNPAT(DFN,DUZ(2))

 +5                WRITE ?31,$$D($PIECE(^AMHPCASE(AMHCASE,0),U)),?41,$EXTRACT($$VAL^XBDIQ1(9002011.58,AMHCASE,.03),1,10)

 +6                WRITE ?53,$EXTRACT($$VAL^XBDIQ1(9002011.58,AMHCASE,.08),1,15)

 +7                WRITE ?72,$$D($$LVD^AMHDPEE(DFN,"ID"))

               End DoDot:1

 +8        QUIT 

DONE      ;

 +1        KILL ^XTMP("AMHLETR3",AMHJOB,AMHBTH),AMHJOB,AMHBTH

 +2        QUIT 

D(D)      ;

 +1        IF $GET(D)=""

               QUIT ""

 +2        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)

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       ;----------

HEAD      ;

 +1        IF 'AMHPG

               GOTO HEAD1

 +2        NEW X

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

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

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

                       SET AMHQUIT=1

                       QUIT 

HEAD1     ;EP

 +1        SET AMHPG=AMHPG+1

 +2        IF $DATA(IOF)

               WRITE @IOF

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

 +4        WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page 1 ",!

 +5        WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!

 +6        SET X="LISTING OF CASES OPENED WITH NO TREATMENT PLAN IN PLACE"

           WRITE $$CTR(X),!

 +7        SET X="Case Open Dates: "_AMHBDD_" to "_AMHEDD

           WRITE $$CTR(X,80),!

 +8        IF $GET(AMHPROV)

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

               WRITE $$CTR(X),!

 +9        IF AMHPROG]""

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

               WRITE $$CTR(X),!

 +10       WRITE !,"PATIENT NAME",?23,"HRN",?31,"CASE OPEN",?41,"PROGRAM",?53,"PROVIDER",?70,"LAST VISIT"

 +11       WRITE !?31,"DATE",!

           WRITE $$REPEAT^XLFSTR("-",80),!

 +12       QUIT