AMHLETPP ; IHS/CMI/LAB - DISPLAY A TREATMENT PLAN ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,4**;JUN 18, 2010;Build 28
;
PRINT ;EP - called from xbdbque
Q:'$G(AMHTP)
Q:'$D(^AMHPTXP(AMHTP))
S DFN=$P(^AMHPTXP(AMHTP,0),U,2)
S (AMHQUIT,AMHPG)=0
S AMHIOSL=$S($G(AMHGUI):55,1:IOSL)
;print/display treatment plan
I AMHPREV="R" G REV^AMHLETP3
D HEAD
;I $Y>(AMHIOSL-5) D HEAD Q:AMHQUIT
W !,"Date Established: ",?30,$$FMTE^XLFDT($P(^AMHPTXP(AMHTP,0),U))
W !,"Admit Date: ",?30,$$FMTE^XLFDT($P(^AMHPTXP(AMHTP,0),U,16))
W !,"Anticipated Completion Date: ",?30,$$FMTE^XLFDT($P(^AMHPTXP(AMHTP,0),U,3))
W !,"Date Closed: ",?30,$$FMTE^XLFDT($P(^AMHPTXP(AMHTP,0),U,12))
I $Y>(AMHIOSL-4) D HEAD Q:AMHQUIT
W !,"Provider: ",?30,$S($P(^AMHPTXP(AMHTP,0),U,4):$E($P(^VA(200,$P(^AMHPTXP(AMHTP,0),U,4),0),U),1,25),1:"<not recorded>")
W !,"Supervisor: ",?30,$S($P(^AMHPTXP(AMHTP,0),U,5):$E($P(^VA(200,$P(^AMHPTXP(AMHTP,0),U,5),0),U),1,25),1:"<not recorded>")
W !?3," Date Concurred: ",?30,$$FMTE^XLFDT($P(^AMHPTXP(AMHTP,0),U,6))
NR ;
W !,"Review Date: ",?30,$$FMTE^XLFDT($P(^AMHPTXP(AMHTP,0),U,9))
I $O(^AMHPTXP(AMHTP,17,0)) D
.W !,"Participants in Plan Creation:"
.S AMHX=0 F S AMHX=$O(^AMHPTXP(AMHTP,17,AMHX)) Q:AMHX'=+AMHX D
..I $Y>(AMHIOSL-3) D HEAD Q:AMHQUIT
..W !?3,$P(^AMHPTXP(AMHTP,17,AMHX,0),U,1),?40,$P(^AMHPTXP(AMHTP,17,AMHX,0),U,2)
Q:AMHQUIT
;W !,"Status:",?27,$$VAL^XBDIQ1(9002011.56,AMHTP,.15)
W !!,"DIAGNOSIS",!
;IF HAVE 2100 DISPLAY IT
I '$O(^AMHPTXP(AMHTP,21,0)) G I
K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=21,AMHDA=AMHTP,AMHFILE=9002011.56 D WP^AMHLETP4
I $D(AMHPRNM) S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT W $TR(AMHPRNM(X),$C(10)),!
I ;
I '$O(^AMHPTXP(AMHTP,6,0)) G II
W !,"AXIS I",!
K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=6,AMHDA=AMHTP,AMHFILE=9002011.56 D WP^AMHLETP4
I $D(AMHPRNM) S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT W $TR(AMHPRNM(X),$C(10)),!
Q:AMHQUIT
II ;
I '$O(^AMHPTXP(AMHTP,8,0)) G III
W !,"AXIS II",!
K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=8,AMHDA=AMHTP,AMHFILE=9002011.56 D WP^AMHLETP4
I $D(AMHPRNM) S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT W $TR(AMHPRNM(X),$C(10)),!
Q:AMHQUIT
III ;
I '$O(^AMHPTXP(AMHTP,7,0)) G IV
W !,"AXIS III",!
K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=7,AMHDA=AMHTP,AMHFILE=9002011.56 D WP^AMHLETP4
I $D(AMHPRNM) S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT W $TR(AMHPRNM(X),$C(10)),!
Q:AMHQUIT
IV ;
I $G(^AMHPTXP(AMHTP,15))="",'$O(^AMHPTXP(AMHTP,9,0)) G V
W !,"AXIS IV "
I $G(^AMHPTXP(AMHTP,15))]"" D
.K AMHLETXT S AMHLETP("ICL")=0,AMHLETP("LGTH")=65,AMHLETP("NRQ")=$G(^AMHPTXP(AMHTP,15)),AMHLETP("TXT")="",AMHLEC=0
.D GETTXT^AMHLETP
.W ! S X=0 F S X=$O(AMHLETXT(X)) Q:X'=+X!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT W ?12,$TR(AMHLETXT(X),$C(10)),!
S AMHX=0 F S AMHX=$O(^AMHPTXP(AMHTP,9,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT D
.I $P(^AMHPTXP(AMHTP,9,AMHX,0),U) W ?12,$P(^AMHTAXIV($P(^AMHPTXP(AMHTP,9,AMHX,0),U),0),U,1)_" "_$P(^AMHTAXIV($P(^AMHPTXP(AMHTP,9,AMHX,0),U),0),U,2),!
Q:AMHQUIT
V ;
I $P($G(^AMHPTXP(AMHTP,16)),U,1)="",$P($G(^AMHPTXP(AMHTP,16)),U,2)="" G GATHER
K AMHLETXT S AMHLETP("ICL")=0,AMHLETP("LGTH")=65,AMHLETP("NRQ")=$P($G(^AMHPTXP(AMHTP,16)),U,1) S:$P($G(^AMHPTXP(AMHTP,16)),U,2)]"" AMHLETP("NRQ")=AMHLETP("NRQ")_" GAF Scale Type: "_$P($G(^AMHPTXP(AMHTP,16)),U,2) S AMHLETP("TXT")="",AMHLEC=0
D GETTXT^AMHLETP
W !,"AXIS V " S X=0 F S X=$O(AMHLETXT(X)) Q:X'=+X!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT W ?12,$TR(AMHLETXT(X),$C(10)),!
Q:AMHQUIT
GATHER ;gather up and display all problems/goals/met
PL ;
I $Y>(AMHIOSL-4) D HEAD Q:AMHQUIT
W !!!,"PROBLEM LIST"
DX ;
TPP ;
I $Y>(AMHIOSL-4) D HEAD Q:AMHQUIT
W !,$G(^AMHPTXP(AMHTP,11)),!
W !!,"TREATMENT PLAN (Problems/Goals/Objectives/Methods)",!
K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=18,AMHDA=AMHTP,AMHFILE=9002011.56 D WP^AMHLETP4
I $D(AMHPRNM) S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X!(AMHQUIT) D:$Y>(AMHIOSL-3) HEAD Q:AMHQUIT W $TR(AMHPRNM(X),$C(10)),!
Q:AMHQUIT
D ^AMHLETP3
Q
HEAD ;ENTRY POINT
I 'AMHPG G HEAD1
NEW X
I '$G(AMHBROW),$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
;Q
HEAD1 ;EP
I AMHPG W:$D(IOF) @IOF
S AMHPG=AMHPG+1
W:$G(AMHGUI) "ZZZZZZZ",!
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !,$TR($J("",80)," ","*")
W !,"*",?79,"*"
W !,"* TREATMENT PLAN",?45,"Printed: "_$$FMTE^XLFDT($$NOW^XLFDT),?79,"*"
W !,"* Name: ",$P(^DPT(DFN,0),U),?68,"Page ",AMHPG,?79,"*"
W !,"* ",$E($P(^DIC(4,DUZ(2),0),U),1,25),?30,"DOB: ",$$FMTE^XLFDT($P(^DPT(DFN,0),U,3),"2D"),?46,"Sex: ",$P(^DPT(DFN,0),U,2),?54," Chart #: ",$P(^AUTTLOC(DUZ(2),0),U,7),$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),?79,"*"
W !,"*",?79,"*"
W !,$TR($J("",80)," ","*"),!
Q
AMHLETPP ; IHS/CMI/LAB - DISPLAY A TREATMENT PLAN ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,4**;JUN 18, 2010;Build 28
+2 ;
PRINT ;EP - called from xbdbque
+1 IF '$GET(AMHTP)
QUIT
+2 IF '$DATA(^AMHPTXP(AMHTP))
QUIT
+3 SET DFN=$PIECE(^AMHPTXP(AMHTP,0),U,2)
+4 SET (AMHQUIT,AMHPG)=0
+5 SET AMHIOSL=$SELECT($GET(AMHGUI):55,1:IOSL)
+6 ;print/display treatment plan
+7 IF AMHPREV="R"
GOTO REV^AMHLETP3
+8 DO HEAD
+9 ;I $Y>(AMHIOSL-5) D HEAD Q:AMHQUIT
+10 WRITE !,"Date Established: ",?30,$$FMTE^XLFDT($PIECE(^AMHPTXP(AMHTP,0),U))
+11 WRITE !,"Admit Date: ",?30,$$FMTE^XLFDT($PIECE(^AMHPTXP(AMHTP,0),U,16))
+12 WRITE !,"Anticipated Completion Date: ",?30,$$FMTE^XLFDT($PIECE(^AMHPTXP(AMHTP,0),U,3))
+13 WRITE !,"Date Closed: ",?30,$$FMTE^XLFDT($PIECE(^AMHPTXP(AMHTP,0),U,12))
+14 IF $Y>(AMHIOSL-4)
DO HEAD
IF AMHQUIT
QUIT
+15 WRITE !,"Provider: ",?30,$SELECT($PIECE(^AMHPTXP(AMHTP,0),U,4):$EXTRACT($PIECE(^VA(200,$PIECE(^AMHPTXP(AMHTP,0),U,4),0),U),1,25),1:"<not recorded>")
+16 WRITE !,"Supervisor: ",?30,$SELECT($PIECE(^AMHPTXP(AMHTP,0),U,5):$EXTRACT($PIECE(^VA(200,$PIECE(^AMHPTXP(AMHTP,0),U,5),0),U),1,25),1:"<not recorded>")
+17 WRITE !?3," Date Concurred: ",?30,$$FMTE^XLFDT($PIECE(^AMHPTXP(AMHTP,0),U,6))
NR ;
+1 WRITE !,"Review Date: ",?30,$$FMTE^XLFDT($PIECE(^AMHPTXP(AMHTP,0),U,9))
+2 IF $ORDER(^AMHPTXP(AMHTP,17,0))
Begin DoDot:1
+3 WRITE !,"Participants in Plan Creation:"
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPTXP(AMHTP,17,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+5 IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
+6 WRITE !?3,$PIECE(^AMHPTXP(AMHTP,17,AMHX,0),U,1),?40,$PIECE(^AMHPTXP(AMHTP,17,AMHX,0),U,2)
End DoDot:2
End DoDot:1
+7 IF AMHQUIT
QUIT
+8 ;W !,"Status:",?27,$$VAL^XBDIQ1(9002011.56,AMHTP,.15)
+9 WRITE !!,"DIAGNOSIS",!
+10 ;IF HAVE 2100 DISPLAY IT
+11 IF '$ORDER(^AMHPTXP(AMHTP,21,0))
GOTO I
+12 KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=21
SET AMHDA=AMHTP
SET AMHFILE=9002011.56
DO WP^AMHLETP4
+13 IF $DATA(AMHPRNM)
SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE $TRANSLATE(AMHPRNM(X),$CHAR(10)),!
I ;
+1 IF '$ORDER(^AMHPTXP(AMHTP,6,0))
GOTO II
+2 WRITE !,"AXIS I",!
+3 KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=6
SET AMHDA=AMHTP
SET AMHFILE=9002011.56
DO WP^AMHLETP4
+4 IF $DATA(AMHPRNM)
SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE $TRANSLATE(AMHPRNM(X),$CHAR(10)),!
+5 IF AMHQUIT
QUIT
II ;
+1 IF '$ORDER(^AMHPTXP(AMHTP,8,0))
GOTO III
+2 WRITE !,"AXIS II",!
+3 KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=8
SET AMHDA=AMHTP
SET AMHFILE=9002011.56
DO WP^AMHLETP4
+4 IF $DATA(AMHPRNM)
SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE $TRANSLATE(AMHPRNM(X),$CHAR(10)),!
+5 IF AMHQUIT
QUIT
III ;
+1 IF '$ORDER(^AMHPTXP(AMHTP,7,0))
GOTO IV
+2 WRITE !,"AXIS III",!
+3 KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=7
SET AMHDA=AMHTP
SET AMHFILE=9002011.56
DO WP^AMHLETP4
+4 IF $DATA(AMHPRNM)
SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE $TRANSLATE(AMHPRNM(X),$CHAR(10)),!
+5 IF AMHQUIT
QUIT
IV ;
+1 IF $GET(^AMHPTXP(AMHTP,15))=""
IF '$ORDER(^AMHPTXP(AMHTP,9,0))
GOTO V
+2 WRITE !,"AXIS IV "
+3 IF $GET(^AMHPTXP(AMHTP,15))]""
Begin DoDot:1
+4 KILL AMHLETXT
SET AMHLETP("ICL")=0
SET AMHLETP("LGTH")=65
SET AMHLETP("NRQ")=$GET(^AMHPTXP(AMHTP,15))
SET AMHLETP("TXT")=""
SET AMHLEC=0
+5 DO GETTXT^AMHLETP
+6 WRITE !
SET X=0
FOR
SET X=$ORDER(AMHLETXT(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE ?12,$TRANSLATE(AMHLETXT(X),$CHAR(10)),!
End DoDot:1
+7 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPTXP(AMHTP,9,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
Begin DoDot:1
+8 IF $PIECE(^AMHPTXP(AMHTP,9,AMHX,0),U)
WRITE ?12,$PIECE(^AMHTAXIV($PIECE(^AMHPTXP(AMHTP,9,AMHX,0),U),0),U,1)_" "_$PIECE(^AMHTAXIV($PIECE(^AMHPTXP(AMHTP,9,AMHX,0),U),0),U,2),!
End DoDot:1
+9 IF AMHQUIT
QUIT
V ;
+1 IF $PIECE($GET(^AMHPTXP(AMHTP,16)),U,1)=""
IF $PIECE($GET(^AMHPTXP(AMHTP,16)),U,2)=""
GOTO GATHER
+2 KILL AMHLETXT
SET AMHLETP("ICL")=0
SET AMHLETP("LGTH")=65
SET AMHLETP("NRQ")=$PIECE($GET(^AMHPTXP(AMHTP,16)),U,1)
IF $PIECE($GET(^AMHPTXP(AMHTP,16)),U,2)]""
SET AMHLETP("NRQ")=AMHLETP("NRQ")_" GAF Scale Type: "_$PIECE($GET(^AMHPTXP(AMHTP,16)),U,2)
SET AMHLETP("TXT")=""
SET AMHLEC=0
+3 DO GETTXT^AMHLETP
+4 WRITE !,"AXIS V "
SET X=0
FOR
SET X=$ORDER(AMHLETXT(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE ?12,$TRANSLATE(AMHLETXT(X),$CHAR(10)),!
+5 IF AMHQUIT
QUIT
GATHER ;gather up and display all problems/goals/met
PL ;
+1 IF $Y>(AMHIOSL-4)
DO HEAD
IF AMHQUIT
QUIT
+2 WRITE !!!,"PROBLEM LIST"
DX ;
TPP ;
+1 IF $Y>(AMHIOSL-4)
DO HEAD
IF AMHQUIT
QUIT
+2 WRITE !,$GET(^AMHPTXP(AMHTP,11)),!
+3 WRITE !!,"TREATMENT PLAN (Problems/Goals/Objectives/Methods)",!
+4 KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=18
SET AMHDA=AMHTP
SET AMHFILE=9002011.56
DO WP^AMHLETP4
+5 IF $DATA(AMHPRNM)
SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(AMHIOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE $TRANSLATE(AMHPRNM(X),$CHAR(10)),!
+6 IF AMHQUIT
QUIT
+7 DO ^AMHLETP3
+8 QUIT
HEAD ;ENTRY POINT
+1 IF 'AMHPG
GOTO HEAD1
+2 NEW X
+3 IF '$GET(AMHBROW)
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
+4 ;Q
HEAD1 ;EP
+1 IF AMHPG
IF $DATA(IOF)
WRITE @IOF
+2 SET AMHPG=AMHPG+1
+3 IF $GET(AMHGUI)
WRITE "ZZZZZZZ",!
+4 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+5 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*")
+6 WRITE !,"*",?79,"*"
+7 WRITE !,"* TREATMENT PLAN",?45,"Printed: "_$$FMTE^XLFDT($$NOW^XLFDT),?79,"*"
+8 WRITE !,"* Name: ",$PIECE(^DPT(DFN,0),U),?68,"Page ",AMHPG,?79,"*"
+9 WRITE !,"* ",$EXTRACT($PIECE(^DIC(4,DUZ(2),0),U),1,25),?30,"DOB: ",$$FMTE^XLFDT($PIECE(^DPT(DFN,0),U,3),"2D"),?46,"Sex: ",$PIECE(^DPT(DFN,0),U,2),?54," Chart #: ",$PIECE(^AUTTLOC(DUZ(2),0),U,7),$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),?
79,"*"
+10 WRITE !,"*",?79,"*"
+11 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*"),!
+12 QUIT
