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
