YTQRCDB2 ;BAL/KTL - MHA CLOUD DATABASE RPC CALLS;Jun 18, 2025@08:53:54
;;5.01;MENTAL HEALTH;**239,250,236,246**;Dec 30, 1994;Build 38
;
;
;Reference to VADPT APIs supported by ICR #10061
;Reference to $$KSP^XUPARAM supported by ICR #2541
;Reference to DIUTC supported by ICR #6445
;Reference to PXRMINDX in ICR #4290
;
Q
PID2(ARGS,RESULTS) ;Get additional patient demographics
N DFN,VA,VADM,YSNM,YSDOB,YSAGE,YSSSN,YSSEX,YSSX,YSSIG
S DFN=$G(ARGS("dfn"))
I +DFN=0 D SETERROR^YTQRUTL(404,"Bad patient identifier") QUIT
I '$D(^DPT(DFN,0)) D SETERROR^YTQRUTL(404,"Not Found: "_DFN) QUIT
D DEM^VADPT,PID^VADPT
S YSNM=VADM(1)
S YSDOB=$P(VADM(3),U,2)
S YSAGE=VADM(4)
S YSSSN="xxx-xx-"_VA("BID")
S YSSEX=$P(VADM(5),U,1)
S YSSX=YSSEX
S YSSIG=$P($G(VADM(14,5)),U,2)
S RESULTS("dob")=YSDOB
S RESULTS("ssn")=YSSSN
S RESULTS("sex")=YSSEX
S RESULTS("sigi")=YSSIG
Q
TZ(ARGS,RESULTS) ;Get Timezone
N INST,PROP,UTC
F PROP="fileman","external","offset","timezone" D
. S RESULTS(PROP)=""
S INST=$$KSP^XUPARAM("INST") Q:+INST=0
S UTC=$$UTC^DIUTC($$NOW^XLFDT(),,INST,,1)
S RESULTS("fileman")=$P(UTC,U)
S RESULTS("external")=$P(UTC,U,2)
S RESULTS("offset")=$P(UTC,U,3)
S RESULTS("timezone")=$P(UTC,U,4)
Q
GETLIST(ARGS,RESULTS) ; GET Insts for Pat
N LST,TST,I,NM,TEST,DFN,SRISK
N ADMINDT,ADMINID,CMPL,CNT,HIT,PAT,G,YSIENS,YSDATA,N,STR,ERRLST,ERRSTR
N ADMINAR,XDT,SAVEDT,SRC,ORD,RVW,NAME
N NMARR
S NM="",N=0
K ^TMP("YTQ-JSON",$J) S CNT=0
D SETRES("{""instruments"":[")
S HIT=""
S DFN=+$G(ARGS("dfn"))
D UPDTSRFL^YTQRQAD4 ; update Suicide Risk Flag
I DFN'?1N.NP D SETERROR^YTQRUTL(404,"Bad Patient ID: "_DFN) QUIT
I '$D(^DPT(DFN,0)) D SETERROR^YTQRUTL(404,"Patient Not Found: "_DFN) QUIT
F S NM=$O(^YTT(601.84,"C",DFN,NM)) Q:'NM D
.S G=$G(^YTT(601.84,NM,0))
.I G="" S ERRLST(NM)="" Q ;-->out
.S CMPL=$P(G,U,9) Q:CMPL'="Y"
.S ADMINDT=$P(G,U,4) Q:ADMINDT=""
.S TST=$P(G,U,3),NAME=$P($G(^YTT(601.71,TST,0)),U,1)
.S SRISK=$P(G,U,14) I SRISK="" S SRISK=0
.Q:$G(NMARR(NAME))'=""&($G(NMARR(NAME))>ADMINDT)
.I $D(NMARR(NAME)) K ADMINAR(-NMARR(NAME),NAME)
.S ADMINAR(-ADMINDT,NAME)=SRISK,NMARR(NAME)=ADMINDT
S XDT="" F S XDT=$O(ADMINAR(XDT)) Q:XDT="" D
.S NM="" F S NM=$O(ADMINAR(XDT,NM)) Q:NM="" D
..S STR="{""instrumentName"":"""_NM_""", ""suicideRisk"":"""_ADMINAR(XDT,NM)_""" },"
..D SETRES(STR) S HIT=1
I HIT S STR=^TMP("YTQ-JSON",$J,CNT,0),STR=$E(STR,1,$L(STR)-1),^TMP("YTQ-JSON",$J,CNT,0)=STR
D SETRES("]}")
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
GETALST(ARGS,RESULTS) ; GET admins for Pat+Inst
N TST,I,ADM,TEST,DFN,SRISK
N ADMINDT,ADMINID,CMPL,CNT,HIT,G,N,STR
N XDT,SAVEDT,SRC,ORD,RVW,INSTIEN
S ADM="",N=0
K ^TMP("YTQ-JSON",$J) S CNT=0
S HIT=""
S DFN=+$G(ARGS("dfn")),TEST=$G(ARGS("instrumentName"))
I DFN'?1N.NP D SETERROR^YTQRUTL(404,"Bad Patient ID: "_DFN) QUIT
I '$D(^DPT(DFN,0)) D SETERROR^YTQRUTL(404,"Patient Not Found: "_DFN) QUIT
S INSTIEN=$O(^YTT(601.71,"B",TEST,0)) I +INSTIEN=0 D SETERROR^YTQRUTL(404,"Instrument Not Found: "_TEST) QUIT
D SETRES("{""instruments"":[")
S XDT=""
I TEST="IMHOA" D ;Only for IMHOA to find incomplete admins as well
. S ADM=0 F S ADM=$O(^YTT(601.84,"C",DFN,ADM)) Q:ADM="" D
.. S G=$G(^YTT(601.84,ADM,0))
.. I G="" Q
.. S CMPL=$P(G,U,9) Q:CMPL="Y"
.. S STR=""
.. S TST=$P(G,U,3),ORD=$P(G,U,6),RVW=$P(G,U,17)
.. S SRC=$P(G,U,13) S:SRC'="" SRC=$P($G(^YTT(601.844,SRC,0)),U)
.. S ADMINID=$P(G,U,1),ADMINDT=$P($P(G,U,4),":",1,2)
.. S SAVEDT=$P($P(G,U,5),":",1,2)
.. S SRISK=$P(G,U,14) I SRISK="" S SRISK=0
.. S STR="{""adminId"":"""_ADMINID_""", ""instrumentName"":"""_TEST_""" , ""instrumentIen"":"""_INSTIEN_""" , ""administrationDate"":"""_$P($$FMTE^XLFDT(ADMINDT),":",1,2)
.. S STR=STR_""" , ""saveDate"":"""_$P($$FMTE^XLFDT(SAVEDT),":",1,2)_""" , ""suicideRisk"":"""_SRISK_""", ""entrySource"":"""_SRC
.. S STR=STR_""" , ""orderedBy"":"""_ORD_""" , ""reviewed"":"""_RVW_""" , ""isComplete"":"""_CMPL_""" },"
.. D SETRES(STR) S HIT=1
I TEST'="IMHOA" F S XDT=$O(^PXRMINDX(601.84,"PI",DFN,INSTIEN,XDT),-1) Q:XDT="" D ;Get list of instr IENs
. S ADM=0 F S ADM=$O(^PXRMINDX(601.84,"PI",DFN,INSTIEN,XDT,ADM)) Q:ADM="" D
.. S G=$G(^YTT(601.84,ADM,0))
.. I G="" Q
.. S CMPL=$P(G,U,9) Q:CMPL'="Y"
.. S STR=""
.. S TST=$P(G,U,3),ORD=$P(G,U,6),RVW=$P(G,U,17)
.. S SRC=$P(G,U,13) S:SRC'="" SRC=$P($G(^YTT(601.844,SRC,0)),U)
.. S ADMINID=$P(G,U,1),ADMINDT=$P($P(G,U,4),":",1,2)
.. S SAVEDT=$P($P(G,U,5),":",1,2)
.. S SRISK=$P(G,U,14) I SRISK="" S SRISK=0
.. S STR="{""adminId"":"""_ADMINID_""", ""instrumentName"":"""_TEST_""" , ""instrumentIen"":"""_INSTIEN_""" , ""administrationDate"":"""_$P($$FMTE^XLFDT(ADMINDT),":",1,2)
.. S STR=STR_""" , ""saveDate"":"""_$P($$FMTE^XLFDT(SAVEDT),":",1,2)_""" , ""suicideRisk"":"""_SRISK_""", ""entrySource"":"""_SRC
.. S STR=STR_""" , ""orderedBy"":"""_ORD_""" , ""reviewed"":"""_RVW_""" , ""isComplete"":"""_CMPL_""" },"
.. D SETRES(STR) S HIT=1
I HIT S STR=^TMP("YTQ-JSON",$J,CNT,0),STR=$E(STR,1,$L(STR)-1),^TMP("YTQ-JSON",$J,CNT,0)=STR
D SETRES("]}")
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
SETRES(STR) ;
S CNT=CNT+1,^TMP("YTQ-JSON",$J,CNT,0)=STR
Q
GETAD(ARGS,RESULTS) ; GET properties for a single admin
N ADMIN,G,TST,TEST,ORD,RVW,SRC,ADMINID,ADMINDT,SAVEDT,SRISK
S ADMIN=+$G(ARGS("adminId"))
I ADMIN=0 D SETERROR^YTQRUTL(404,"Administration not sent.") QUIT
I '$D(^YTT(601.84,ADMIN)) D SETERROR^YTQRUTL(404,"Administration not found.") QUIT
S G=$G(^YTT(601.84,ADMIN,0))
I G="" Q
S CMPL=$P(G,U,9) Q:CMPL'="Y"
S STR=""
S TST=$P(G,U,3),ORD=$P(G,U,6),RVW=$P(G,U,17)
S TEST=$P($G(^YTT(601.71,TST,0)),U)
S SRC=$P(G,U,13) S:SRC'="" SRC=$P($G(^YTT(601.844,SRC,0)),U)
S ADMINID=$P(G,U,1),ADMINDT=$P($P(G,U,4),":",1,2)
S SAVEDT=$P($P(G,U,5),":",1,2)
S SRISK=$P(G,U,14) I SRISK="" S SRISK=0
S RESULTS("adminId")=ADMINID
S RESULTS("instrumentName")=TEST
S RESULTS("instrumentIen")=TST
S RESULTS("administrationDate")=$P($$FMTE^XLFDT(ADMINDT),":",1,2)
S RESULTS("saveDate")=$P($$FMTE^XLFDT(SAVEDT),":",1,2)
S RESULTS("suicideRisk")=SRISK
S RESULTS("entrySource")=SRC
S RESULTS("orderedBy")=ORD
S RESULTS("reviewed")=RVW
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRCDB2 6248 printed Oct 28, 2026@01:13:19 Page 2
YTQRCDB2 ;BAL/KTL - MHA CLOUD DATABASE RPC CALLS;Jun 18, 2025@08:53:54
+1 ;;5.01;MENTAL HEALTH;**239,250,236,246**;Dec 30, 1994;Build 38
+2 ;
+3 ;
+4 ;Reference to VADPT APIs supported by ICR #10061
+5 ;Reference to $$KSP^XUPARAM supported by ICR #2541
+6 ;Reference to DIUTC supported by ICR #6445
+7 ;Reference to PXRMINDX in ICR #4290
+8 ;
+9 QUIT
PID2(ARGS,RESULTS) ;Get additional patient demographics
+1 NEW DFN,VA,VADM,YSNM,YSDOB,YSAGE,YSSSN,YSSEX,YSSX,YSSIG
+2 SET DFN=$GET(ARGS("dfn"))
+3 IF +DFN=0
DO SETERROR^YTQRUTL(404,"Bad patient identifier")
QUIT
+4 IF '$DATA(^DPT(DFN,0))
DO SETERROR^YTQRUTL(404,"Not Found: "_DFN)
QUIT
+5 DO DEM^VADPT
DO PID^VADPT
+6 SET YSNM=VADM(1)
+7 SET YSDOB=$PIECE(VADM(3),U,2)
+8 SET YSAGE=VADM(4)
+9 SET YSSSN="xxx-xx-"_VA("BID")
+10 SET YSSEX=$PIECE(VADM(5),U,1)
+11 SET YSSX=YSSEX
+12 SET YSSIG=$PIECE($GET(VADM(14,5)),U,2)
+13 SET RESULTS("dob")=YSDOB
+14 SET RESULTS("ssn")=YSSSN
+15 SET RESULTS("sex")=YSSEX
+16 SET RESULTS("sigi")=YSSIG
+17 QUIT
TZ(ARGS,RESULTS) ;Get Timezone
+1 NEW INST,PROP,UTC
+2 FOR PROP="fileman","external","offset","timezone"
Begin DoDot:1
+3 SET RESULTS(PROP)=""
End DoDot:1
+4 SET INST=$$KSP^XUPARAM("INST")
if +INST=0
QUIT
+5 SET UTC=$$UTC^DIUTC($$NOW^XLFDT(),,INST,,1)
+6 SET RESULTS("fileman")=$PIECE(UTC,U)
+7 SET RESULTS("external")=$PIECE(UTC,U,2)
+8 SET RESULTS("offset")=$PIECE(UTC,U,3)
+9 SET RESULTS("timezone")=$PIECE(UTC,U,4)
+10 QUIT
GETLIST(ARGS,RESULTS) ; GET Insts for Pat
+1 NEW LST,TST,I,NM,TEST,DFN,SRISK
+2 NEW ADMINDT,ADMINID,CMPL,CNT,HIT,PAT,G,YSIENS,YSDATA,N,STR,ERRLST,ERRSTR
+3 NEW ADMINAR,XDT,SAVEDT,SRC,ORD,RVW,NAME
+4 NEW NMARR
+5 SET NM=""
SET N=0
+6 KILL ^TMP("YTQ-JSON",$JOB)
SET CNT=0
+7 DO SETRES("{""instruments"":[")
+8 SET HIT=""
+9 SET DFN=+$GET(ARGS("dfn"))
+10 ; update Suicide Risk Flag
DO UPDTSRFL^YTQRQAD4
+11 IF DFN'?1N.NP
DO SETERROR^YTQRUTL(404,"Bad Patient ID: "_DFN)
QUIT
+12 IF '$DATA(^DPT(DFN,0))
DO SETERROR^YTQRUTL(404,"Patient Not Found: "_DFN)
QUIT
+13 FOR
SET NM=$ORDER(^YTT(601.84,"C",DFN,NM))
if 'NM
QUIT
Begin DoDot:1
+14 SET G=$GET(^YTT(601.84,NM,0))
+15 ;-->out
IF G=""
SET ERRLST(NM)=""
QUIT
+16 SET CMPL=$PIECE(G,U,9)
if CMPL'="Y"
QUIT
+17 SET ADMINDT=$PIECE(G,U,4)
if ADMINDT=""
QUIT
+18 SET TST=$PIECE(G,U,3)
SET NAME=$PIECE($GET(^YTT(601.71,TST,0)),U,1)
+19 SET SRISK=$PIECE(G,U,14)
IF SRISK=""
SET SRISK=0
+20 if $GET(NMARR(NAME))'=""&($GET(NMARR(NAME))>ADMINDT)
QUIT
+21 IF $DATA(NMARR(NAME))
KILL ADMINAR(-NMARR(NAME),NAME)
+22 SET ADMINAR(-ADMINDT,NAME)=SRISK
SET NMARR(NAME)=ADMINDT
End DoDot:1
+23 SET XDT=""
FOR
SET XDT=$ORDER(ADMINAR(XDT))
if XDT=""
QUIT
Begin DoDot:1
+24 SET NM=""
FOR
SET NM=$ORDER(ADMINAR(XDT,NM))
if NM=""
QUIT
Begin DoDot:2
+25 SET STR="{""instrumentName"":"""_NM_""", ""suicideRisk"":"""_ADMINAR(XDT,NM)_""" },"
+26 DO SETRES(STR)
SET HIT=1
End DoDot:2
End DoDot:1
+27 IF HIT
SET STR=^TMP("YTQ-JSON",$JOB,CNT,0)
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-1)
SET ^TMP("YTQ-JSON",$JOB,CNT,0)=STR
+28 DO SETRES("]}")
+29 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+30 QUIT
GETALST(ARGS,RESULTS) ; GET admins for Pat+Inst
+1 NEW TST,I,ADM,TEST,DFN,SRISK
+2 NEW ADMINDT,ADMINID,CMPL,CNT,HIT,G,N,STR
+3 NEW XDT,SAVEDT,SRC,ORD,RVW,INSTIEN
+4 SET ADM=""
SET N=0
+5 KILL ^TMP("YTQ-JSON",$JOB)
SET CNT=0
+6 SET HIT=""
+7 SET DFN=+$GET(ARGS("dfn"))
SET TEST=$GET(ARGS("instrumentName"))
+8 IF DFN'?1N.NP
DO SETERROR^YTQRUTL(404,"Bad Patient ID: "_DFN)
QUIT
+9 IF '$DATA(^DPT(DFN,0))
DO SETERROR^YTQRUTL(404,"Patient Not Found: "_DFN)
QUIT
+10 SET INSTIEN=$ORDER(^YTT(601.71,"B",TEST,0))
IF +INSTIEN=0
DO SETERROR^YTQRUTL(404,"Instrument Not Found: "_TEST)
QUIT
+11 DO SETRES("{""instruments"":[")
+12 SET XDT=""
+13 ;Only for IMHOA to find incomplete admins as well
IF TEST="IMHOA"
Begin DoDot:1
+14 SET ADM=0
FOR
SET ADM=$ORDER(^YTT(601.84,"C",DFN,ADM))
if ADM=""
QUIT
Begin DoDot:2
+15 SET G=$GET(^YTT(601.84,ADM,0))
+16 IF G=""
QUIT
+17 SET CMPL=$PIECE(G,U,9)
if CMPL="Y"
QUIT
+18 SET STR=""
+19 SET TST=$PIECE(G,U,3)
SET ORD=$PIECE(G,U,6)
SET RVW=$PIECE(G,U,17)
+20 SET SRC=$PIECE(G,U,13)
if SRC'=""
SET SRC=$PIECE($GET(^YTT(601.844,SRC,0)),U)
+21 SET ADMINID=$PIECE(G,U,1)
SET ADMINDT=$PIECE($PIECE(G,U,4),":",1,2)
+22 SET SAVEDT=$PIECE($PIECE(G,U,5),":",1,2)
+23 SET SRISK=$PIECE(G,U,14)
IF SRISK=""
SET SRISK=0
+24 SET STR="{""adminId"":"""_ADMINID_""", ""instrumentName"":"""_TEST_""" , ""instrumentIen"":"""_INSTIEN_""" , ""administrationDate"":"""_$PIECE($$FMTE^XLFDT(ADMINDT),":",1,2)
+25 SET STR=STR_""" , ""saveDate"":"""_$PIECE($$FMTE^XLFDT(SAVEDT),":",1,2)_""" , ""suicideRisk"":"""_SRISK_""", ""entrySource"":"""_SRC
+26 SET STR=STR_""" , ""orderedBy"":"""_ORD_""" , ""reviewed"":"""_RVW_""" , ""isComplete"":"""_CMPL_""" },"
+27 DO SETRES(STR)
SET HIT=1
End DoDot:2
End DoDot:1
+28 ;Get list of instr IENs
IF TEST'="IMHOA"
FOR
SET XDT=$ORDER(^PXRMINDX(601.84,"PI",DFN,INSTIEN,XDT),-1)
if XDT=""
QUIT
Begin DoDot:1
+29 SET ADM=0
FOR
SET ADM=$ORDER(^PXRMINDX(601.84,"PI",DFN,INSTIEN,XDT,ADM))
if ADM=""
QUIT
Begin DoDot:2
+30 SET G=$GET(^YTT(601.84,ADM,0))
+31 IF G=""
QUIT
+32 SET CMPL=$PIECE(G,U,9)
if CMPL'="Y"
QUIT
+33 SET STR=""
+34 SET TST=$PIECE(G,U,3)
SET ORD=$PIECE(G,U,6)
SET RVW=$PIECE(G,U,17)
+35 SET SRC=$PIECE(G,U,13)
if SRC'=""
SET SRC=$PIECE($GET(^YTT(601.844,SRC,0)),U)
+36 SET ADMINID=$PIECE(G,U,1)
SET ADMINDT=$PIECE($PIECE(G,U,4),":",1,2)
+37 SET SAVEDT=$PIECE($PIECE(G,U,5),":",1,2)
+38 SET SRISK=$PIECE(G,U,14)
IF SRISK=""
SET SRISK=0
+39 SET STR="{""adminId"":"""_ADMINID_""", ""instrumentName"":"""_TEST_""" , ""instrumentIen"":"""_INSTIEN_""" , ""administrationDate"":"""_$PIECE($$FMTE^XLFDT(ADMINDT),":",1,2)
+40 SET STR=STR_""" , ""saveDate"":"""_$PIECE($$FMTE^XLFDT(SAVEDT),":",1,2)_""" , ""suicideRisk"":"""_SRISK_""", ""entrySource"":"""_SRC
+41 SET STR=STR_""" , ""orderedBy"":"""_ORD_""" , ""reviewed"":"""_RVW_""" , ""isComplete"":"""_CMPL_""" },"
+42 DO SETRES(STR)
SET HIT=1
End DoDot:2
End DoDot:1
+43 IF HIT
SET STR=^TMP("YTQ-JSON",$JOB,CNT,0)
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-1)
SET ^TMP("YTQ-JSON",$JOB,CNT,0)=STR
+44 DO SETRES("]}")
+45 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+46 QUIT
SETRES(STR) ;
+1 SET CNT=CNT+1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)=STR
+2 QUIT
GETAD(ARGS,RESULTS) ; GET properties for a single admin
+1 NEW ADMIN,G,TST,TEST,ORD,RVW,SRC,ADMINID,ADMINDT,SAVEDT,SRISK
+2 SET ADMIN=+$GET(ARGS("adminId"))
+3 IF ADMIN=0
DO SETERROR^YTQRUTL(404,"Administration not sent.")
QUIT
+4 IF '$DATA(^YTT(601.84,ADMIN))
DO SETERROR^YTQRUTL(404,"Administration not found.")
QUIT
+5 SET G=$GET(^YTT(601.84,ADMIN,0))
+6 IF G=""
QUIT
+7 SET CMPL=$PIECE(G,U,9)
if CMPL'="Y"
QUIT
+8 SET STR=""
+9 SET TST=$PIECE(G,U,3)
SET ORD=$PIECE(G,U,6)
SET RVW=$PIECE(G,U,17)
+10 SET TEST=$PIECE($GET(^YTT(601.71,TST,0)),U)
+11 SET SRC=$PIECE(G,U,13)
if SRC'=""
SET SRC=$PIECE($GET(^YTT(601.844,SRC,0)),U)
+12 SET ADMINID=$PIECE(G,U,1)
SET ADMINDT=$PIECE($PIECE(G,U,4),":",1,2)
+13 SET SAVEDT=$PIECE($PIECE(G,U,5),":",1,2)
+14 SET SRISK=$PIECE(G,U,14)
IF SRISK=""
SET SRISK=0
+15 SET RESULTS("adminId")=ADMINID
+16 SET RESULTS("instrumentName")=TEST
+17 SET RESULTS("instrumentIen")=TST
+18 SET RESULTS("administrationDate")=$PIECE($$FMTE^XLFDT(ADMINDT),":",1,2)
+19 SET RESULTS("saveDate")=$PIECE($$FMTE^XLFDT(SAVEDT),":",1,2)
+20 SET RESULTS("suicideRisk")=SRISK
+21 SET RESULTS("entrySource")=SRC
+22 SET RESULTS("orderedBy")=ORD
+23 SET RESULTS("reviewed")=RVW
+24 QUIT
