AMHLETR2 ; 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 **********",!!
W "This report will list all patients who have a treatment plan on file."
D DBHUSRP^AMHUTIL
GETDATES ;
BD ;get beginning date
W !,"Please enter the date range during which the treatment plan was established.",!
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) XIT
G:Y="A" SORT
S DIC("A")="Which Designated Provider: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC,DA
I X="" G THER
I Y<0 G THER
S AMHTHER=+Y
SORT ;
S AMHSORT=""
S DIR(0)="S^P:Responsible Provider;N:Patient Name;D:Date Established",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 THER
ZIS ;
S XBRC="PROC^AMHLETR2",XBRP="PRINT^AMHLETR2",XBNS="AMH",XBRX="XIT^AMHLETR2"
D ^XBDBQUE
XIT ;
D EN^XBVK("AMH")
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)="" ;no patient
Q:'$$ALLOWP^AMHUTIL(DUZ,$P(X,U,2))
Q:$$DEMO^AMHUTIL1($P(X,U,2),$G(AMHDEMO))
Q:'$$ALLOWTP^AMHLETP(DUZ,AMHTP)
I $G(AMHTHER),$P(X,U,4)'=AMHTHER Q
I AMHPROG]"",$P(X,U,17)'=AMHPROG Q
D @AMHSORT
I $P(X,U,1)]"",$P(X,U,1)'<AMHBD,$P(X,U,1)'>AMHED S ^XTMP("AMHLETR2",AMHJOB,AMHBTH,AMHSORTV,AMHTP)=""
Q
P ;
S AMHSORTV=$P(X,U,4)
I AMHSORTV S AMHSORTV=$P(^VA(200,AMHSORTV,0),U) Q
S AMHSORTV="--"
Q
N ;
S P=$P(^AMHPTXP(AMHTP,0),U,2)
I P="" S AMHSORVT="--" Q
S AMHSORTV=$P(^DPT(P,0),U)
I AMHSORTV="" S AMHSORTV="--"
Q
D ;
S AMHSORTV=$P(^AMHPTXP(AMHTP,0),U,1)
I AMHSORTV="" S AMHSORTV="--" Q
Q
PRINT ;EP
S AMH80D="-------------------------------------------------------------------------------",AMHQUIT=0,AMHPG=0
D HEAD
I '$D(^XTMP("AMHLETR2",AMHJOB,AMHBTH)) W !!,"NO DATA TO REPORT" G DONE
S AMHSORTV="" F S AMHSORTV=$O(^XTMP("AMHLETR2",AMHJOB,AMHBTH,AMHSORTV)) Q:AMHSORTV=""!(AMHQUIT) D PRT2
D DONE
Q
PRT2 ;
S AMHTP=0 F S AMHTP=$O(^XTMP("AMHLETR2",AMHJOB,AMHBTH,AMHSORTV,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
.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:"???")
.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:"????")
Q
DONE D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHLETR2",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),!
S X="LISTING OF TREATMENT PLANS" W $$CTR(X),!
W ?20,"Date Established: ",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
AMHLETR2 ; 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 **********",!!
+9 WRITE "This report will list all patients who have a treatment plan on file."
+10 DO DBHUSRP^AMHUTIL
GETDATES ;
BD ;get beginning date
+1 WRITE !,"Please enter the date range during which the treatment plan was established.",!
+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 XIT
+4 IF Y="A"
GOTO SORT
+5 SET DIC("A")="Which Designated 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
SORT ;
+1 SET AMHSORT=""
+2 SET DIR(0)="S^P:Responsible Provider;N:Patient Name;D:Date Established"
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 THER
ZIS ;
+1 SET XBRC="PROC^AMHLETR2"
SET XBRP="PRINT^AMHLETR2"
SET XBNS="AMH"
SET XBRX="XIT^AMHLETR2"
+2 DO ^XBDBQUE
XIT ;
+1 DO EN^XBVK("AMH")
+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 ;no patient
IF $PIECE(X,U,2)=""
QUIT
+3 IF '$$ALLOWP^AMHUTIL(DUZ,$PIECE(X,U,2))
QUIT
+4 IF $$DEMO^AMHUTIL1($PIECE(X,U,2),$GET(AMHDEMO))
QUIT
+5 IF '$$ALLOWTP^AMHLETP(DUZ,AMHTP)
QUIT
+6 IF $GET(AMHTHER)
IF $PIECE(X,U,4)'=AMHTHER
QUIT
+7 IF AMHPROG]""
IF $PIECE(X,U,17)'=AMHPROG
QUIT
+8 DO @AMHSORT
+9 IF $PIECE(X,U,1)]""
IF $PIECE(X,U,1)'<AMHBD
IF $PIECE(X,U,1)'>AMHED
SET ^XTMP("AMHLETR2",AMHJOB,AMHBTH,AMHSORTV,AMHTP)=""
+10 QUIT
P ;
+1 SET AMHSORTV=$PIECE(X,U,4)
+2 IF AMHSORTV
SET AMHSORTV=$PIECE(^VA(200,AMHSORTV,0),U)
QUIT
+3 SET AMHSORTV="--"
+4 QUIT
N ;
+1 SET P=$PIECE(^AMHPTXP(AMHTP,0),U,2)
+2 IF P=""
SET AMHSORVT="--"
QUIT
+3 SET AMHSORTV=$PIECE(^DPT(P,0),U)
+4 IF AMHSORTV=""
SET AMHSORTV="--"
+5 QUIT
D ;
+1 SET AMHSORTV=$PIECE(^AMHPTXP(AMHTP,0),U,1)
+2 IF AMHSORTV=""
SET AMHSORTV="--"
QUIT
+3 QUIT
PRINT ;EP
+1 SET AMH80D="-------------------------------------------------------------------------------"
SET AMHQUIT=0
SET AMHPG=0
+2 DO HEAD
+3 IF '$DATA(^XTMP("AMHLETR2",AMHJOB,AMHBTH))
WRITE !!,"NO DATA TO REPORT"
GOTO DONE
+4 SET AMHSORTV=""
FOR
SET AMHSORTV=$ORDER(^XTMP("AMHLETR2",AMHJOB,AMHBTH,AMHSORTV))
IF AMHSORTV=""!(AMHQUIT)
QUIT
DO PRT2
+5 DO DONE
+6 QUIT
PRT2 ;
+1 SET AMHTP=0
FOR
SET AMHTP=$ORDER(^XTMP("AMHLETR2",AMHJOB,AMHBTH,AMHSORTV,AMHTP))
IF AMHTP'=+AMHTP!(AMHQUIT)
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-4)
DO HEAD
IF AMHQUIT
QUIT
+3 SET AMHTPR=^AMHPTXP(AMHTP,0)
+4 SET Y=$PIECE(AMHTPR,U,2)
IF Y
DO ^AUPNPAT
+5 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:"???")
+6 WRITE ?41,$$FMTE^XLFDT($PIECE(AMHTPR,U,1)),?54,$$FMTE^XLFDT($PIECE(AMHTPR,U,9)),?68,$$FMTE^XLFDT($PIECE(AMHTPR,U,3))
+7 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
+8 QUIT
DONE DO DONE^AMHLEIN
DO ^AMHEKL
+1 KILL ^XTMP("AMHLETR2",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 SET X="LISTING OF TREATMENT PLANS"
WRITE $$CTR(X),!
+7 WRITE ?20,"Date Established: ",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
