HMPDJ09M ;SLC/MKB,ASMR/RRB - Mental Health;Nov 16, 2015 17:15:13
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Sep 01, 2011;Build 63
;Per VA Directive 6402, this routine should not be modified.
;
; All tags expect DFN, ID, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
Q
;
MH ; -- Mental Health Administrations [from ^HMPDJ0]
I $G(HMPID) D MH1(HMPID) Q
N CNT,HMPIDT,ID,FNUM,TOTAL,HMPOUT,HMPYS,IEN
;
;DE2818, for ^YTT(601.71), subscription needed to ICR 5044
S IEN=0 F S IEN=$O(^YTT(601.71,IEN)) Q:IEN'>0 D
.S HMPYS("CODE")=IEN,HMPYS("DFN")=+$G(DFN),HMPYS("LIMIT")=999
.K HMPOUT
.D PTTEST^YTQPXRM2(.HMPOUT,.HMPYS)
.I HMPOUT(1)["[ERROR]" Q
.S TOTAL=$P(HMPOUT(1),U,2)+1
.I $P(HMPOUT(1),U,2)<1 Q
.;S CNT=1 F S CNT=$O(HMPOUT(CNT)) Q:CNT'>0 D
.F CNT=2:1:TOTAL D
..I $G(HMPOUT(CNT))="" Q
..S ID=$P(HMPOUT(CNT),U)
..D MH1(ID,IEN)
;handle old MH test before the latest revision to their package
;S FNUM=601.2 D SORT^HMPDJ09 ;sort ^PXRMINDX into ^TMP("HMPPX",$J,IDT)
;S HMPIDT=0 F S HMPIDT=$O(^TMP("HMPPX",$J,HMPIDT)) Q:HMPIDT<1 D Q:HMPI'<HMPMAX
;. S ID=0 F S ID=$O(^TMP("HMPPX",$J,HMPIDT,ID)) Q:ID<1 D YT1^HMPDJ09(ID) Q:HMPI'<HMPMAX
;I HMPI'<HMPMAX Q
;handle new MH test after revision to their package
;S FNUM=601.84 D SORT^HMPDJ09 ;sort ^PXRMINDX into ^TMP("HMPPX",$J,IDT)
;S HMPIDT=0 F S HMPIDT=$O(^TMP("HMPPX",$J,HMPIDT)) Q:HMPIDT<1 D Q:HMPI'<HMPMAX
;. S ID=0 F S ID=$O(^TMP("HMPPX",$J,HMPIDT,ID)) Q:ID<1 D YT1^HMPDJ09(ID) Q:HMPI'<HMPMAX
K ^TMP("HMPPX",$J)
Q
;
MH1(ID,IEN) ; -- MH Administration
N HMPY,COPY,GBL,ISCOPY,MH,NAME,NODE,CNT,I,X2,X,Y,TEMP,TEXT
D ENDAS71^YTQPXRM6(.HMPY,ID)
;DE2818, for ^YTT(601.71), subscription needed to ICR 5044
S NAME=$P($G(^YTT(601.71,IEN,0)),U) ;(#.01) NAME
S COPY=$G(^YTT(601.71,IEN,7)) ;(#21) COPYRIGHT TEXT
S ISCOPY=+$P($G(^YTT(601.71,IEN,8)),U,5) ;(#25) IS COPYRIGHTED
;HMPY(2) = Patient Name (1)^Test Code (2)^Test Title (3)^Internal Admin date (4)^External Admin Date (5)^Ordered by (6)
S MH("localId")=ID,X2=$G(HMPY(2))
S MH("uid")=$$SETUID^HMPUTILS("mh",DFN,ID)
S MH("displayName")=$P(X2,U,2),MH("name")=$S(NAME'="":NAME,1:$P(X2,U,3))
S MH("administeredDateTime")=$$JSONDT^HMPUTILS($P(X2,U,4))
S X=$P(X2,U,6) I $L(X) D ;ordered by
. N HMPERR,HMPOUT ;DE2818, changed ^VA(200,"B") global reference to FileMan
. D FIND^DIC(200,"","@;.01","X",X,"","B","","","HMPOUT","HMPERR")
. ; if single result found save it in Y, else zero
. S Y=$S($P($G(HMPOUT("DILIST",0)),U)=1:$G(HMPOUT("DILIST",2,1)),1:0)
. S MH("providerName")=X
. S:Y MH("providerUid")=$$SETUID^HMPUTILS("user",,Y)
;get questions/answers for test
S I=0,CNT=0 F S I=$O(HMPY("R",I)) Q:I'>0 D
.S NODE=$G(HMPY("R",I))
.S CNT=CNT+1
.K TEMP,^TMP($J,"HMP MH TEXT")
.;answers
.S TEMP=$P(NODE,U,2) I TEMP>0 D
..S MH("responses",CNT,"answer","uid")=$$SETVURN^HMPUTILS("mha-answer",TEMP)
..S MH("responses",CNT,"answer","text")=$P(NODE,U,6)
.;questions
.S TEMP=$P(NODE,U,3) I TEMP>0 D
..S MH("responses",CNT,"question","uid")=$$SETVURN^HMPUTILS("mha-question",TEMP)
..;DE2818 - ^YTT(601.72,D0,1,D1,0)= (#.01) QUESTION TEXT [1W], ICR 6277
..S GBL=$NA(^YTT(601.72,TEMP,1))
..D SETTEXT^HMPUTILS(GBL,$NA(^TMP($J,"HMP MH TEXT")))
..M MH("responses",CNT,"question","text","\")=^TMP($J,"HMP MH TEXT")
; get scale(s) for test
S I=0,CNT=0 F S I=$O(HMPY("SI",I)) Q:I'>0 D
.S NODE=$G(HMPY("SI",I))
.S CNT=CNT+1
.S MH("scales",CNT,"scale","uid")=$$SETVURN^HMPUTILS("mha-scale",I)
.S MH("scales",CNT,"scale","name")=$P(NODE,U,2)
.S MH("scales",CNT,"scale","rawScore")=$P(NODE,U,3)
.I $P(NODE,U,4)'="" S MH("scales",CNT,"scale","transformScore")=$P(NODE,U,4)
S MH("isCopyright")=$S(ISCOPY=1:"true",1:"false")
I ISCOPY=1 S MH("copyrightText")=COPY
S MH("lastUpdateTime")=$$EN^HMPSTMP("mh") ;RHL 20150103
S MH("stampTime")=MH("lastUpdateTime") ; RHL 20150103
;US6734 - pre-compile metastamp
I $G(HMPMETA) D ADD^HMPMETA("mh",MH("uid"),MH("stampTime")) Q:HMPMETA=1 ;US6734,US11019
D ADD^HMPDJ("MH","mh")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ09M 4059 printed Sep 23, 2025@19:29:31 Page 2
HMPDJ09M ;SLC/MKB,ASMR/RRB - Mental Health;Nov 16, 2015 17:15:13
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Sep 01, 2011;Build 63
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; All tags expect DFN, ID, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
+5 QUIT
+6 ;
MH ; -- Mental Health Administrations [from ^HMPDJ0]
+1 IF $GET(HMPID)
DO MH1(HMPID)
QUIT
+2 NEW CNT,HMPIDT,ID,FNUM,TOTAL,HMPOUT,HMPYS,IEN
+3 ;
+4 ;DE2818, for ^YTT(601.71), subscription needed to ICR 5044
+5 SET IEN=0
FOR
SET IEN=$ORDER(^YTT(601.71,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+6 SET HMPYS("CODE")=IEN
SET HMPYS("DFN")=+$GET(DFN)
SET HMPYS("LIMIT")=999
+7 KILL HMPOUT
+8 DO PTTEST^YTQPXRM2(.HMPOUT,.HMPYS)
+9 IF HMPOUT(1)["[ERROR]"
QUIT
+10 SET TOTAL=$PIECE(HMPOUT(1),U,2)+1
+11 IF $PIECE(HMPOUT(1),U,2)<1
QUIT
+12 ;S CNT=1 F S CNT=$O(HMPOUT(CNT)) Q:CNT'>0 D
+13 FOR CNT=2:1:TOTAL
Begin DoDot:2
+14 IF $GET(HMPOUT(CNT))=""
QUIT
+15 SET ID=$PIECE(HMPOUT(CNT),U)
+16 DO MH1(ID,IEN)
End DoDot:2
End DoDot:1
+17 ;handle old MH test before the latest revision to their package
+18 ;S FNUM=601.2 D SORT^HMPDJ09 ;sort ^PXRMINDX into ^TMP("HMPPX",$J,IDT)
+19 ;S HMPIDT=0 F S HMPIDT=$O(^TMP("HMPPX",$J,HMPIDT)) Q:HMPIDT<1 D Q:HMPI'<HMPMAX
+20 ;. S ID=0 F S ID=$O(^TMP("HMPPX",$J,HMPIDT,ID)) Q:ID<1 D YT1^HMPDJ09(ID) Q:HMPI'<HMPMAX
+21 ;I HMPI'<HMPMAX Q
+22 ;handle new MH test after revision to their package
+23 ;S FNUM=601.84 D SORT^HMPDJ09 ;sort ^PXRMINDX into ^TMP("HMPPX",$J,IDT)
+24 ;S HMPIDT=0 F S HMPIDT=$O(^TMP("HMPPX",$J,HMPIDT)) Q:HMPIDT<1 D Q:HMPI'<HMPMAX
+25 ;. S ID=0 F S ID=$O(^TMP("HMPPX",$J,HMPIDT,ID)) Q:ID<1 D YT1^HMPDJ09(ID) Q:HMPI'<HMPMAX
+26 KILL ^TMP("HMPPX",$JOB)
+27 QUIT
+28 ;
MH1(ID,IEN) ; -- MH Administration
+1 NEW HMPY,COPY,GBL,ISCOPY,MH,NAME,NODE,CNT,I,X2,X,Y,TEMP,TEXT
+2 DO ENDAS71^YTQPXRM6(.HMPY,ID)
+3 ;DE2818, for ^YTT(601.71), subscription needed to ICR 5044
+4 ;(#.01) NAME
SET NAME=$PIECE($GET(^YTT(601.71,IEN,0)),U)
+5 ;(#21) COPYRIGHT TEXT
SET COPY=$GET(^YTT(601.71,IEN,7))
+6 ;(#25) IS COPYRIGHTED
SET ISCOPY=+$PIECE($GET(^YTT(601.71,IEN,8)),U,5)
+7 ;HMPY(2) = Patient Name (1)^Test Code (2)^Test Title (3)^Internal Admin date (4)^External Admin Date (5)^Ordered by (6)
+8 SET MH("localId")=ID
SET X2=$GET(HMPY(2))
+9 SET MH("uid")=$$SETUID^HMPUTILS("mh",DFN,ID)
+10 SET MH("displayName")=$PIECE(X2,U,2)
SET MH("name")=$SELECT(NAME'="":NAME,1:$PIECE(X2,U,3))
+11 SET MH("administeredDateTime")=$$JSONDT^HMPUTILS($PIECE(X2,U,4))
+12 ;ordered by
SET X=$PIECE(X2,U,6)
IF $LENGTH(X)
Begin DoDot:1
+13 ;DE2818, changed ^VA(200,"B") global reference to FileMan
NEW HMPERR,HMPOUT
+14 DO FIND^DIC(200,"","@;.01","X",X,"","B","","","HMPOUT","HMPERR")
+15 ; if single result found save it in Y, else zero
+16 SET Y=$SELECT($PIECE($GET(HMPOUT("DILIST",0)),U)=1:$GET(HMPOUT("DILIST",2,1)),1:0)
+17 SET MH("providerName")=X
+18 if Y
SET MH("providerUid")=$$SETUID^HMPUTILS("user",,Y)
End DoDot:1
+19 ;get questions/answers for test
+20 SET I=0
SET CNT=0
FOR
SET I=$ORDER(HMPY("R",I))
if I'>0
QUIT
Begin DoDot:1
+21 SET NODE=$GET(HMPY("R",I))
+22 SET CNT=CNT+1
+23 KILL TEMP,^TMP($JOB,"HMP MH TEXT")
+24 ;answers
+25 SET TEMP=$PIECE(NODE,U,2)
IF TEMP>0
Begin DoDot:2
+26 SET MH("responses",CNT,"answer","uid")=$$SETVURN^HMPUTILS("mha-answer",TEMP)
+27 SET MH("responses",CNT,"answer","text")=$PIECE(NODE,U,6)
End DoDot:2
+28 ;questions
+29 SET TEMP=$PIECE(NODE,U,3)
IF TEMP>0
Begin DoDot:2
+30 SET MH("responses",CNT,"question","uid")=$$SETVURN^HMPUTILS("mha-question",TEMP)
+31 ;DE2818 - ^YTT(601.72,D0,1,D1,0)= (#.01) QUESTION TEXT [1W], ICR 6277
+32 SET GBL=$NAME(^YTT(601.72,TEMP,1))
+33 DO SETTEXT^HMPUTILS(GBL,$NAME(^TMP($JOB,"HMP MH TEXT")))
+34 MERGE MH("responses",CNT,"question","text","\")=^TMP($JOB,"HMP MH TEXT")
End DoDot:2
End DoDot:1
+35 ; get scale(s) for test
+36 SET I=0
SET CNT=0
FOR
SET I=$ORDER(HMPY("SI",I))
if I'>0
QUIT
Begin DoDot:1
+37 SET NODE=$GET(HMPY("SI",I))
+38 SET CNT=CNT+1
+39 SET MH("scales",CNT,"scale","uid")=$$SETVURN^HMPUTILS("mha-scale",I)
+40 SET MH("scales",CNT,"scale","name")=$PIECE(NODE,U,2)
+41 SET MH("scales",CNT,"scale","rawScore")=$PIECE(NODE,U,3)
+42 IF $PIECE(NODE,U,4)'=""
SET MH("scales",CNT,"scale","transformScore")=$PIECE(NODE,U,4)
End DoDot:1
+43 SET MH("isCopyright")=$SELECT(ISCOPY=1:"true",1:"false")
+44 IF ISCOPY=1
SET MH("copyrightText")=COPY
+45 ;RHL 20150103
SET MH("lastUpdateTime")=$$EN^HMPSTMP("mh")
+46 ; RHL 20150103
SET MH("stampTime")=MH("lastUpdateTime")
+47 ;US6734 - pre-compile metastamp
+48 ;US6734,US11019
IF $GET(HMPMETA)
DO ADD^HMPMETA("mh",MH("uid"),MH("stampTime"))
if HMPMETA=1
QUIT
+49 DO ADD^HMPDJ("MH","mh")
+50 QUIT
