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

AMHGUA.m

Go to the documentation of this file. 
  1. AMHGUA ; IHS/CMI/MAW - AMH Behavioral Health GUI Utilities continued 9/8/2008 2:00:25 PM ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**1,4**;JUN 18, 2010;Build 28
  1.  ;
  1.  ;
  1. DEBUG(RETVAL,AMHSTR)  ;replace tag below to allow Serenji debug of GUI
  1.  D DEBUG^%Serenji("GETPAT^AMHGUA(.RETVAL,.AMHSTR)")
  1.  Q
  1.  ;
  1. UU(RETVAL,AMHSTR) ;-- return a list of sites in from BH USER file
  1.  N P,AMHUSR,AMHI
  1.  S P="|"
  1.  S AMHUSR=$P(AMHSTR,P)
  1.  S AMHI=0
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  K ^AMHTMP($J)
  1.  S @RETVAL@(AMHI)="T00030UUSite"_$C(30)
  1.  I '$D(^AMHBHUSR(AMHUSR)) D  Q
  1.  . S @RETVAL@(AMHI+1)=$C(31)
  1.  N AMHDA
  1.  S AMHDA=0 F  S AMHDA=$O(^AMHBHUSR(AMHUSR,11,AMHDA)) Q:'AMHDA  D
  1.  . S AMHI=AMHI+1
  1.  . N AMHLOC
  1.  . S AMHLOC=$$GET1^DIQ(9999999.06,AMHDA,.01)
  1.  . S @RETVAL@(AMHI)=AMHLOC_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. ACTCODE(RETVAL,AMHSTR) ;-- return activity code based on code passed in
  1.  N P,AMHACT,AMHI,R
  1.  S P="|",R="~"
  1.  S AMHACT=$P(AMHSTR,P)
  1.  S AMHI=0
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  K ^AMHTMP($J)
  1.  S @RETVAL@(AMHI)="T00080Activity"_$C(30)
  1.  N AMHIEN
  1.  S AMHIEN=$O(^AMHTACT("B",AMHACT,0))
  1.  I 'AMHIEN D  Q
  1.  . S @RETVAL@(AMHI+1)=$C(31)
  1.  N AMHDATA,AMHDSC
  1.  S AMHDATA=$G(^AMHTACT(AMHIEN,0))
  1.  S AMHDSC=$P(AMHDATA,U,2)
  1.  S AMHI=AMHI+1
  1.  S @RETVAL@(AMHI)=AMHIEN_R_AMHDSC_R_AMHACT_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. VC(RETVAL,AMHSTR) ;-- get version number to see if client matches
  1.  N P
  1.  S P="|"
  1.  K ^AMHTMP($J)
  1.  N AMHVER,AMHVERI,AMHVERIN,AMHPKG,AMHI,AMHPTCH,AMHPTCHI,AMHVERI,AMHCHK
  1.  S AMHI=0
  1.  S AMHVERIN=$P(AMHSTR,P)
  1.  ;S AMHVERIN=8.3
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  S ^AMHTMP($J,AMHI)="T00001VersionPresent"_$C(30)
  1.  S AMHI=AMHI+1
  1.  S AMHPKG=$O(^DIC(9.4,"C","AMH",0))
  1.  I '$G(AMHPKG) D  Q
  1.  . S ^AMHTMP($J,AMHI)=0_$C(30)
  1.  . S ^AMHTMP($J,AMHI+1)=$C(31)
  1.  S AMHVER=$G(^DIC(9.4,AMHPKG,"VERSION"))
  1.  S AMHVERI=$O(^DIC(9.4,AMHPKG,22,"B",AMHVER,0))
  1.  S AMHPTCH=$O(^DIC(9.4,AMHPKG,22,AMHVERI,"PAH","B",""),-1)
  1.  I $S($G(AMHPTCH):$E(AMHVER,1,2)_AMHPTCH,1:$E(AMHVER,1,3)_AMHPTCH)=AMHVERIN D  Q
  1.  . S ^AMHTMP($J,AMHI)=1_$C(30)
  1.  . S ^AMHTMP($J,AMHI+1)=$C(31)
  1.  S ^AMHTMP($J,AMHI)=0_$C(30)  ;remove the line below when done with testing and uncomment this one
  1.  ;S ^AMHTMP($J,AMHI)=1_$C(30)
  1.  S ^AMHTMP($J,AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. LOCK(RETVAL,AMHSTR) ;-- check to see if record is locked
  1.  N P,AMHFILE,AMHIEN,AMHI,R,AMHGL,AMHREC,AMHVAL
  1.  S P="|",R="~"
  1.  S AMHFILE=$P(AMHSTR,P)
  1.  S AMHIEN=$P(AMHSTR,P,2)
  1.  S AMHI=0
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  K ^AMHTMP($J)
  1.  S @RETVAL@(AMHI)="T00001Lock"_$C(30)
  1.  S AMHGL=$G(^DIC(AMHFILE,0,"GL"))
  1.  S AMHREC=AMHGL_AMHIEN_")"
  1.  S AMHVAL=0
  1.  L @AMHREC:1
  1.  I $T L -@AMHREC
  1.  I '$T S AMHVAL=1
  1.  S AMHI=AMHI+1
  1.  S @RETVAL@(AMHI)=AMHVAL_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. TIME(RETVAL,AMHSTR) ;-- get system time out based on user or location
  1.  N P,AMHDUZ,AMHDUZ2,AMHI,AMHVAL,AMHVALI
  1.  S P="|"
  1.  S AMHDUZ=$P(AMHSTR,P)
  1.  S AMHDUZ2=$P(AMHSTR,P,2)
  1.  S AMHI=0
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  K ^AMHTMP($J)
  1.  S @RETVAL@(AMHI)="T00010TimeOut"_$C(30)
  1.  S AMHVAL=$$GET1^DIQ(200,AMHDUZ,200.1)
  1.  I '$G(AMHVAL) D
  1.  . S AMHVAL=$$GET1^DIQ(8989.3,1,210)
  1.  S AMHI=AMHI+1
  1.  S @RETVAL@(AMHI)=$G(AMHVAL)_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. VER(RETVAL,AMHSTR) ;-- check to see if verify code is valid
  1.  N AMHVER,AMHVVER,AMHPVER,AMHVAL
  1.  S AMHVER=AMHSTR
  1.  S AMHVVER=$$EN^XUSHSH($$UP^XLFSTR(AMHVER))
  1.  S AMHPVER=$P($G(^VA(200,DUZ,.1)),U,2)
  1.  S AMHVAL=$S(AMHVVER=AMHPVER:1,1:0)
  1.  S RETVAL=AMHVAL
  1.  Q
  1.  ;
  1. POV(RET,AMHPAT,AMHD) ;EP -- filter POV if allowed to see
  1.  ;v4.0p1 ihs/cmi/maw 11/4/2010 modified to prevent duplicates
  1.  NEW AMHC1,AMHA,AMHMSG,%,AMHA,AMHB,AMHT,AMHV,AMHC,AMHCC,X,S,Y,Z,AMHVAL1,AMHVAL2,AMHCNT ;CMI/TUCSON/LAB - added X,S,Y,Z patch 1 10/06/97
  1.  Q:'$G(AMHPAT)
  1.  K ^TMP("AMHTMP",$J)
  1.  S AMHC=$$VAL^XBDIQ1(9002013,DUZ(2),.25) S:'AMHC AMHC=10
  1.  ;S AMHC=10  ;not using site parameter for GUI v4.0p1 02/23/2011
  1.  S AMHC1=1
  1.  S AMHCNT=0
  1.  S (AMHA,AMHV,AMHCC)=0 F  S AMHA=$O(^AMHREC("AE",AMHPAT,AMHA)) Q:AMHA'=+AMHA!(AMHV)  D
  1.  .S AMHT=0 F  S AMHT=$O(^AMHREC("AE",AMHPAT,AMHA,AMHT)) Q:AMHT'=+AMHT!(AMHV)  D
  1.  ..I $P($G(^AMHSITE(DUZ(2),0)),U,26) Q:$$NOSHOW^AMHLESM(AMHT)
  1.  ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHT)
  1.  ..S AMHB=0 F  S AMHB=$O(^AMHRPRO("AD",AMHT,AMHB)) Q:AMHB'=+AMHB  D
  1.  ...Q:'$P(^AMHRPRO(AMHB,0),U,3)
  1.  ...N AMHPIEN
  1.  ...S AMHPIEN=$P($G(^AMHRPRO(AMHB,0)),U)
  1.  ...;Q:'$$CURCOD(AMHPIEN)  ;v4.0p4 screen out codes not in the current code set
  1.  ...Q:'$$CHKD^AMHUTIL1(AMHPIEN,AMHD)
  1.  ...S AMHCC=AMHCC+1 I (AMHCC-1)=AMHC S AMHV=AMHT Q
  1.  ...S AMHCNT=AMHCNT+1
  1.  ...;S ^TMP("AMHTMP",$J,AMHB)=AMHCNT_U_AMHPIEN
  1.  ...S ^TMP("AMHTMP",$J,AMHCNT,AMHB)=AMHPIEN
  1.  N AMHTDA,AMHTCNT,AMHTIEN,AMHCN
  1.  S AMHCN=0
  1.  ;S AMHTDA=0 F  S AMHTDA=$O(^TMP("AMHTMP",$J,AMHTDA)) Q:'AMHTDA  D
  1.  S AMHTCNT=0 F  S AMHTCNT=$O(^TMP("AMHTMP",$J,AMHTCNT)) Q:'AMHTCNT  D
  1.  .;S AMHTCNT=$G(^TMP("AMHTMP",$J,AMHTDA))
  1.  .S AMHTDA=0 F  S AMHTDA=$O(^TMP("AMHTMP",$J,AMHTCNT,AMHTDA)) Q:'AMHTDA  D
  1.  ..S AMHCN=AMHCN+1
  1.  ..S AMHTIEN=$P($G(^TMP("AMHTMP",$J,AMHTCNT,AMHTDA)),U)
  1.  ..S AMHVAL1=$$GET1^DIQ(9002011.01,AMHTDA,.01)
  1.  ..S AMHVAL2=$$GET1^DIQ(9002011.01,AMHTDA,.04)
  1.  ..S @RET@(AMHCN)=AMHTIEN_U_AMHVAL1_U_AMHVAL2_$C(30)
  1.  .;S AMHC1=AMHC1+1
  1.  S @RET@(AMHCN+1)=$C(31)
  1.  Q
  1.  ;
  1. CURCOD(PIEN) ;-- check the code to see if it is the current version of code set
  1.  N CV
  1.  S CV=$$DSMVDT^AMHUTIL1(DUZ(2))
  1.  I '$G(CV) S CV=4
  1.  I $$GET1^DIQ(9002012.2,PIEN,.1)=CV Q 1
  1.  Q 0
  1.  ;
  1. LABG(RETVAL,AMHSTR) ;-- graph labs
  1.  N P,AMHI,AMHB,AMHE,AMHBD,AMHED,AMHP,AMHL,AMHD,AMHR,AMHA,AMHRL,AMHRH
  1.  S P="|"
  1.  S AMHB=$P(AMHSTR,P)
  1.  S AMHE=$P(AMHSTR,P,2)
  1.  S AMHP=$P(AMHSTR,P,3)
  1.  S AMHL=$P(AMHSTR,P,4)
  1.  S AMHI=0
  1.  K ^AMHTMP($J)
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  S @RETVAL@(AMHI)="T00030Date^T00050Normal Result^T00010Abnormal Result"_$C(30)  ;^T00010Abnormal^T00030Ref Low^T00030Ref High"_$C(30)
  1.  S AMHBD=9999999-AMHB
  1.  S AMHED=9999999-AMHE
  1.  N AMHDA,AMHIEN
  1.  S AMHDA=AMHED F  S AMHDA=$O(^AUPNVLAB("AA",AMHP,AMHL,AMHDA)) Q:'AMHDA!(AMHDA>AMHBD)  D
  1.  . S AMHIEN=0 F  S AMHIEN=$O(^AUPNVLAB("AA",AMHP,AMHL,AMHDA,AMHIEN)) Q:'AMHIEN  D
  1.  .. S AMHD=9999999-AMHDA
  1.  .. S AMHR=$$GET1^DIQ(9000010.09,AMHIEN,.04)
  1.  .. S AMHA=$$GET1^DIQ(9000010.09,AMHIEN,.05)
  1.  .. S AMHRL=$$GET1^DIQ(9000010.09,AMHIEN,1104)
  1.  .. S AMHRH=$$GET1^DIQ(9000010.09,AMHIEN,1105)
  1.  .. S AMHI=AMHI+1
  1.  .. S @RETVAL@(AMHI)=$$LVDT^AMHGU(AMHD)_U_AMHR_U_$S(AMHA]"":AMHR,1:"")_$C(30)  ;U_AMHA_U_AMHRL_U_AMHRH_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. CLNWP(FL,ND,REC) ;-- lets clean up a wp field before refiling
  1.  N RDA,GL,GLN
  1.  S DA(1)=REC
  1.  S GL=$G(^DIC(FL,0,"GL"))
  1.  S GLN=GL_REC_","_ND_")"
  1.  S RDA=0 F  S RDA=$O(@GLN@(RDA)) Q:'RDA  D
  1.  . S DA=RDA
  1.  . S DIK=GL_REC_","_ND_","
  1.  . D ^DIK
  1.  Q
  1.  ;
  1. VEXIST(RETVAL,AMHSTR) ;-- check to see if there is a visit on the record (used for group edit)
  1.  N P,AMHREC,AMHI,AMHX
  1.  S P="|"
  1.  S AMHREC=$P(AMHSTR,P)
  1.  K ^AMHTMP($J)
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  S AMHI=0
  1.  S @RETVAL@(AMHI)="T00001VisitExists"_$C(30)
  1.  S AMHI=AMHI+1
  1.  S AMHX=$S($$GET1^DIQ(9002011,AMHREC,.16,"I"):1,1:0)
  1.  S @RETVAL@(AMHI)=AMHX_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. CHKDSM(RETVAL,AMHSTR) ;-- check which version of DSM
  1.  N P,AMHS,AMHD
  1.  S P="|"
  1.  S AMHS=$P(AMHSTR,P)
  1.  K ^AMHTMP($J)
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  S AMHI=0
  1.  S @RETVAL@(AMHI)="T00001DSM"_$C(30)
  1.  S AMHI=AMHI+1
  1.  S AMHD=$$GET1^DIQ(9002013,AMHS,1811,"I")
  1.  I AMHD="" S AMHD=9999999
  1.  ;S AMHD=$S($G(AMHD)]"":5,1:4)  ;default to DSM-IV if blank
  1.  S @RETVAL@(AMHI)=AMHD_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;