- 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 ;----------
