- 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
