AMHLETP ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;
;
;; ;
START ; Write Header
D EN^AMHEKL ; -- kill all vars before starting
W:$D(IOF) @IOF
F J=1:1:5 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X
K X,J
W !!
D ^AMHLEIN ;Initialize vars, etc.
;loop through until user wants to quit
S DFN="" D GETPAT
I DFN D EN,FULL^VALM1,EXIT
D EOJ
Q
;
GETPAT ;get patient
S DFN="",AMHPAT=""
W !
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
S (DFN,AMHPAT)=+Y
I AMHPAT,'$$ALLOWP^AMHUTIL(DUZ,AMHPAT) D NALLOWP^AMHUTIL D PAUSE^AMHLEA G GETPAT
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
Q
EOJ ;EOJ CLEANUP
D CLEAR^VALM1
D EN^AMHEKL
Q
ALLOWTP(S,R) ;EP - CAN THIS USER SEE THIS TREATMENT PLAN?
;S is duz, R is TREATMENT PLAN ien
I '$G(S) Q 0
I '$G(R) Q 0
I '$D(^AMHPTXP(R,0)) Q 0
NEW P
S P=$P($G(^AMHPTXP(R,0)),U,2)
I 'P Q 0
I $D(^AMHSITE(DUZ(2),16,S)) Q 1 ;Q $$ALLOWP^AMHUTIL(S,P) ;allow all with access
I $P(^AMHPTXP(R,0),U,4)=S Q 1 ;designated Q $$ALLOWP^AMHUTIL(S,P) ;allow your own
I $P(^AMHPTXP(R,0),U,5)=S Q 1 ;supervisor
NEW X,Y,G
S G=0
S X=0 F S X=$O(^AMHPTXP(R,41,X)) Q:X'=+X!(G) D
.I $P($G(^AMHPTXP(R,41,X,0)),U,3)=S S G=1
.I $P($G(^AMHPTXP(R,41,X,0)),U,4)=S S G=1
I G Q 1
Q 0
;
EP1(DFN) ;EP CALLED FROM PROTOCOL
Q:'$G(DFN)
Q:'$D(^DPT(DFN))
Q:$P(^DPT(DFN,0),U,19)
NEW APCHSTYP,APCHSPAT
D EN
D FULL^VALM1
K VALMHDR
K X,Y
Q
EN ; EP -- main entry point for AMH UPDATE ACTIVITY RECORDS
S VALMCC=1
I $G(AMHDISP) D EN^VALM("AMH DISP/PRINT TREATMENT PLAN"),CLEAR^VALM1 Q
D EN^VALM("AMH UPDATE PATIENT TX PLAN")
D CLEAR^VALM1
Q
;
GATHER ;EP - called from AMHUAR
K AMHQUIT,AMHPTP S AMHRCNT=0,AMHLINE=0
I '$D(^AMHPTXP("AC",DFN)) S AMHPTP(1,0)="No Treatment Plans currently on file" S AMHRCNT=1 Q
S AMHD=0 F S AMHD=$O(^AMHPTXP("AA",DFN,AMHD)) Q:AMHD'=+AMHD S AMHE=0 F S AMHE=$O(^AMHPTXP("AA",DFN,AMHD,AMHE)) Q:AMHE'=+AMHE D
.Q:'$$ALLOWTP(DUZ,AMHE)
.S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,AMHPTP("IDX",AMHRCNT,AMHLINE)=AMHE
.S AMHX=AMHRCNT_") Program: "_$$VAL^XBDIQ1(9002011.56,AMHE,.17),$E(AMHX,42)="Responsible Provider: "_$S($P(^AMHPTXP(AMHE,0),U,4):$P(^VA(200,$P(^AMHPTXP(AMHE,0),U,4),0),U),1:"<<not recorded>>"),AMHPTP(AMHLINE,0)=AMHX
.S AMHLINE=AMHLINE+1,AMHX=" Date Established: "_$$FTIME^VALM1($P(^AMHPTXP(AMHE,0),U)),$E(AMHX,42)="Next Review Date: "_$$FTIME^VALM1($P(^AMHPTXP(AMHE,0),U,9))
.S AMHPTP(AMHLINE,0)=AMHX
.S AMHLINE=AMHLINE+1,AMHX=" Date Resolved: "_$$FTIME^VALM1($P(^AMHPTXP(AMHE,0),U,12)),AMHPTP(AMHLINE,0)=AMHX
.S AMHLINE=AMHLINE+1,AMHX=" Problem: "_$E($G(^AMHPTXP(AMHE,11)),1,65),AMHPTP(AMHLINE,0)=AMHX
.S (X,C)=0 F S X=$O(^AMHPTXP(AMHE,11,X)) Q:X'=+X S C=C+1 D
..S AMHLINE=AMHLINE+1,AMHPTP(AMHLINE,0)=" Problem #"_C_": "_$P(^AMHPTXP(AMHE,11,X,0),U)
..Q
.S AMHLINE=AMHLINE+1,AMHPTP(AMHLINE,0)=""
Q ;**** new format
HDR ;EP -- header code
S VALMHDR(1)="Patient Name: "_$P(^DPT(DFN,0),U)_" DOB: "_$$FTIME^VALM1($P(^DPT(DFN,0),U,3))_" Sex: "_$P(^DPT(DFN,0),U,2)
I $E($G(AMHPTP(1,0)))="N" S AMHRCNT=0,VALMHDR(2)=AMHPTP(1,0) K AMHPTP
E S VALMHDR(2)=" TREATMENT PLANS CURRENTLY ON FILE"
Q
;
INIT ;EP -- init variables and list array
D GATHER ;gather up all records for display
S VALMCNT=AMHLINE
Q
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K AMHRCNT,AMHPTP,AMHE,AMHLINE,AMHLEL,AMHLETXT,AMHGNUM,AMHTPN,AMHCOL
K VALMCC,VALMHDR
Q
;
EXPND ; -- expand code
Q
;
TEXT ;
;;Behavioral Health Module
;;
;;****************************************
;;* Update BH Patient Treatment Plans *
;;****************************************
;;
Q
GETTXT ;EP - GENERALIZED TEXT PRINTER
S AMHLETP("DLT")=1,AMHLETP("ILN")=$S($G(AMHLETP("LGTH")):AMHLETP("LGTH"),1:80)-AMHLETP("ICL")-1
F AMHLETP("Q")=0:0 S:AMHLETP("NRQ")]""&(($L(AMHLETP("NRQ"))+$L(AMHLETP("TXT"))+2)<255) AMHLETP("TXT")=$S(AMHLETP("TXT")]"":AMHLETP("TXT")_"; ",1:"")_AMHLETP("NRQ"),AMHLETP("NRQ")="" Q:AMHLETP("TXT")="" D GETTXT2
K AMHLETP("ILN"),AMHLETP("DLT"),AMHLETP("F"),AMHLETP("C"),AMHLETP("TXT")
Q
GETTXT2 D GETFRAG S AMHLEC=AMHLEC+1,AMHLETXT(AMHLEC)="" F X=1:1:AMHLETP("ICL") S AMHLETXT(AMHLEC)=AMHLETXT(AMHLEC)_" "
S AMHLETXT(AMHLEC)=AMHLETXT(AMHLEC)_AMHLETP("F"),AMHLETP("ICL")=AMHLETP("ICL")+AMHLETP("DLT"),AMHLETP("ILN")=AMHLETP("ILN")-AMHLETP("DLT"),AMHLETP("DLT")=0
Q
GETFRAG I $L(AMHLETP("TXT"))<AMHLETP("ILN") S AMHLETP("F")=AMHLETP("TXT"),AMHLETP("TXT")="" Q
F AMHLETP("C")=AMHLETP("ILN"):-1:1 Q:$E(AMHLETP("TXT"),AMHLETP("C"))=" "
S AMHLETP("F")=$E(AMHLETP("TXT"),1,AMHLETP("C")-1),AMHLETP("TXT")=$E(AMHLETP("TXT"),AMHLETP("C")+1,255)
Q
;
AMHLETP ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;
+4 ;
+5 ;; ;
START ; Write Header
+1 ; -- kill all vars before starting
DO EN^AMHEKL
+2 IF $DATA(IOF)
WRITE @IOF
+3 FOR J=1:1:5
SET X=$PIECE($TEXT(TEXT+J),";;",2)
WRITE !?80-$LENGTH(X)\2,X
+4 KILL X,J
+5 WRITE !!
+6 ;Initialize vars, etc.
DO ^AMHLEIN
+7 ;loop through until user wants to quit
+8 SET DFN=""
DO GETPAT
+9 IF DFN
DO EN
DO FULL^VALM1
DO EXIT
+10 DO EOJ
+11 QUIT
+12 ;
GETPAT ;get patient
+1 SET DFN=""
SET AMHPAT=""
+2 WRITE !
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+4 IF Y<0
QUIT
+5 SET (DFN,AMHPAT)=+Y
+6 IF AMHPAT
IF '$$ALLOWP^AMHUTIL(DUZ,AMHPAT)
DO NALLOWP^AMHUTIL
DO PAUSE^AMHLEA
GOTO GETPAT
+7 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!!
HANG 2
+8 QUIT
EOJ ;EOJ CLEANUP
+1 DO CLEAR^VALM1
+2 DO EN^AMHEKL
+3 QUIT
ALLOWTP(S,R) ;EP - CAN THIS USER SEE THIS TREATMENT PLAN?
+1 ;S is duz, R is TREATMENT PLAN ien
+2 IF '$GET(S)
QUIT 0
+3 IF '$GET(R)
QUIT 0
+4 IF '$DATA(^AMHPTXP(R,0))
QUIT 0
+5 NEW P
+6 SET P=$PIECE($GET(^AMHPTXP(R,0)),U,2)
+7 IF 'P
QUIT 0
+8 ;Q $$ALLOWP^AMHUTIL(S,P) ;allow all with access
IF $DATA(^AMHSITE(DUZ(2),16,S))
QUIT 1
+9 ;designated Q $$ALLOWP^AMHUTIL(S,P) ;allow your own
IF $PIECE(^AMHPTXP(R,0),U,4)=S
QUIT 1
+10 ;supervisor
IF $PIECE(^AMHPTXP(R,0),U,5)=S
QUIT 1
+11 NEW X,Y,G
+12 SET G=0
+13 SET X=0
FOR
SET X=$ORDER(^AMHPTXP(R,41,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+14 IF $PIECE($GET(^AMHPTXP(R,41,X,0)),U,3)=S
SET G=1
+15 IF $PIECE($GET(^AMHPTXP(R,41,X,0)),U,4)=S
SET G=1
End DoDot:1
+16 IF G
QUIT 1
+17 QUIT 0
+18 ;
EP1(DFN) ;EP CALLED FROM PROTOCOL
+1 IF '$GET(DFN)
QUIT
+2 IF '$DATA(^DPT(DFN))
QUIT
+3 IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+4 NEW APCHSTYP,APCHSPAT
+5 DO EN
+6 DO FULL^VALM1
+7 KILL VALMHDR
+8 KILL X,Y
+9 QUIT
EN ; EP -- main entry point for AMH UPDATE ACTIVITY RECORDS
+1 SET VALMCC=1
+2 IF $GET(AMHDISP)
DO EN^VALM("AMH DISP/PRINT TREATMENT PLAN")
DO CLEAR^VALM1
QUIT
+3 DO EN^VALM("AMH UPDATE PATIENT TX PLAN")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
GATHER ;EP - called from AMHUAR
+1 KILL AMHQUIT,AMHPTP
SET AMHRCNT=0
SET AMHLINE=0
+2 IF '$DATA(^AMHPTXP("AC",DFN))
SET AMHPTP(1,0)="No Treatment Plans currently on file"
SET AMHRCNT=1
QUIT
+3 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPTXP("AA",DFN,AMHD))
IF AMHD'=+AMHD
QUIT
SET AMHE=0
FOR
SET AMHE=$ORDER(^AMHPTXP("AA",DFN,AMHD,AMHE))
IF AMHE'=+AMHE
QUIT
Begin DoDot:1
+4 IF '$$ALLOWTP(DUZ,AMHE)
QUIT
+5 SET AMHRCNT=AMHRCNT+1
SET AMHLINE=AMHLINE+1
SET AMHPTP("IDX",AMHRCNT,AMHLINE)=AMHE
+6 SET AMHX=AMHRCNT_") Program: "_$$VAL^XBDIQ1(9002011.56,AMHE,.17)
SET $EXTRACT(AMHX,42)="Responsible Provider: "_$SELECT($PIECE(^AMHPTXP(AMHE,0),U,4):$PIECE(^VA(200,$PIECE(^AMHPTXP(AMHE,0),U,4),0),U),1:"<<not recorded>>")
SET AMHPTP(AMHLINE,0)=AMHX
+7 SET AMHLINE=AMHLINE+1
SET AMHX=" Date Established: "_$$FTIME^VALM1($PIECE(^AMHPTXP(AMHE,0),U))
SET $EXTRACT(AMHX,42)="Next Review Date: "_$$FTIME^VALM1($PIECE(^AMHPTXP(AMHE,0),U,9))
+8 SET AMHPTP(AMHLINE,0)=AMHX
+9 SET AMHLINE=AMHLINE+1
SET AMHX=" Date Resolved: "_$$FTIME^VALM1($PIECE(^AMHPTXP(AMHE,0),U,12))
SET AMHPTP(AMHLINE,0)=AMHX
+10 SET AMHLINE=AMHLINE+1
SET AMHX=" Problem: "_$EXTRACT($GET(^AMHPTXP(AMHE,11)),1,65)
SET AMHPTP(AMHLINE,0)=AMHX
+11 SET (X,C)=0
FOR
SET X=$ORDER(^AMHPTXP(AMHE,11,X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:2
+12 SET AMHLINE=AMHLINE+1
SET AMHPTP(AMHLINE,0)=" Problem #"_C_": "_$PIECE(^AMHPTXP(AMHE,11,X,0),U)
+13 QUIT
End DoDot:2
+14 SET AMHLINE=AMHLINE+1
SET AMHPTP(AMHLINE,0)=""
End DoDot:1
+15 ;**** new format
QUIT
HDR ;EP -- header code
+1 SET VALMHDR(1)="Patient Name: "_$PIECE(^DPT(DFN,0),U)_" DOB: "_$$FTIME^VALM1($PIECE(^DPT(DFN,0),U,3))_" Sex: "_$PIECE(^DPT(DFN,0),U,2)
+2 IF $EXTRACT($GET(AMHPTP(1,0)))="N"
SET AMHRCNT=0
SET VALMHDR(2)=AMHPTP(1,0)
KILL AMHPTP
+3 IF '$TEST
SET VALMHDR(2)=" TREATMENT PLANS CURRENTLY ON FILE"
+4 QUIT
+5 ;
INIT ;EP -- init variables and list array
+1 ;gather up all records for display
DO GATHER
+2 SET VALMCNT=AMHLINE
+3 QUIT
+4 ;
HELP ;EP -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL AMHRCNT,AMHPTP,AMHE,AMHLINE,AMHLEL,AMHLETXT,AMHGNUM,AMHTPN,AMHCOL
+2 KILL VALMCC,VALMHDR
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
TEXT ;
+1 ;;Behavioral Health Module
+2 ;;
+3 ;;****************************************
+4 ;;* Update BH Patient Treatment Plans *
+5 ;;****************************************
+6 ;;
+7 QUIT
GETTXT ;EP - GENERALIZED TEXT PRINTER
+1 SET AMHLETP("DLT")=1
SET AMHLETP("ILN")=$SELECT($GET(AMHLETP("LGTH")):AMHLETP("LGTH"),1:80)-AMHLETP("ICL")-1
+2 FOR AMHLETP("Q")=0:0
IF AMHLETP("NRQ")]""&(($LENGTH(AMHLETP("NRQ"))+$LENGTH(AMHLETP("TXT"))+2)<255)
SET AMHLETP("TXT")=$SELECT(AMHLETP("TXT")]"":AMHLETP("TXT")_"; ",1:"")_AMHLETP("NRQ")
SET AMHLETP("NRQ")=""
IF AMHLETP("TXT")=""
QUIT
DO GETTXT2
+3 KILL AMHLETP("ILN"),AMHLETP("DLT"),AMHLETP("F"),AMHLETP("C"),AMHLETP("TXT")
+4 QUIT
GETTXT2 DO GETFRAG
SET AMHLEC=AMHLEC+1
SET AMHLETXT(AMHLEC)=""
FOR X=1:1:AMHLETP("ICL")
SET AMHLETXT(AMHLEC)=AMHLETXT(AMHLEC)_" "
+1 SET AMHLETXT(AMHLEC)=AMHLETXT(AMHLEC)_AMHLETP("F")
SET AMHLETP("ICL")=AMHLETP("ICL")+AMHLETP("DLT")
SET AMHLETP("ILN")=AMHLETP("ILN")-AMHLETP("DLT")
SET AMHLETP("DLT")=0
+2 QUIT
GETFRAG IF $LENGTH(AMHLETP("TXT"))<AMHLETP("ILN")
SET AMHLETP("F")=AMHLETP("TXT")
SET AMHLETP("TXT")=""
QUIT
+1 FOR AMHLETP("C")=AMHLETP("ILN"):-1:1
IF $EXTRACT(AMHLETP("TXT"),AMHLETP("C"))=" "
QUIT
+2 SET AMHLETP("F")=$EXTRACT(AMHLETP("TXT"),1,AMHLETP("C")-1)
SET AMHLETP("TXT")=$EXTRACT(AMHLETP("TXT"),AMHLETP("C")+1,255)
+3 QUIT
+4 ;
