AMHLEIV3 ; IHS/CMI/LAB - treatment plan update ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;
PRINT ;EP
NEW DFN,AMHPAT,AMHDPT,Y,X,AMHBROW,AMHAO,AMHINTR
I '$G(AMHRINTI) W !!,"ERROR - IEN OF INTAKE not defined!" Q
S (DFN,AMHPAT)=$P(^AMHRINTK(AMHRINTI,0),U,2)
D FULL^VALM1
S AMHDPT=""
S DIR(0)="S^I:Intake Document Only;U:Update Document Only;B:Both the Intake and Update Documents;Q:Quit/Exit",DIR("A")="What would you like to print",DIR("B")="I" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I Y="Q" Q
S AMHDPT=Y
I AMHDPT="I" G DEVICE
S AMHAO=""
K AMHREVS,AMHREVP
I AMHDPT="U",'$O(^AMHRINTK("AI",AMHRINTI,0)) W !!,"There are no updates on file to print." D PAUSE G PRINT
I AMHDPT="B",'$O(^AMHRINTK("AI",AMHRINTI,0)) W !!,"There are no updates to print...printing intake only." G DEVICE
;display all updates and have user choose
W !?4,"0) ",?10,"Quit/Exit (or type '^')"
S (AMHX,AMHC)=0 F S AMHX=$O(^AMHRINTK("AI",AMHRINTI,AMHX)) Q:AMHX'=+AMHX D
.S AMHC=AMHC+1,AMHREVS(AMHC)=AMHX
.S AMHINTR=$P(^AMHRINTK(AMHX,0),U,3)
.W !,?4,AMHC,") ",?10,"Date: ",$$D^AMHLEIV($$VALI^XBDIQ1(9002011.13,AMHX,.01))," Provider: ",$E($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,15),?51,$E($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,13),?65,$$VAL^XBDIQ1(9002011.13,AMHX,.09)
S AMHC=AMHC+1 W !?4,AMHC,") ",?10,"ALL Updates"
K DIR
S DIR(0)="L^0:"_AMHC,DIR("A")="Which Updates would you like to Print",DIR("B")=AMHC KILL DA D ^DIR KILL DIR
I $D(DIRUT) G PRINT
I Y[0 G PRINT
I Y[AMHC D K AMHREVS G DEVICE
.F I=1:1:(AMHC-1) S AMHREVP(AMHREVS(I))=""
S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C="" S J=AMHREVS(C) S AMHREVP(J)=""
K AMHREVS
DEVICE ;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,EXIT^AMHLEIV Q
I $G(Y)="B" D BROWSE D EXIT^AMHLEIV Q
D EN1
D EXIT^AMHLEIV
Q
BROWSE ;
S AMHBROW=1 D VIEWR^XBLM("PRINT1^AMHLEIV3","Display of Intake Document") K AMHBROW
Q
EN1 ;EP - called from protocol
;DFN must be equal to patient
;get device
S XBRP="PRINT1^AMHLEIV3",XBRC="",XBRX="XIT^AMHLEIV3",XBNS="AMH;DFN"
D ^XBDBQUE
D EXIT^AMHLEIV
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
GUI(AMHDPT,DFN,AMHRINTI,AMHREVP,AMHARRAY) ;EP - gui call
I '$G(DFN) Q ""
I '$G(AMHRINTI) Q ""
NEW AMHGUI
S AMHGUI=1
D GUIR^XBLM("PRINT1^AMHLEIV3",AMHARRAY)
Q
PRINT1 ;EP - called from xbdbque
;NOW REORDER THE UPDATES WITH THE INTAKE BY LATEST FIRST
S AMHIOSL=$S($G(AMHGUI):55,1:IOSL)
K AMHREVD
S X=0 F S X=$O(AMHREVP(X)) Q:X'=+X S AMHREVD((9999999-$P(^AMHRINTK(X,0),U)),X)=""
I AMHDPT'="U" S AMHREVD((9999999-$P(^AMHRINTK(AMHRINTI,0),U)),AMHRINTI)=""
;I '$D(^AMHRINTK(AMHRINTI)) D HEAD W !!,"No INTAKE Document on file for ",$P(^DPT(DFN,0),U) Q
NEW AMHQUIT,AMHPG,AMHX,AMHV,AMHPRNM,AMHPCNT,AMHFILE,AMHNOD,AMHRD,AMHRP
S (AMHQUIT,AMHPG)=0
S AMHRD=0 F S AMHRD=$O(AMHREVD(AMHRD)) Q:AMHRD'=+AMHRD!(AMHQUIT) D
.S AMHRP=99999999999 F S AMHRP=$O(AMHREVD(AMHRD,AMHRP),-1) Q:AMHRP'=+AMHRP!(AMHQUIT) D PRINT2
.Q
Q
PRINT2 ;
NEW X,Y,I,AMHINTT,AMHINTR
;S AMHIOSL=$S($G(AMHGUI):55,1:IOSL)
S AMHINTT=$P(^AMHRINTK(AMHRP,0),U,9)
D HEAD
S AMHINTR=$P(^AMHRINTK(AMHRP,0),U,3)
W !?2,"Date "_$S(AMHINTT="I":"Established",1:"Updated")_": ",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.01)
W !?2,"Provider: ",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.04)
W !?2,"Program:",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.05)
W !?2,"Type of Document:",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.09)
W !!?2,"Intake Documentation/Narrative:",!
K AMHPCNT,AMHPRNM S AMHPCNT=0,AMHNODE=41,AMHDA=AMHRP ;,AMHFILE=9002011.13 D WP^AMHLETP4
S AMHX=0 F S AMHX=$O(^AMHRINTK(AMHDA,AMHNODE,AMHX)) Q:AMHX'=+AMHX S AMHPCNT=AMHPCNT+1,AMHPRNM(AMHPCNT)=^AMHRINTK(AMHDA,AMHNODE,AMHX,0)
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)),! ;cmi/maw 1/13/10 pr593
I $G(AMHBROW) G SIG
I $Y>(AMHIOSL-8) D HEAD Q:AMHQUIT
S X=AMHIOSL-$Y S X=X-8 F I=1:1:X W !
I '$P(^AMHRINTK(AMHRP,0),U,11) D
.W !,"________________________________________",?52,"__________________"
.W !?60,"DATE"
SIG I $P(^AMHRINTK(AMHRP,0),U,11) D
.W !?2,"PROVIDER SIGNATURE: /es/ "_$P(^AMHRINTK(AMHRP,0),U,12)
.I $P(^AMHRINTK(AMHRP,0),U,16)]"" W !?29,$P(^AMHRINTK(AMHRP,0),U,16)
.W !?5,"Signed: "_$P($$FMTE^XLFDT($P(^AMHRINTK(AMHRP,0),U,11)),"@",1)_" "_$P($$FMTE^XLFDT($P(^AMHRINTK(AMHRP,0),U,11)),"@",2)
W !!!,"________________________________________",?52,"__________________"
W !?60,"DATE"
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
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 !,"* INTAKE DOCUMENT "_$S(AMHINTT="U":"UPDATE",1:""),?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
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
AMHLEIV3 ; IHS/CMI/LAB - treatment plan update ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;
PRINT ;EP
+1 NEW DFN,AMHPAT,AMHDPT,Y,X,AMHBROW,AMHAO,AMHINTR
+2 IF '$GET(AMHRINTI)
WRITE !!,"ERROR - IEN OF INTAKE not defined!"
QUIT
+3 SET (DFN,AMHPAT)=$PIECE(^AMHRINTK(AMHRINTI,0),U,2)
+4 DO FULL^VALM1
+5 SET AMHDPT=""
+6 SET DIR(0)="S^I:Intake Document Only;U:Update Document Only;B:Both the Intake and Update Documents;Q:Quit/Exit"
SET DIR("A")="What would you like to print"
SET DIR("B")="I"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
QUIT
+8 IF Y="Q"
QUIT
+9 SET AMHDPT=Y
+10 IF AMHDPT="I"
GOTO DEVICE
+11 SET AMHAO=""
+12 KILL AMHREVS,AMHREVP
+13 IF AMHDPT="U"
IF '$ORDER(^AMHRINTK("AI",AMHRINTI,0))
WRITE !!,"There are no updates on file to print."
DO PAUSE
GOTO PRINT
+14 IF AMHDPT="B"
IF '$ORDER(^AMHRINTK("AI",AMHRINTI,0))
WRITE !!,"There are no updates to print...printing intake only."
GOTO DEVICE
+15 ;display all updates and have user choose
+16 WRITE !?4,"0) ",?10,"Quit/Exit (or type '^')"
+17 SET (AMHX,AMHC)=0
FOR
SET AMHX=$ORDER(^AMHRINTK("AI",AMHRINTI,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+18 SET AMHC=AMHC+1
SET AMHREVS(AMHC)=AMHX
+19 SET AMHINTR=$PIECE(^AMHRINTK(AMHX,0),U,3)
+20 WRITE !,?4,AMHC,") ",?10,"Date: ",$$D^AMHLEIV($$VALI^XBDIQ1(9002011.13,AMHX,.01))," Provider: ",$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,15),?51,$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,13),?65,$$VAL^XBDIQ1(9002011.13,AMHX,.09
)
End DoDot:1
+21 SET AMHC=AMHC+1
WRITE !?4,AMHC,") ",?10,"ALL Updates"
+22 KILL DIR
+23 SET DIR(0)="L^0:"_AMHC
SET DIR("A")="Which Updates would you like to Print"
SET DIR("B")=AMHC
KILL DA
DO ^DIR
KILL DIR
+24 IF $DATA(DIRUT)
GOTO PRINT
+25 IF Y[0
GOTO PRINT
+26 IF Y[AMHC
Begin DoDot:1
+27 FOR I=1:1:(AMHC-1)
SET AMHREVP(AMHREVS(I))=""
End DoDot:1
KILL AMHREVS
GOTO DEVICE
+28 SET A=Y
SET C=""
FOR I=1:1
SET C=$PIECE(A,",",I)
IF C=""
QUIT
SET J=AMHREVS(C)
SET AMHREVP(J)=""
+29 KILL AMHREVS
DEVICE ;print or browse
+1 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
+2 IF $DATA(DIRUT)
DO PAUSE
DO EXIT^AMHLEIV
QUIT
+3 IF $GET(Y)="B"
DO BROWSE
DO EXIT^AMHLEIV
QUIT
+4 DO EN1
+5 DO EXIT^AMHLEIV
+6 QUIT
BROWSE ;
+1 SET AMHBROW=1
DO VIEWR^XBLM("PRINT1^AMHLEIV3","Display of Intake Document")
KILL AMHBROW
+2 QUIT
EN1 ;EP - called from protocol
+1 ;DFN must be equal to patient
+2 ;get device
+3 SET XBRP="PRINT1^AMHLEIV3"
SET XBRC=""
SET XBRX="XIT^AMHLEIV3"
SET XBNS="AMH;DFN"
+4 DO ^XBDBQUE
+5 DO EXIT^AMHLEIV
+6 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
GUI(AMHDPT,DFN,AMHRINTI,AMHREVP,AMHARRAY) ;EP - gui call
+1 IF '$GET(DFN)
QUIT ""
+2 IF '$GET(AMHRINTI)
QUIT ""
+3 NEW AMHGUI
+4 SET AMHGUI=1
+5 DO GUIR^XBLM("PRINT1^AMHLEIV3",AMHARRAY)
+6 QUIT
PRINT1 ;EP - called from xbdbque
+1 ;NOW REORDER THE UPDATES WITH THE INTAKE BY LATEST FIRST
+2 SET AMHIOSL=$SELECT($GET(AMHGUI):55,1:IOSL)
+3 KILL AMHREVD
+4 SET X=0
FOR
SET X=$ORDER(AMHREVP(X))
IF X'=+X
QUIT
SET AMHREVD((9999999-$PIECE(^AMHRINTK(X,0),U)),X)=""
+5 IF AMHDPT'="U"
SET AMHREVD((9999999-$PIECE(^AMHRINTK(AMHRINTI,0),U)),AMHRINTI)=""
+6 ;I '$D(^AMHRINTK(AMHRINTI)) D HEAD W !!,"No INTAKE Document on file for ",$P(^DPT(DFN,0),U) Q
+7 NEW AMHQUIT,AMHPG,AMHX,AMHV,AMHPRNM,AMHPCNT,AMHFILE,AMHNOD,AMHRD,AMHRP
+8 SET (AMHQUIT,AMHPG)=0
+9 SET AMHRD=0
FOR
SET AMHRD=$ORDER(AMHREVD(AMHRD))
IF AMHRD'=+AMHRD!(AMHQUIT)
QUIT
Begin DoDot:1
+10 SET AMHRP=99999999999
FOR
SET AMHRP=$ORDER(AMHREVD(AMHRD,AMHRP),-1)
IF AMHRP'=+AMHRP!(AMHQUIT)
QUIT
DO PRINT2
+11 QUIT
End DoDot:1
+12 QUIT
PRINT2 ;
+1 NEW X,Y,I,AMHINTT,AMHINTR
+2 ;S AMHIOSL=$S($G(AMHGUI):55,1:IOSL)
+3 SET AMHINTT=$PIECE(^AMHRINTK(AMHRP,0),U,9)
+4 DO HEAD
+5 SET AMHINTR=$PIECE(^AMHRINTK(AMHRP,0),U,3)
+6 WRITE !?2,"Date "_$SELECT(AMHINTT="I":"Established",1:"Updated")_": ",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.01)
+7 WRITE !?2,"Provider: ",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.04)
+8 WRITE !?2,"Program:",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.05)
+9 WRITE !?2,"Type of Document:",?22,$$VAL^XBDIQ1(9002011.13,AMHRP,.09)
+10 WRITE !!?2,"Intake Documentation/Narrative:",!
+11 ;,AMHFILE=9002011.13 D WP^AMHLETP4
KILL AMHPCNT,AMHPRNM
SET AMHPCNT=0
SET AMHNODE=41
SET AMHDA=AMHRP
+12 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRINTK(AMHDA,AMHNODE,AMHX))
IF AMHX'=+AMHX
QUIT
SET AMHPCNT=AMHPCNT+1
SET AMHPRNM(AMHPCNT)=^AMHRINTK(AMHDA,AMHNODE,AMHX,0)
+13 ;cmi/maw 1/13/10 pr593
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)),!
+14 IF $GET(AMHBROW)
GOTO SIG
+15 IF $Y>(AMHIOSL-8)
DO HEAD
IF AMHQUIT
QUIT
+16 SET X=AMHIOSL-$Y
SET X=X-8
FOR I=1:1:X
WRITE !
+17 IF '$PIECE(^AMHRINTK(AMHRP,0),U,11)
Begin DoDot:1
+18 WRITE !,"________________________________________",?52,"__________________"
+19 WRITE !?60,"DATE"
End DoDot:1
SIG IF $PIECE(^AMHRINTK(AMHRP,0),U,11)
Begin DoDot:1
+1 WRITE !?2,"PROVIDER SIGNATURE: /es/ "_$PIECE(^AMHRINTK(AMHRP,0),U,12)
+2 IF $PIECE(^AMHRINTK(AMHRP,0),U,16)]""
WRITE !?29,$PIECE(^AMHRINTK(AMHRP,0),U,16)
+3 WRITE !?5,"Signed: "_$PIECE($$FMTE^XLFDT($PIECE(^AMHRINTK(AMHRP,0),U,11)),"@",1)_" "_$PIECE($$FMTE^XLFDT($PIECE(^AMHRINTK(AMHRP,0),U,11)),"@",2)
End DoDot:1
+4 WRITE !!!,"________________________________________",?52,"__________________"
+5 WRITE !?60,"DATE"
+6 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 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 !,"* INTAKE DOCUMENT "_$SELECT(AMHINTT="U":"UPDATE",1:""),?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
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 ;----------
