AMHLETR1 ; IHS/CMI/LAB - print report of tps needing resolved ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;fixed potential undef
;
;
I '$D(IOF) D HOME^%ZIS
W @(IOF),!!
W "********** LIST TREATMENT PLANS BY NEXT REVIEW DATE **********",!!
W "This report will list all patients who have a treatment plan which is due",!,"to be reviewed in a date range specified by the user.",!
D DBHUSRP^AMHUTIL
GETDATES ;
BD ;get beginning date
W !,"Please enter the date range during which the treatment plan is to be reviewed.",!
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 ;
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 THER
S DIR(0)="9002011.56,.17",DIR("A")="Which PROGRAM" KILL DA D ^DIR KILL DIR
G:$D(DIRUT) PROG
I X="" G PROG
S AMHPROG=Y
THER ;
W !!,"You can limit the report output to treatment plans for one or all Providers",!
K AMHTHER W ! S DIR(0)="S^O:One Provider;A:All Providers",DIR("A")="List treatment plans for",DIR("B")="O" K DA D ^DIR K DIR
G:$D(DIRUT) BD
G:Y="A" DEMO
S DIC("A")="Which Responsible Provider: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC,DA
I X="" G THER
I Y<0 G THER
S AMHTHER=+Y
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G THER
ZIS ;
S XBRC="PROC^AMHLETR1",XBRP="PRINT^AMHLETR1",XBNS="AMH",XBRX="XIT^AMHLETR1"
D ^XBDBQUE
XIT ;EP
K AMHTP,AMHED,AMHBD,AMHBDD,AMHEDD,AMHBTH,AMHJOB,AMHTPR,AMHET,AMH80D,AMHTHER
Q
;
PROC ;EP - entry point for processing
S AMHJOB=$J,AMHBTH=$H,AMHTOT=0,AMHTP=0,AMHBT=$H
F S AMHTP=$O(^AMHPTXP(AMHTP)) Q:AMHTP'=+AMHTP D PROC1
S AMHET=$H
K AMHTP
Q
PROC1 ;
S X=$G(^AMHPTXP(AMHTP,0))
Q:$P(X,U,2)=""
Q:'$$ALLOWP^AMHUTIL(DUZ,$P(X,U,2))
Q:'$$ALLOWTP^AMHLETP(DUZ,AMHTP)
Q:$$DEMO^AMHUTIL1($P(X,U,2),$G(AMHDEMO))
I $G(AMHTHER),$P(X,U,4)'=AMHTHER Q
I AMHPROG]"",$P(X,U,17)'=AMHPROG Q
I $P(^AMHPTXP(AMHTP,0),U,12)]"" Q ;don't display those resolved
I $P(X,U,9)]"",$P(X,U,9)'<AMHBD,$P(X,U,9)'>AMHED S ^XTMP("AMHLETR1",AMHJOB,AMHBTH,AMHTP)=""
Q
PRINT ;EP
S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y
S AMH80D="-------------------------------------------------------------------------------",AMHQUIT=0,AMHPG=0
D HEAD
I '$D(^XTMP("AMHLETR1",AMHJOB,AMHBTH)) W !!,"NO DATA TO REPORT" G DONE
S AMHTP=0 F S AMHTP=$O(^XTMP("AMHLETR1",AMHJOB,AMHBTH,AMHTP)) Q:AMHTP'=+AMHTP!(AMHQUIT) D
.I $Y>(IOSL-4) D HEAD Q:AMHQUIT
.S AMHTPR=^AMHPTXP(AMHTP,0)
.S Y=$P(AMHTPR,U,2) I Y D ^AUPNPAT
.I $P(AMHTPR,U,2)="" W !,"????",?23,"????",?33,"????" G P1
.W !,$S($P(AMHTPR,U,2):$P(^DPT($P(AMHTPR,U,2),0),U),1:"????"),?23,$$FMTE^XLFDT(AUPNDOB,"2D"),?33,$S($P($G(^AUPNPAT($P(AMHTPR,U,2),41,DUZ(2),0)),U,2):$P(^AUPNPAT($P(AMHTPR,U,2),41,DUZ(2),0),U,2),1:"???")
P1 .W ?41,$$FMTE^XLFDT($P(AMHTPR,U,1)),?54,$$FMTE^XLFDT($P(AMHTPR,U,9)),?68,$$FMTE^XLFDT($P(AMHTPR,U,3))
.W !?3,"Program: ",$$VAL^XBDIQ1(9002011.56,AMHTP,.17),?33,"Responsible Provider: ",$S($P(AMHTPR,U,4):$P(^VA(200,$P(AMHTPR,U,4),0),U),1:"????")
DONE D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHLETR1",AMHJOB,AMHBTH),AMHJOB,AMHBTH
Q
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),!
W ?13,"LISTING OF TREATMENT PLANS DUE TO BE REVIEWED",!
W ?20,"Date Range: ",AMHBDD," to ",AMHEDD,!
I AMHPROG]"" S X="Program: "_$$EXTSET^XBFUNC(9002011.56,.17,AMHPROG) W $$CTR(X),!
I $G(AMHTHER) S X="Responsible Provider: "_$P(^VA(200,AMHTHER,0),U) W $$CTR(X),!
W !,"PATIENT NAME",?23,"DOB",?33,"CHART #",?41,"DATE",?54,"REVIEW DATE",?68,"ANTICIPATED"
W !?41,"ESTABLISHED",?68,"COMPLETION",!?68,"DATE"
W !
W AMH80D,!
Q
AMHLETR1 ; IHS/CMI/LAB - print report of tps needing resolved ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;fixed potential undef
+4 ;
+5 ;
+6 IF '$DATA(IOF)
DO HOME^%ZIS
+7 WRITE @(IOF),!!
+8 WRITE "********** LIST TREATMENT PLANS BY NEXT REVIEW DATE **********",!!
+9 WRITE "This report will list all patients who have a treatment plan which is due",!,"to be reviewed in a date range specified by the user.",!
+10 DO DBHUSRP^AMHUTIL
GETDATES ;
BD ;get beginning date
+1 WRITE !,"Please enter the date range during which the treatment plan is to be reviewed.",!
+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 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 THER
+5 SET DIR(0)="9002011.56,.17"
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
THER ;
+1 WRITE !!,"You can limit the report output to treatment plans for one or all Providers",!
+2 KILL AMHTHER
WRITE !
SET DIR(0)="S^O:One Provider;A:All Providers"
SET DIR("A")="List treatment plans for"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO BD
+4 IF Y="A"
GOTO DEMO
+5 SET DIC("A")="Which Responsible 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 AMHTHER=+Y
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO THER
ZIS ;
+1 SET XBRC="PROC^AMHLETR1"
SET XBRP="PRINT^AMHLETR1"
SET XBNS="AMH"
SET XBRX="XIT^AMHLETR1"
+2 DO ^XBDBQUE
XIT ;EP
+1 KILL AMHTP,AMHED,AMHBD,AMHBDD,AMHEDD,AMHBTH,AMHJOB,AMHTPR,AMHET,AMH80D,AMHTHER
+2 QUIT
+3 ;
PROC ;EP - entry point for processing
+1 SET AMHJOB=$JOB
SET AMHBTH=$HOROLOG
SET AMHTOT=0
SET AMHTP=0
SET AMHBT=$HOROLOG
+2 FOR
SET AMHTP=$ORDER(^AMHPTXP(AMHTP))
IF AMHTP'=+AMHTP
QUIT
DO PROC1
+3 SET AMHET=$HOROLOG
+4 KILL AMHTP
+5 QUIT
PROC1 ;
+1 SET X=$GET(^AMHPTXP(AMHTP,0))
+2 IF $PIECE(X,U,2)=""
QUIT
+3 IF '$$ALLOWP^AMHUTIL(DUZ,$PIECE(X,U,2))
QUIT
+4 IF '$$ALLOWTP^AMHLETP(DUZ,AMHTP)
QUIT
+5 IF $$DEMO^AMHUTIL1($PIECE(X,U,2),$GET(AMHDEMO))
QUIT
+6 IF $GET(AMHTHER)
IF $PIECE(X,U,4)'=AMHTHER
QUIT
+7 IF AMHPROG]""
IF $PIECE(X,U,17)'=AMHPROG
QUIT
+8 ;don't display those resolved
IF $PIECE(^AMHPTXP(AMHTP,0),U,12)]""
QUIT
+9 IF $PIECE(X,U,9)]""
IF $PIECE(X,U,9)'<AMHBD
IF $PIECE(X,U,9)'>AMHED
SET ^XTMP("AMHLETR1",AMHJOB,AMHBTH,AMHTP)=""
+10 QUIT
PRINT ;EP
+1 SET Y=AMHBD
DO DD^%DT
SET AMHBDD=Y
SET Y=AMHED
DO DD^%DT
SET AMHEDD=Y
+2 SET AMH80D="-------------------------------------------------------------------------------"
SET AMHQUIT=0
SET AMHPG=0
+3 DO HEAD
+4 IF '$DATA(^XTMP("AMHLETR1",AMHJOB,AMHBTH))
WRITE !!,"NO DATA TO REPORT"
GOTO DONE
+5 SET AMHTP=0
FOR
SET AMHTP=$ORDER(^XTMP("AMHLETR1",AMHJOB,AMHBTH,AMHTP))
IF AMHTP'=+AMHTP!(AMHQUIT)
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-4)
DO HEAD
IF AMHQUIT
QUIT
+7 SET AMHTPR=^AMHPTXP(AMHTP,0)
+8 SET Y=$PIECE(AMHTPR,U,2)
IF Y
DO ^AUPNPAT
+9 IF $PIECE(AMHTPR,U,2)=""
WRITE !,"????",?23,"????",?33,"????"
GOTO P1
+10 WRITE !,$SELECT($PIECE(AMHTPR,U,2):$PIECE(^DPT($PIECE(AMHTPR,U,2),0),U),1:"????"),?23,$$FMTE^XLFDT(AUPNDOB,"2D"),?33,$SELECT($PIECE($GET(^AUPNPAT($PIECE(AMHTPR,U,2),41,DUZ(2),0)),U,2):$PIECE(^AUPNPAT($PIECE(AMHTPR,U,2),41,DUZ(2),0),U,2)
,1:"???")
P1 WRITE ?41,$$FMTE^XLFDT($PIECE(AMHTPR,U,1)),?54,$$FMTE^XLFDT($PIECE(AMHTPR,U,9)),?68,$$FMTE^XLFDT($PIECE(AMHTPR,U,3))
+1 WRITE !?3,"Program: ",$$VAL^XBDIQ1(9002011.56,AMHTP,.17),?33,"Responsible Provider: ",$SELECT($PIECE(AMHTPR,U,4):$PIECE(^VA(200,$PIECE(AMHTPR,U,4),0),U),1:"????")
End DoDot:1
DONE DO DONE^AMHLEIN
DO ^AMHEKL
+1 KILL ^XTMP("AMHLETR1",AMHJOB,AMHBTH),AMHJOB,AMHBTH
+2 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 ;----------
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 WRITE ?13,"LISTING OF TREATMENT PLANS DUE TO BE REVIEWED",!
+7 WRITE ?20,"Date Range: ",AMHBDD," to ",AMHEDD,!
+8 IF AMHPROG]""
SET X="Program: "_$$EXTSET^XBFUNC(9002011.56,.17,AMHPROG)
WRITE $$CTR(X),!
+9 IF $GET(AMHTHER)
SET X="Responsible Provider: "_$PIECE(^VA(200,AMHTHER,0),U)
WRITE $$CTR(X),!
+10 WRITE !,"PATIENT NAME",?23,"DOB",?33,"CHART #",?41,"DATE",?54,"REVIEW DATE",?68,"ANTICIPATED"
+11 WRITE !?41,"ESTABLISHED",?68,"COMPLETION",!?68,"DATE"
+12 WRITE !
+13 WRITE AMH80D,!
+14 QUIT
