AMHLEI3 ; IHS/CMI/LAB - treatment plan update ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
PRINT ;EP
I '$G(AMHPAT) W !!,"ERROR - Patient not defined!" Q
D FULL^VALM1
;print or browse
W ! S DIR(0)="S^P:PRINT Output on Paper;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) D PAUSE,BACK^AMHLEI Q
I $G(Y)="B" D BROWSE D BACK^AMHLEI Q
D EN1
D BACK^AMHLEI
Q
BROWSE ;
S AMHBROW=1 D VIEWR^XBLM("PRINT1^AMHLEI3","Display of Intake Document") K AMHBROW
Q
EN1 ;EP - called from protocol
;DFN must be equal to patient
Q:'$G(DFN)
Q:'$D(^DPT(DFN))
;get device
S XBRP="PRINT1^AMHLEI3",XBRC="",XBRX="XIT^AMHLEI3",XBNS="AMH;DFN"
D ^XBDBQUE
D BACK^AMHLEI
Q
XIT ;
Q
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
PRINT1 ;EP - called from xbdbque
Q:'$G(DFN)
I '$D(^AMHPINTK(DFN)) D HEAD W !!,"No INTAKE Document on file for ",$P(^DPT(DFN,0),U) Q
S (AMHQUIT,AMHPG)=0
D HEAD
W !!?2,"Initial Intake: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.07)
W !?2," Provider: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.08)
W !!?2," Last Update: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.02)
W !?2," Provider: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.02)
I $O(^AMHPINTK(DFN,10,0)) D Q:AMHQUIT
.W !!?2,"Referred By:",!
.K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=10,AMHDA=DFN,AMHFILE=9002011.07 D WP^AMHLETP4
.I $D(AMHPRNM) S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X!(AMHQUIT) D:$Y>(IOSL-3) HEAD Q:AMHQUIT W ?5,AMHPRNM(X),!
.Q:AMHQUIT
W !!?2,"Intake Documentation/Narrative:",!
K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=41,AMHDA=DFN,AMHFILE=9002011.07 D WP^AMHLETP4
I $D(AMHPRNM) S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X!(AMHQUIT) D:$Y>(IOSL-3) HEAD Q:AMHQUIT W ?5,AMHPRNM(X),!
Q:$G(AMHBROW)
I $Y>(IOSL-8) D HEAD Q:AMHQUIT
S X=IOSL-$Y S X=X-8 F I=1:1:X W !
W !,"________________________________________",?52,"__________________"
W !?60,"DATE"
W !!!,"________________________________________",?52,"__________________"
W !?60,"DATE"
K AMHPG,AMHQUIT,AMHPRNM,AMHNODE,AMHPCNT,AMHFILE
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
HEAD1 ;EP
W:$D(IOF) @IOF S AMHPG=AMHPG+1
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !,$TR($J("",80)," ","*")
W !,"*",?79,"*"
W !,"* INTAKE DOCUMENT",?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
AMHLEI3 ; IHS/CMI/LAB - treatment plan update ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
PRINT ;EP
+1 IF '$GET(AMHPAT)
WRITE !!,"ERROR - Patient not defined!"
QUIT
+2 DO FULL^VALM1
+3 ;print or browse
+4 WRITE !
SET DIR(0)="S^P:PRINT Output on Paper;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
DO PAUSE
DO BACK^AMHLEI
QUIT
+6 IF $GET(Y)="B"
DO BROWSE
DO BACK^AMHLEI
QUIT
+7 DO EN1
+8 DO BACK^AMHLEI
+9 QUIT
BROWSE ;
+1 SET AMHBROW=1
DO VIEWR^XBLM("PRINT1^AMHLEI3","Display of Intake Document")
KILL AMHBROW
+2 QUIT
EN1 ;EP - called from protocol
+1 ;DFN must be equal to patient
+2 IF '$GET(DFN)
QUIT
+3 IF '$DATA(^DPT(DFN))
QUIT
+4 ;get device
+5 SET XBRP="PRINT1^AMHLEI3"
SET XBRC=""
SET XBRX="XIT^AMHLEI3"
SET XBNS="AMH;DFN"
+6 DO ^XBDBQUE
+7 DO BACK^AMHLEI
+8 QUIT
XIT ;
+1 QUIT
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
PRINT1 ;EP - called from xbdbque
+1 IF '$GET(DFN)
QUIT
+2 IF '$DATA(^AMHPINTK(DFN))
DO HEAD
WRITE !!,"No INTAKE Document on file for ",$PIECE(^DPT(DFN,0),U)
QUIT
+3 SET (AMHQUIT,AMHPG)=0
+4 DO HEAD
+5 WRITE !!?2,"Initial Intake: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.07)
+6 WRITE !?2," Provider: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.08)
+7 WRITE !!?2," Last Update: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.02)
+8 WRITE !?2," Provider: ",?27,$$VAL^XBDIQ1(9002011.07,DFN,.02)
+9 IF $ORDER(^AMHPINTK(DFN,10,0))
Begin DoDot:1
+10 WRITE !!?2,"Referred By:",!
+11 KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=10
SET AMHDA=DFN
SET AMHFILE=9002011.07
DO WP^AMHLETP4
+12 IF $DATA(AMHPRNM)
SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(IOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE ?5,AMHPRNM(X),!
+13 IF AMHQUIT
QUIT
End DoDot:1
IF AMHQUIT
QUIT
+14 WRITE !!?2,"Intake Documentation/Narrative:",!
+15 KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=41
SET AMHDA=DFN
SET AMHFILE=9002011.07
DO WP^AMHLETP4
+16 IF $DATA(AMHPRNM)
SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X!(AMHQUIT)
QUIT
IF $Y>(IOSL-3)
DO HEAD
IF AMHQUIT
QUIT
WRITE ?5,AMHPRNM(X),!
+17 IF $GET(AMHBROW)
QUIT
+18 IF $Y>(IOSL-8)
DO HEAD
IF AMHQUIT
QUIT
+19 SET X=IOSL-$Y
SET X=X-8
FOR I=1:1:X
WRITE !
+20 WRITE !,"________________________________________",?52,"__________________"
+21 WRITE !?60,"DATE"
+22 WRITE !!!,"________________________________________",?52,"__________________"
+23 WRITE !?60,"DATE"
+24 KILL AMHPG,AMHQUIT,AMHPRNM,AMHNODE,AMHPCNT,AMHFILE
+25 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
HEAD1 ;EP
+1 IF $DATA(IOF)
WRITE @IOF
SET AMHPG=AMHPG+1
+2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*")
+4 WRITE !,"*",?79,"*"
+5 WRITE !,"* INTAKE DOCUMENT",?45,"Printed: ",$$FMTE^XLFDT($$NOW^XLFDT),?79,"*"
+6 WRITE !,"* Name: ",$PIECE(^DPT(DFN,0),U),?68,"Page ",AMHPG,?79,"*"
+7 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,"*"
+8 WRITE !,"*",?79,"*"
+9 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*"),!
+10 QUIT
