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