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

AMHBPL.m

Go to the documentation of this file. 
  1. AMHBPL ; IHS/CMI/LAB - PROBLEM LIST UPDATE ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**2,4**;JUN 18, 2010;Build 28
  1.  ;; ;
  1. START(AMHR) ;EP
  1.  I '$G(AMHR) Q
  1.  I '$D(^AMHREC(AMHR,0)) Q
  1.  NEW DFN,AMHPAT,AMHLOC,AMHDATE,AMHBHPL,AMHLINE,AMHPRCNT
  1.  S (DFN,AMHPAT)=$P($G(^AMHREC(AMHR,0)),U,8)
  1.  S AMHDATE=$P($P(^AMHREC(AMHR,0),U,1),".")
  1.  S AMHLOC=$P(^AMHREC(AMHR,0),U,4)
  1.  S AMHOVRR=1
  1.  S APCDOVRR=1
  1.  I '$G(AUPNDOB) S Y=DFN D ^AUPNPAT
  1.  D EN1
  1.  D FULL^VALM1
  1.  D EXIT
  1.  ;D EOJ
  1.  Q
  1. EOJ ;End of job cleanup
  1.  D:$D(VALMWD) CLEAR^VALM1 ;clears out all list man stuff
  1.  K ^TMP($J,"AMHBPL")
  1.  K XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW
  1.  K AMHBPLPT,AMHLOC,AMHPAT,AMHDATE,AMHPIEN,AMHAF,AMHPRB,AMHLOOK,AMHPDFN
  1.  ;D KILL^AUPNPAT
  1.  Q
  1. EN1 ;PEP - requires DFN to be set to patient
  1.  K ^TMP($J,"AMHBPL")
  1.  Q:'$G(DFN)
  1.  S AMHBPLPT=DFN
  1.  Q:'$G(AMHBPLPT)
  1.  Q:'$D(^AUPNPAT(AMHBPLPT))
  1.  Q:'$D(^DPT(AMHBPLPT))
  1.  ;S Y=AMHBPLPT D ^AUPNPAT
  1.  S AMHOVRR=1
  1.  D EN
  1.  K AMHBPLPT
  1.  D FULL^VALM1
  1.  D EXIT
  1.  Q
  1. EN ;PEP  main entry point for AMH BHPL PROBLEM LIST
  1.  S VALMCC=1 ;1 means screen mode, 0 means scrolling mode
  1.  D EN^VALM("AMH BHPL PROBLEM LIST")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ;EP -- header code
  1.  S VALMHDR(1)=$TR($J(" ",80)," ","-")
  1.  S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(AMHBPLPT,0),U)_IOINORM_"   DOB: "_$$FTIME^VALM1(AUPNDOB)_"   Sex: "_$P(^DPT(AMHBPLPT,0),U,2)_"   HRN: "_$S($D(^AUPNPAT(AMHBPLPT,41,DUZ(2),0)):$P(^AUPNPAT(AMHBPLPT,41,DUZ(2),0),U,2),1:"????")
  1.  S VALMHDR(3)=$TR($J(" ",80)," ","-")
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  D GATHER ;gather up all problems
  1.  S VALMCNT=AMHLINE ;this variable must be the total number of lines in list
  1.  S AMHOVRR="" ;for provider narrative lookup
  1.  Q
  1.  ;
  1. GATHER ;EP
  1.  ;set up array containing list of problems
  1.  ;**** see page 7 of List Manager Manual for info on how to
  1.  ;**** set up the array that contains the list
  1.  K AMHBHPL
  1.  NEW AMHSX,AMHAF,AMHF,AMHPIEN,AMHPRB,AMHP0,AMHX,AMHC,AMHLR
  1.  K AMHQUIT,AMHBPL S AMHPRCNT=0,AMHLINE=0
  1.  I '$D(^AMHPPROB("AC",AMHBPLPT)) S AMHBHPL(1,0)="No BH Problems currently on file",AMHBHPL("IDX",1,1)="" S AMHLINE=1 ;Q
  1.  S AMHSX=$$LASTPLR^AMHAPI6(AMHBPLPT,,DT,"A")
  1.  I AMHSX S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)="BH Problem List Reviewed On: "_$$FMTE^XLFDT($P(AMHSX,U,1))_"  By: "_$E($P($G(^VA(200,+$P(AMHSX,U,3),0)),U),1,25)
  1.  S AMHSX=$$LASTPLU^AMHAPI6(AMHBPLPT,,DT,"A")
  1.  I AMHSX S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)="BH Problem List Updated On: "_$$FMTE^XLFDT($P(AMHSX,U,1))_"  By: "_$E($P($G(^VA(200,+$P(AMHSX,U,3),0)),U),1,25)
  1.  S AMHSX=$$LASTNAP^AMHAPI6(AMHBPLPT,,DT,"A")
  1.  ;I '$$ANYACTP^AMHAPRB(AMHBPLPT),AMHSX S AMHLINE=AMHLINE+1,^TMP($J,"AMHBPL",AMHLINE,0)="No Active BH Problems:    "_$$FMTE^XLFDT($P(AMHSX,U,1))_"  Documented By: "_$E($P($G(^VA(200,+$P(AMHSX,U,3),0)),U),1,25)
  1.  I AMHSX S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)="No Active BH Problems Documented On: "_$$FMTE^XLFDT($P(AMHSX,U,1))_"  By: "_$E($P($G(^VA(200,+$P(AMHSX,U,3),0)),U),1,25)
  1.  S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)="  "
  1.  S AMHPRCNT=0
  1.  S AMHAF="A" D GATHER1 S AMHAF="I" D GATHER1
  1.  Q
  1. GATHER1 ;
  1.  S AMHF=0 F  S AMHF=$O(^AMHPPROB("AA",AMHBPLPT,AMHF)) Q:AMHF=""  D
  1.  .S AMHPRB="" F  S AMHPRB=$O(^AMHPPROB("AA",AMHBPLPT,AMHF,AMHPRB)) Q:AMHPRB=""  D
  1.  ..S AMHPIEN=AMHPRB,AMHP0=^AMHPPROB(AMHPIEN,0)
  1.  ..Q:AMHAF'=$P(^AMHPPROB(AMHPIEN,0),U,12)
  1.  ..;quit if not meet UU
  1.  ..;Q:'$$ALLOWV^AMHUTIL(DUZ,$P(^AMHPPROB(AMHPIEN,0),U,6))  no UU per Wendy
  1.  ..S AMHPRCNT=AMHPRCNT+1,AMHLINE=AMHLINE+1,AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN,AMHX=""
  1.  ..S AMHX=AMHPRCNT,AMHX=AMHX_")  ",$E(AMHX,6)="DX: "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.01),$E(AMHX,20)="Status: "_IOUON_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.12)_IOUOFF,$E(AMHX,50)="Last Modified: "_$$DATE^AMHVRL($P(AMHP0,U,3))
  1.  ..S AMHBHPL(AMHLINE,0)=AMHX,AMHX="",AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ..S AMHLINE=AMHLINE+1
  1.  ..S $E(AMHX,6)="DSM Narrative: "_$$VAL^XBDIQ1(9002012.2,$P(AMHP0,U,1),.02)
  1.  ..S AMHBHPL(AMHLINE,0)=AMHX,AMHX="",AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ..S AMHLINE=AMHLINE+1
  1.  ..S $E(AMHX,6)="Provider Narrative: "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.05)
  1.  ..S AMHBHPL(AMHLINE,0)=AMHX,AMHX="",AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ..S AMHLINE=AMHLINE+1
  1.  ..S $E(AMHX,6)="Date of Onset: "_$$DATE^AMHVRL($P(AMHP0,U,13))_"   Facility: "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.06)
  1.  ..S AMHBHPL(AMHLINE,0)=AMHX,AMHX="",AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1. NOTE ..;
  1.  ..I '$D(^AMHPTP("AE",AMHPIEN)) D  Q
  1.  ...S AMHLINE=AMHLINE+1
  1.  ...S AMHX=""
  1.  ...S AMHBHPL(AMHLINE,0)=AMHX,AMHX="",AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ..S AMHC=0 S AMHTNDF=0 F  S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF  D
  1.  ...S AMHNIEN=0 F  S AMHNIEN=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF,AMHNIEN)) Q:AMHNIEN'=+AMHNIEN  D
  1.  ....S AMHC=AMHC+1 I AMHC=1 S X=IOINORM_"        "_IORVON_"Notes:"_IORVOFF S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)=X,AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ....S AMHLR=$$VALI^XBDIQ1(9002011.53,AMHNIEN,.07) S AMHLR=$S(AMHLR=1:"STP",AMHLR=2:"LTP",1:"   ")
  1.  ....S X="           "_AMHLR_" Note #"_AMHC_" Added: "_$S($P(^AMHPTP(AMHNIEN,0),U,5)]"":$$FMTE^XLFDT($P(^(0),U,5),5),1:"        ")
  1.  ....S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)=X,AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ....S X="           Narrative:  "_$P(^AMHPTP(AMHNIEN,0),U,4)
  1.  ...S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)=X,AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ..S AMHLINE=AMHLINE+1,AMHBHPL(AMHLINE,0)=IOINORM_"  ",AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  ..;S AMHLINE=AMHLINE+1
  1.  ..;S AMHX=""
  1.  ..;S AMHBHPL(AMHLINE,0)=AMHX,AMHX="",AMHBHPL("IDX",AMHLINE,AMHPRCNT)=AMHPIEN
  1.  .Q
  1.  K AMHLR,AMHL,AMHX,AMHF
  1.  Q
  1. TEXT ;
  1.  ;;
  1.  ;;*****************************************************
  1.  ;;* Update Behavioral Health/PCC Patient Problem List *
  1.  ;;*****************************************************
  1.  ;;
  1.  Q
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K AMHBHPL
  1.  K AMHPRCNT,AMHBPL,AMHLINE,AMHX,AMHP0,AMHC,AMHL,AMHLR,AMHPIEN,AMHAF,AMHPRB,AMHOVRR,AMHLOOK,AMHPDFN,AMHLOC,AMHDATE
  1.  K X,Y
  1.  K VALMHDR
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. ANYNONUU(P,R) ;EP - any problem that is allowed to be seen?
  1.  NEW G,A,B,C
  1.  I '$G(P) Q ""
  1.  I '$G(R) Q ""
  1.  S G=0
  1.  S A=0 F  S A=$O(^AMHPPROB("AC",P,A)) Q:A'=+A!(G)  D
  1.  .Q:$P(^AMHPPROB(A,0),U,12)="D" Q  ;deleted
  1.  .S B=$P(^AMHPPROB(A,0),U,6)
  1.  .Q:'$$ALLOWV^AMHUTIL(R,B)
  1.  .S G=1
  1.  Q G