Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHLETP

AMHLETP.m

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