YTQRQAD4 ;ISP/MJB - RESTful Calls to handle MHA lists ; 1/25/2017
;;5.01;MENTAL HEALTH;**158,178,182,181,187,199,202,204,221,249**;Dec 30, 1994;Build 30
;
; Reference to PXRMINDX in ICR #4290
; Reference to ^SC in ICR 10040
;
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
S NM="",N=0
K ^TMP("YTQ-JSON",$J) S CNT=0
D SETRES("{""instruments"":[")
S HIT=""
S DFN=+$G(ARGS("dfn"))
D UPDTSRFL ; 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) I CMPL="Y" D
..S ADMINDT=$P(G,U,4) Q:ADMINDT=""
..S ADMINAR(-ADMINDT,NM)=""
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=""
..S G=$G(^YTT(601.84,NM,0))
..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)
..I $P($G(^YTT(601.71,TST,2)),U,2)="C" QUIT
..S CMPL=$P(G,U,9) I CMPL="Y" D
...S NAME=$P($G(^YTT(601.71,TST,0)),U,1)
...S ADMINID=$P(G,U,1),ADMINDT=$P($P(G,U,4),":",1,2),PAT=$P(G,U,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"":"""_NAME_""" , ""instrumentIen"":"""_TST_""" , ""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_""" },"
..I STR]"" S HIT=1 D SETRES(STR)
I $D(ERRLST) D Q
. S (ERRSTR,NM)="" F S NM=$O(ERRLST(NM)) Q:NM="" D
.. S ERRSTR=ERRSTR_NM_", "
. S ERRSTR=$E(ERRSTR,1,$L(ERRSTR)-2)
. D SETERROR^YTQRUTL(404,"Instrument not found: "_ERRSTR)
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
;
GETLOCS(ARGS,RESULTS) ; get list of hosp loc
; C=Clinics, Z=Other, $$ACTLOC
; .Y=return, ORFROM=text to $O from, DIR=$O dir.
N I,IEN,CNT,LCNT,STR,LOC,HIT,DIR,ORFROM
N ROOT,LROOT
N STRT,EXCT
S HIT=0,CNT=0,DIR=1,ORFROM=""
S ROOT=$$UP^XLFSTR($G(ARGS("locmatch"))),LROOT=$L(ROOT)
D SETRES("{""locations"":[")
;Exact match
I $D(^SC("B",ROOT)) D
. S IEN="" F S IEN=$O(^SC("B",ROOT,IEN)) Q:'IEN D
..Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
..S STR="{""locId"": """_IEN_""", ""locName"": """_ROOT_"""},",HIT=IEN
..D SETRES(STR)
S ORFROM=$S(+ROOT=ROOT:ROOT_" ",1:ROOT)
S I=0,LCNT=99999 ;Return all locs for now
F Q:I'<LCNT S ORFROM=$O(^SC("B",ORFROM),DIR) Q:ORFROM="" Q:$E(ORFROM,1,LROOT)'=ROOT D ; IA# 10040.
.S IEN="" F S IEN=$O(^SC("B",ORFROM,IEN),DIR) Q:'IEN D
..Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
..S STR="{""locId"": """_IEN_""", ""locName"": """_ORFROM_"""},",HIT=IEN
..D SETRES(STR)
I HIT S STR=^TMP("YTQ-JSON",$J,CNT,0),STR=$E(STR,1,$L(STR)-1),^TMP("YTQ-JSON",$J,CNT,0)=STR ;Remove last ","
I HIT=0 D SETRES("{}")
D SETRES("]}")
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
;
GETLNAM(ARGS,RESULTS) ;Hosp Loc name
;
N I,IEN,LNAM,LOCNAM
S IEN=$G(ARGS("locId"))
I '$D(^SC(IEN)) D SETERROR^YTQRUTL(404,"Bad Location ID: "_IEN) QUIT
S LOCNAM=$P($G(^SC(IEN,0)),U,1)
S RESULTS("locId")=IEN
S RESULTS("locationName")=LOCNAM
Q
ACTLOC(LOC) ; TRUE if active
N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; OOS
S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; OOS
S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inact dte
I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk react dte
Q 1 ; active
;
GETCATA(DOCNAME,RESULTS) ; set ^TMP with doc named and cat
N CNT,HIT,NMB,NAME,IENI,IENC,CATN,XSTR,STAFF,OP,ALWN,DARR
K ^TMP("YTQ-JSON",$J)
S CNT=0,NMB="",NAME="",HIT=""
D SETRES("{""Instruments"":[")
S (IENI,NAME)=""
F S NAME=$O(^YTT(601.71,"B",NAME)) Q:NAME="" D
. S HIT=1
. S IENI="" S IENI=$O(^YTT(601.71,"B",NAME,IENI))
. S OP=$P($G(^YTT(601.71,IENI,2)),"^",2)
. I OP'="Y" Q
. I $E(NAME,1,7)="CAT-CAD" Q ;only used for interview
. I $$GET^XPAR("ALL","YSCAT DISABLED",1,"Q") Q:$E(NAME,1,4)="CAT-" Q:$E(NAME,1,4)="CAD-"
. S STAFF=$P($G(^YTT(601.71,IENI,9)),U,4)
. S STAFF=$S(STAFF="Y":"true",1:"false")
. S ALWN=$$ALWN2^YTQRQAD3(IENI) ;ALLOWNOTE function call
. S STR="{""instrumentName"":"""_NAME_""", ""staffOnly"":"""_STAFF_""" , ""allowNote"":"""_ALWN_""" ,"
. D SETRES(STR)
. D GETDES(NAME,.DARR)
. I $D(DARR) D
.. N DI S DI="" F S DI=$O(DARR(DI)) Q:DI="" D
... D SETRES(DARR(DI))
. S STR="""instrumentCategory"": ["
. S IENC=""
. I '$D(^YTT(601.71,IENI,10,"B")) D
.. S CATN=""
.. S XSTR="{""categoryName"":"""_CATN_"""}"
.. D SETRES(STR)
. I $D(^YTT(601.71,IENI,10,"B")) D
.. F S IENC=$O(^YTT(601.71,IENI,10,"B",IENC)) Q:'IENC D
... S CATN=""
... S CATN=^YTT(601.97,IENC,0)
... S XSTR="{""categoryName"":"""_CATN_"""},"
... S STR=STR_XSTR
.. S STR=$E(STR,1,$L(STR)-1)
.. D SETRES(STR)
. D SETRES("]},") ;Close
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
GETDES(NAME,DARR) ;Get Inst Desc
N DARG,YSDOUT,YSDARR,YSER,NDX,STR
M YSDARR=DARR
S DARG("instrumentName")=NAME
D GINSTD^YTQRQAD(.DARG,.YSDOUT)
D ENCODE^XLFJSON("YSDOUT","YSDARR","YSER")
I $D(YSER) K YSDARR Q
M DARR=YSDARR
S NDX=$O(DARR("")) S DARR(NDX)=$E(DARR(NDX),2,$L(DARR(NDX))) ;Strip leading {
S NDX=$O(DARR(""),-1) S DARR(NDX)=$E(DARR(NDX),1,$L(DARR(NDX))-1)_", "
Q
;
GETINTRP(ARGS,RESULTS) ;Get Interp Desc
N NAME,IEN,IARR,I,ERR,YSARR,DARR,ICNT,CRLF,OP,LN
N IEN,IARR,I,ERR,CRLF,CRL,OP,LN,STR,INTERP
K ^TMP("YTQ-JSON",$J)
S ICNT=0,CRLF="\n",CRL=$L(CRLF)
S LN=1,^TMP("YTQ-JSON",$J,LN,0)="{""Instruments"":["
S NAME="" F S NAME=$O(^YTT(601.71,"B",NAME)) Q:NAME="" D
. S IEN=$O(^YTT(601.71,"B",NAME,""))
. S OP=$P($G(^YTT(601.71,IEN,2)),U,2) Q:OP'="Y"
. K IARR D GET1^DIQ(601.71,IEN_",",110,"","IARR","ERR")
. Q:'$D(IARR)
. S INTERP=""
. S I=0 F S I=$O(IARR(I)) Q:I="" D
.. S INTERP=INTERP_IARR(I)_CRLF
. S INTERP=$E(INTERP,1,$L(INTERP)-CRL)
. S LN=LN+1,^TMP("YTQ-JSON",$J,LN,0)="{""instrumentId"":"_IEN_",""name"":"""_NAME_""",""interpText"":"""_INTERP_"""},"
S STR=^TMP("YTQ-JSON",$J,LN,0),STR=$E(STR,1,$L(STR)-1),^TMP("YTQ-JSON",$J,LN,0)=STR
S LN=LN+1,^TMP("YTQ-JSON",$J,LN,0)="]}"
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
;
ASMTLST(ARGS,RESULTS) ; get assgn by patid
N ASMT,ORDBY,I,DATA,ENTRY,PROG,ASGNDT,IN
N ADMINID,YSIENS,YSDATA,N,ASMTID,NOD,LSTDG
N ASTR,PROG,NWA,IADM
N MHADLST,IHIT,PATLST,DTGIVE,ADMLST
N LSTINST,MHCMPLT,MHTST,APPSRC
N HASINST,HASPROG,PNOT
S NM="",N=0
S ASMT="",ORDBY=""
K ^TMP("YTQ-JSON",$J) S CNT=0
S DFN=+$G(ARGS("dfn"))
D UPDTSRFL ; update Suicide Risk Flg
D ASMTIDA(DFN,.LSTINST) ;Lst MH ADMIN
D INCMPLT(DFN,DUZ,.INCMPL) ;Get list partially complete
D SETRES("{""patientAssignments"":[")
S ORDBY=0 F S ORDBY=$O(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY)) Q:'ORDBY D
.S ASMT=0 F S ASMT=$O(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,ASMT)) Q:'ASMT D
..Q:'$D(^XTMP("YTQASMT-SET-"_ASMT))
..S NOD="YTQASMT-SET-"_ASMT
..S ENTRY=$G(^XTMP(NOD,1,"entryMode"))
..S DTGIVE=$G(^XTMP(NOD,1,"date"))
..S IN=0 F S IN=$O(^XTMP(NOD,1,"instruments",IN)) Q:+IN=0 D
...S ADMINID=+$G(^XTMP(NOD,1,"instruments",IN,"adminId"))
...Q:ADMINID=0
...S MHCMPLT(ADMINID)=$$GET1^DIQ(601.84,ADMINID_",",8,"I")
...S LSTDG=$G(MHADLST(ENTRY,ADMINID))
...I $$FMDIFF^XLFDT(DTGIVE,LSTDG,2)>0 S MHADLST(ENTRY,ADMINID)=DTGIVE,ADMLST(ADMINID)=ASMT Q
S HIT=""
F S ORDBY=$O(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY)) Q:'ORDBY D
.F S ASMT=$O(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,ASMT)) Q:'ASMT D
..Q:'$D(^XTMP("YTQASMT-SET-"_ASMT))
..S NOD="YTQASMT-SET-"_ASMT
..S ENTRY=$G(^XTMP(NOD,1,"entryMode"))
..S APPSRC=$G(^XTMP(NOD,1,"appSrc"))
..I ENTRY="patient" D Q
... S (IHIT,I)=0 F S I=$O(^XTMP(NOD,1,"instruments",I)) Q:+I=0 D
.... S ADMINID=+$G(^XTMP(NOD,1,"instruments",I,"adminId")) Q:$D(PATLST(ADMINID))!(ADMINID=0)
.... S IHIT=1,PATLST(ADMINID)=ENTRY_U_$G(^XTMP(NOD,1,"date"))
... ;Q:IHIT=0
... S HIT=1 D SETASGN(ASMT) Q ;Always include Patient Assignment for possible Staff completion
..S ASGNDT=$P(^XTMP(NOD,1,"date"),".")
..S HASINST=$D(^XTMP(NOD,1,"instruments"))
..S HASPROG=$D(^XTMP(NOD,2,"PNOTE"))
..S (I,IHIT)=0 F S I=$O(^XTMP(NOD,1,"instruments",I)) Q:+I=0 D
...S ADMINID=+$G(^XTMP(NOD,1,"instruments",I,"adminId"))
...I ADMINID'=0 D
....Q:$D(MHADLST("patient",ADMINID)) ;If part of PE Assignment, PE trumps SE - Legacy MHA flow.
....I $G(MHCMPLT(ADMINID))="Y" D Q
.....;S MHTST=^XTMP(NOD,1,"instruments",I,"name")
.....;D RMVTEST^YTQRQAD1(ASMT,MHTST,"","Y")
....I $G(ADMLST(ADMINID))=ASMT S IHIT=1 K INCMPL(ADMINID) ;Assign has a MH ADMIN
..I (HASINST=0),(HASPROG>0) S PNOT=$$FILPNOT^YTQRQAD8(ASMT) Q ;No insts but Aggreg Prog note
..I APPSRC="mhaweb",(IHIT=0),(HASINST>0) D SETASGN(ASMT) Q ;If an MHA Assignment, always show
..I IHIT=1 S HIT=1 D SETASGN(ASMT)
; Handle any remaining incomplete MH ADMINISTRATIONS
I $D(INCMPL) S IADM="" F S IADM=$O(INCMPL(IADM)) Q:IADM="" D
. Q:$D(MHADLST("patient",IADM))
. S ASTR=INCMPL(IADM)
. S PROG=$$PROGRESS^YTQRQAD1(IADM,$P(ASTR,U,4))
. K DATA
. S DATA("adminDate")=$P($P(ASTR,U,2),"@")
. S DATA("date")=$P(ASTR,U,3)
. S DATA("entryMode")="staff"
. S DATA("catInfo")="null"
. S DATA("interview")=$P(ASTR,U,9)
. S DATA("location")=$P(ASTR,U,8)
. S DATA("orderedBy")=DUZ
. ;S DATA("appSrc")="mhaweb"
. S DATA("patient","dfn")=DFN
. I $P(ASTR,U,7)]"" S DATA("consult")=$P(ASTR,U,7)
. S DATA("instruments",1,"adminId")=IADM
. S DATA("instruments",1,"complete")="false"
. S DATA("instruments",1,"name")=$P(ASTR,U,5)
. S DATA("instruments",1,"progress")=+PROG
. S NWA=$$NEWASMT^YTQRQAD1(.ARGS,.DATA),NWA=$P(NWA,"/",$L(NWA,"/"))
. I +NWA D SETASGN(NWA) S HIT=1
S STR=^TMP("YTQ-JSON",$J,CNT,0) I $E(STR,$L(STR))="," S STR=$E(STR,1,$L(STR)-1),^TMP("YTQ-JSON",$J,CNT,0)=STR ;Remove last trailing ","
D SETRES("]}")
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
SETASGN(ASMT) ;Set up the Assign JSON
N DATA,ENTRY,ASSGNDT,CATHIT,STR,NAME,TSTIEN,CMPL,PROG,EXPDT,XSTR,XADMIN
N LSTADMIN,LSTDT,STAFF
S ASSGNDT=$P(^XTMP("YTQASMT-SET-"_ASMT,0),U,2) ;Add Assign dt
S ENTRY=$G(^XTMP("YTQASMT-SET-"_ASMT,1,"entryMode"))
S STR="{""assignmentId"":"""_ASMT_""" , ""entryMode"":"""_ENTRY_""",""assignDt"":"""_$P($$FMTE^XLFDT($P(ASSGNDT,".")),":",1,2)_""", ""instruments"": ["
S I="",CATHIT=0 F S I=$O(^XTMP("YTQASMT-SET-"_ASMT,1,"instruments",I)) Q:'I D
.K DATA
.M DATA=^XTMP("YTQASMT-SET-"_ASMT,1,"instruments",I)
.S NAME=$G(DATA("name"))
.S TSTIEN=$G(DATA("id"))
.S CMPL=$G(DATA("complete"))
.S XADMIN=$G(DATA("adminId"))
.I XADMIN,'$D(^YTT(601.84,XADMIN)) D RMVTEST^YTQRQAD1(ASMT,NAME) Q
.I XADMIN,'$$CHKADM(XADMIN,NAME,DFN) D RMVTEST^YTQRQAD1(ASMT,NAME) Q ;MH ADMIN exists but was reused
.S PROG=$$PROGRESS^YTQRQAD1(XADMIN,TSTIEN,ASMT)
.I PROG="" S PROG=0
.S EXPDT=$P(^XTMP("YTQASMT-SET-"_ASMT,0),U) ; Add Expiration dt
.S (LSTADMIN,LSTDT)="",STAFF="false" ;LSTINST set up from call to ASMTIDA2
.S LSTDT=$O(LSTINST(TSTIEN,""),-1) I LSTDT'="" S LSTADMIN=$O(LSTINST(TSTIEN,LSTDT,""),-1),STAFF=LSTINST(TSTIEN,LSTDT,LSTADMIN)
.S XSTR="{""instrumentName"":"""_NAME_""",""lastDone"":"""_$P($$FMTE^XLFDT($P(LSTDT,".")),":",1,2)_""",""adminId"":"""_XADMIN_""",""instrumentComplete"":"""_CMPL_""",""staffOnly"":"_STAFF
.S XSTR=XSTR_", ""progress"": """_PROG_""",""expDt"":"""_$P($$FMTE^XLFDT($P(EXPDT,".")),":",1,2)_"""},"
.S STR=STR_XSTR,CATHIT=1
I '$D(^XTMP("YTQASMT-SET-"_ASMT)) Q ;Assign deleted if RMVTEST
I $D(^XTMP("YTQASMT-SET-"_ASMT,1,"instruments")) S HIT=1
D SETRES(STR)
I CATHIT S STR=^TMP("YTQ-JSON",$J,CNT,0),STR=$E(STR,1,$L(STR)-1),^TMP("YTQ-JSON",$J,CNT,0)=STR
D SETRES("]},")
Q
INCMPLT(DFN,ORDBY,INCMPL) ; add list of incompl insts for DFN/ORDBY
; expects RSP,YSIDX,PTADMIN
Q:'ORDBY Q:'DFN
N I,X,YS,YSDATA,YSNOW,YSDOW,OFFSET,YSDTSAV,YSRSTRT,YSDG,YSINAM,YSADMIN,YSORD,YSCONS,PID,PTNAM,YSARR
N YSIN,YSINIEN,YSINTTL,YSLOC,YSINTRV,YSSRC
N VA,VADM,VAERR
D DEM^VADPT I $G(VAERR) D SETERROR^YTQRUTL(400,"Missing Pt Info") Q
S PID=VA("BID"),PTNAM=VADM(1)
S YSNOW=$$NOW^XLFDT
S YSDOW=$$DOW^XLFDT(YSNOW)
S OFFSET=$S(YSDOW=5:2,YSDOW=6:1,1:0)
S YS("DFN")=DFN,YS("COMPLETE")="N"
D ADMINS^YTQAPI5(.YSDATA,.YS)
S I=2 F S I=$O(YSDATA(I)) Q:'I D
. I $P(YSDATA(I),U,5)'=ORDBY QUIT ; not same orderedBy
. S YSDTSAV=$P(YSDATA(I),U,4) I 'YSDTSAV QUIT ; no date, bad entry
. S YSRSTRT=$P(YSDATA(I),U,15) S:'YSRSTRT YSRSTRT=2 ; account for weekends
. ; always restartable is -1, comparing full 24 hour periods so use seconds
. I (YSRSTRT'=-1),$$FMDIFF^XLFDT(YSNOW,YSDTSAV,2)>((YSRSTRT+OFFSET)*86400) Q
. S YSADMIN=$P(YSDATA(I),U) ; admin ien
. S YSINAM=$P(YSDATA(I),U,2) ; instrument name
. S YSINIEN=$P(YSDATA(I),U,11) ; instrument ien
. S YSDG=$P(YSDATA(I),U,3) ; date given
. S YSDG=$P($P($$FMTE^XLFDT(YSDG,5),":",1,2),".")
. S YSLOC=$P(YSDATA(I),U,14)
. S YSINTRV=$P(YSDATA(I),U,6)
. D GETS^DIQ(601.84,YSADMIN_",","2;15;17","IE","YSARR")
. S YSCONS=$G(YSARR(601.84,YSADMIN_",",17,"I"))
. S YSSRC=$G(YSARR(601.84,YSADMIN_",",15,"E")) Q:YSSRC="web" ;Incomplete MHA admins
. S INCMPL(YSADMIN)=YSADMIN_U_YSDG_U_YSDTSAV_U_YSINIEN_U_YSINAM_U_YSRSTRT_U_YSCONS_U_YSLOC_U_YSINTRV_U_YSSRC
Q
CHKADM(YSADMIN,YSNAM,YSDFN) ;Check Instrument Ad= what is in XTMP
N STAT,YSIENS,YSARR,YSERR
I $G(YSNAM)="" S STAT=0 Q STAT
I +$G(YSDFN)=0 S STAT=0 Q STAT
I +$G(YSADMIN)=0 S STAT=0 Q STAT
S STAT=1 ;OK
S YSIENS=YSADMIN_","
D GETS^DIQ(601.84,YSIENS,"1;2","EI","YSARR","YSERR")
I $D(YSERR) S STAT=0 Q STAT
I $G(YSARR(601.84,YSIENS,2,"E"))'=$G(YSNAM) S STAT=0
I $G(YSARR(601.84,YSIENS,1,"I"))'=YSDFN S STAT=0
Q STAT
;
ASMTIDA(DFN,LSTINST) ; get admins by DFN/TSTIEN
; Find last complete admin
N ADMINDT,ADMINID,CMPL,PAT,NM
K ARRAY
S NM="",N=0
I DFN'?1N.NP S YSDATA(1)="[ERROR]",YSDATA(2)="bad DFN" Q
I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt" Q
F S NM=$O(^YTT(601.84,"C",DFN,NM)) Q:'NM D
.S G=$G(^YTT(601.84,NM,0))
.I G="" S YSDATA(1)="[ERROR]",YSDATA(2)=YSIENS_" bad ien in 84"
.S PAT=$P(G,U,2) Q:PAT'=DFN
.S TST=$P(G,U,3)
.S CMPL=$P(G,U,9) I CMPL="Y" D
..S NAME=$P($G(^YTT(601.71,TST,0)),U,1)
..S STAFF=$P($G(^YTT(601.71,TST,9)),U,4) S:STAFF="" STAFF="N"
..S STAFF=$S(STAFF="Y":"true",1:"false")
..S ADMINID=$P(G,U,1),ADMINDT=$P(G,U,4)
..S LSTINST(TST,ADMINDT,ADMINID)=STAFF
Q
;
UPDTSRFL ;
; Set index for 601.84 MH ADMINISTRATIONS
; X(1)=Patient X(2)=Instrument X(3)=Date Given
; ^PXRMINDX(601.84,"IP",X(2),X(1),X(3),DA)=""
; ^PXRMINDX(601.84,"PI",X(1),X(2),X(3),DA)=""
N INSTIEN,TEMP,SRCALL
S INSTIEN=""
F S INSTIEN=$O(^PXRMINDX(601.84,"PI",DFN,INSTIEN)) Q:INSTIEN="" D ;Get list of instr IENs
. S TEMP=$G(^YTT(601.71,INSTIEN,9))
. S TEMP(1)=$P(TEMP,U,5),TEMP(2)=$P(TEMP,U,6) ;Get Suicide Tag & routine
. I TEMP(1)'="",(TEMP(2)'="") D
. . S SRCALL="D "_TEMP(2)_U_TEMP(1)
. . X SRCALL
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRQAD4 15803 printed Nov 22, 2024@17:28:58 Page 2
YTQRQAD4 ;ISP/MJB - RESTful Calls to handle MHA lists ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**158,178,182,181,187,199,202,204,221,249**;Dec 30, 1994;Build 30
+2 ;
+3 ; Reference to PXRMINDX in ICR #4290
+4 ; Reference to ^SC in ICR 10040
+5 ;
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
+4 SET NM=""
SET N=0
+5 KILL ^TMP("YTQ-JSON",$JOB)
SET CNT=0
+6 DO SETRES("{""instruments"":[")
+7 SET HIT=""
+8 SET DFN=+$GET(ARGS("dfn"))
+9 ; update Suicide Risk Flag
DO UPDTSRFL
+10 IF DFN'?1N.NP
DO SETERROR^YTQRUTL(404,"Bad Patient ID: "_DFN)
QUIT
+11 IF '$DATA(^DPT(DFN,0))
DO SETERROR^YTQRUTL(404,"Patient Not Found: "_DFN)
QUIT
+12 FOR
SET NM=$ORDER(^YTT(601.84,"C",DFN,NM))
if 'NM
QUIT
Begin DoDot:1
+13 SET G=$GET(^YTT(601.84,NM,0))
+14 ;-->out
IF G=""
SET ERRLST(NM)=""
QUIT
+15 SET CMPL=$PIECE(G,U,9)
IF CMPL="Y"
Begin DoDot:2
+16 SET ADMINDT=$PIECE(G,U,4)
if ADMINDT=""
QUIT
+17 SET ADMINAR(-ADMINDT,NM)=""
End DoDot:2
End DoDot:1
+18 SET XDT=""
FOR
SET XDT=$ORDER(ADMINAR(XDT))
if XDT=""
QUIT
Begin DoDot:1
+19 SET NM=""
FOR
SET NM=$ORDER(ADMINAR(XDT,NM))
if NM=""
QUIT
Begin DoDot:2
+20 SET STR=""
+21 SET G=$GET(^YTT(601.84,NM,0))
+22 SET TST=$PIECE(G,U,3)
SET ORD=$PIECE(G,U,6)
SET RVW=$PIECE(G,U,17)
+23 SET SRC=$PIECE(G,U,13)
if SRC'=""
SET SRC=$PIECE($GET(^YTT(601.844,SRC,0)),U)
+24 IF $PIECE($GET(^YTT(601.71,TST,2)),U,2)="C"
QUIT
+25 SET CMPL=$PIECE(G,U,9)
IF CMPL="Y"
Begin DoDot:3
+26 SET NAME=$PIECE($GET(^YTT(601.71,TST,0)),U,1)
+27 SET ADMINID=$PIECE(G,U,1)
SET ADMINDT=$PIECE($PIECE(G,U,4),":",1,2)
SET PAT=$PIECE(G,U,2)
+28 SET SAVEDT=$PIECE($PIECE(G,U,5),":",1,2)
+29 SET SRISK=$PIECE(G,U,14)
IF SRISK=""
SET SRISK=0
+30 SET STR="{""adminId"":"""_ADMINID_""", ""instrumentName"":"""_NAME_""" , ""instrumentIen"":"""_TST_""" , ""administrationDate"":"""_$PIECE($$FMTE^XLFDT(ADMINDT),":",1,2)
+31 SET STR=STR_""" , ""saveDate"":"""_$PIECE($$FMTE^XLFDT(SAVEDT),":",1,2)_""" , ""suicideRisk"":"""_SRISK_""", ""entrySource"":"""_SRC
+32 SET STR=STR_""" , ""orderedBy"":"""_ORD_""" , ""reviewed"":"""_RVW_""" },"
End DoDot:3
+33 IF STR]""
SET HIT=1
DO SETRES(STR)
End DoDot:2
End DoDot:1
+34 IF $DATA(ERRLST)
Begin DoDot:1
+35 SET (ERRSTR,NM)=""
FOR
SET NM=$ORDER(ERRLST(NM))
if NM=""
QUIT
Begin DoDot:2
+36 SET ERRSTR=ERRSTR_NM_", "
End DoDot:2
+37 SET ERRSTR=$EXTRACT(ERRSTR,1,$LENGTH(ERRSTR)-2)
+38 DO SETERROR^YTQRUTL(404,"Instrument not found: "_ERRSTR)
End DoDot:1
QUIT
+39 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
+40 DO SETRES("]}")
+41 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+42 QUIT
+43 ;
SETRES(STR) ;
+1 SET CNT=CNT+1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)=STR
+2 QUIT
+3 ;
GETLOCS(ARGS,RESULTS) ; get list of hosp loc
+1 ; C=Clinics, Z=Other, $$ACTLOC
+2 ; .Y=return, ORFROM=text to $O from, DIR=$O dir.
+3 NEW I,IEN,CNT,LCNT,STR,LOC,HIT,DIR,ORFROM
+4 NEW ROOT,LROOT
+5 NEW STRT,EXCT
+6 SET HIT=0
SET CNT=0
SET DIR=1
SET ORFROM=""
+7 SET ROOT=$$UP^XLFSTR($GET(ARGS("locmatch")))
SET LROOT=$LENGTH(ROOT)
+8 DO SETRES("{""locations"":[")
+9 ;Exact match
+10 IF $DATA(^SC("B",ROOT))
Begin DoDot:1
+11 SET IEN=""
FOR
SET IEN=$ORDER(^SC("B",ROOT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+12 if ("CW"'[$PIECE($GET(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
QUIT
+13 SET STR="{""locId"": """_IEN_""", ""locName"": """_ROOT_"""},"
SET HIT=IEN
+14 DO SETRES(STR)
End DoDot:2
End DoDot:1
+15 SET ORFROM=$SELECT(+ROOT=ROOT:ROOT_" ",1:ROOT)
+16 ;Return all locs for now
SET I=0
SET LCNT=99999
+17 ; IA# 10040.
FOR
if I'<LCNT
QUIT
SET ORFROM=$ORDER(^SC("B",ORFROM),DIR)
if ORFROM=""
QUIT
if $EXTRACT(ORFROM,1,LROOT)'=ROOT
QUIT
Begin DoDot:1
+18 SET IEN=""
FOR
SET IEN=$ORDER(^SC("B",ORFROM,IEN),DIR)
if 'IEN
QUIT
Begin DoDot:2
+19 if ("CW"'[$PIECE($GET(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
QUIT
+20 SET STR="{""locId"": """_IEN_""", ""locName"": """_ORFROM_"""},"
SET HIT=IEN
+21 DO SETRES(STR)
End DoDot:2
End DoDot:1
+22 ;Remove last ","
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
+23 IF HIT=0
DO SETRES("{}")
+24 DO SETRES("]}")
+25 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+26 QUIT
+27 ;
GETLNAM(ARGS,RESULTS) ;Hosp Loc name
+1 ;
+2 NEW I,IEN,LNAM,LOCNAM
+3 SET IEN=$GET(ARGS("locId"))
+4 IF '$DATA(^SC(IEN))
DO SETERROR^YTQRUTL(404,"Bad Location ID: "_IEN)
QUIT
+5 SET LOCNAM=$PIECE($GET(^SC(IEN,0)),U,1)
+6 SET RESULTS("locId")=IEN
+7 SET RESULTS("locationName")=LOCNAM
+8 QUIT
ACTLOC(LOC) ; TRUE if active
+1 ; OOS
NEW D0,X
IF +$GET(^SC(LOC,"OOS"))
QUIT 0
+2 ; OOS
SET D0=+$GET(^SC(LOC,42))
IF D0
DO WIN^DGPMDDCF
QUIT 'X
+3 ; no inact dte
SET X=$GET(^SC(LOC,"I"))
IF +X=0
QUIT 1
+4 ; chk react dte
IF DT>$PIECE(X,U)&($PIECE(X,U,2)=""!(DT<$PIECE(X,U,2)))
QUIT 0
+5 ; active
QUIT 1
+6 ;
GETCATA(DOCNAME,RESULTS) ; set ^TMP with doc named and cat
+1 NEW CNT,HIT,NMB,NAME,IENI,IENC,CATN,XSTR,STAFF,OP,ALWN,DARR
+2 KILL ^TMP("YTQ-JSON",$JOB)
+3 SET CNT=0
SET NMB=""
SET NAME=""
SET HIT=""
+4 DO SETRES("{""Instruments"":[")
+5 SET (IENI,NAME)=""
+6 FOR
SET NAME=$ORDER(^YTT(601.71,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+7 SET HIT=1
+8 SET IENI=""
SET IENI=$ORDER(^YTT(601.71,"B",NAME,IENI))
+9 SET OP=$PIECE($GET(^YTT(601.71,IENI,2)),"^",2)
+10 IF OP'="Y"
QUIT
+11 ;only used for interview
IF $EXTRACT(NAME,1,7)="CAT-CAD"
QUIT
+12 IF $$GET^XPAR("ALL","YSCAT DISABLED",1,"Q")
if $EXTRACT(NAME,1,4)="CAT-"
QUIT
if $EXTRACT(NAME,1,4)="CAD-"
QUIT
+13 SET STAFF=$PIECE($GET(^YTT(601.71,IENI,9)),U,4)
+14 SET STAFF=$SELECT(STAFF="Y":"true",1:"false")
+15 ;ALLOWNOTE function call
SET ALWN=$$ALWN2^YTQRQAD3(IENI)
+16 SET STR="{""instrumentName"":"""_NAME_""", ""staffOnly"":"""_STAFF_""" , ""allowNote"":"""_ALWN_""" ,"
+17 DO SETRES(STR)
+18 DO GETDES(NAME,.DARR)
+19 IF $DATA(DARR)
Begin DoDot:2
+20 NEW DI
SET DI=""
FOR
SET DI=$ORDER(DARR(DI))
if DI=""
QUIT
Begin DoDot:3
+21 DO SETRES(DARR(DI))
End DoDot:3
End DoDot:2
+22 SET STR="""instrumentCategory"": ["
+23 SET IENC=""
+24 IF '$DATA(^YTT(601.71,IENI,10,"B"))
Begin DoDot:2
+25 SET CATN=""
+26 SET XSTR="{""categoryName"":"""_CATN_"""}"
+27 DO SETRES(STR)
End DoDot:2
+28 IF $DATA(^YTT(601.71,IENI,10,"B"))
Begin DoDot:2
+29 FOR
SET IENC=$ORDER(^YTT(601.71,IENI,10,"B",IENC))
if 'IENC
QUIT
Begin DoDot:3
+30 SET CATN=""
+31 SET CATN=^YTT(601.97,IENC,0)
+32 SET XSTR="{""categoryName"":"""_CATN_"""},"
+33 SET STR=STR_XSTR
End DoDot:3
+34 SET STR=$EXTRACT(STR,1,$LENGTH(STR)-1)
+35 DO SETRES(STR)
End DoDot:2
+36 ;Close
DO SETRES("]},")
End DoDot:1
+37 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
+38 DO SETRES("]}")
+39 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+40 QUIT
GETDES(NAME,DARR) ;Get Inst Desc
+1 NEW DARG,YSDOUT,YSDARR,YSER,NDX,STR
+2 MERGE YSDARR=DARR
+3 SET DARG("instrumentName")=NAME
+4 DO GINSTD^YTQRQAD(.DARG,.YSDOUT)
+5 DO ENCODE^XLFJSON("YSDOUT","YSDARR","YSER")
+6 IF $DATA(YSER)
KILL YSDARR
QUIT
+7 MERGE DARR=YSDARR
+8 ;Strip leading {
SET NDX=$ORDER(DARR(""))
SET DARR(NDX)=$EXTRACT(DARR(NDX),2,$LENGTH(DARR(NDX)))
+9 SET NDX=$ORDER(DARR(""),-1)
SET DARR(NDX)=$EXTRACT(DARR(NDX),1,$LENGTH(DARR(NDX))-1)_", "
+10 QUIT
+11 ;
GETINTRP(ARGS,RESULTS) ;Get Interp Desc
+1 NEW NAME,IEN,IARR,I,ERR,YSARR,DARR,ICNT,CRLF,OP,LN
+2 NEW IEN,IARR,I,ERR,CRLF,CRL,OP,LN,STR,INTERP
+3 KILL ^TMP("YTQ-JSON",$JOB)
+4 SET ICNT=0
SET CRLF="\n"
SET CRL=$LENGTH(CRLF)
+5 SET LN=1
SET ^TMP("YTQ-JSON",$JOB,LN,0)="{""Instruments"":["
+6 SET NAME=""
FOR
SET NAME=$ORDER(^YTT(601.71,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+7 SET IEN=$ORDER(^YTT(601.71,"B",NAME,""))
+8 SET OP=$PIECE($GET(^YTT(601.71,IEN,2)),U,2)
if OP'="Y"
QUIT
+9 KILL IARR
DO GET1^DIQ(601.71,IEN_",",110,"","IARR","ERR")
+10 if '$DATA(IARR)
QUIT
+11 SET INTERP=""
+12 SET I=0
FOR
SET I=$ORDER(IARR(I))
if I=""
QUIT
Begin DoDot:2
+13 SET INTERP=INTERP_IARR(I)_CRLF
End DoDot:2
+14 SET INTERP=$EXTRACT(INTERP,1,$LENGTH(INTERP)-CRL)
+15 SET LN=LN+1
SET ^TMP("YTQ-JSON",$JOB,LN,0)="{""instrumentId"":"_IEN_",""name"":"""_NAME_""",""interpText"":"""_INTERP_"""},"
End DoDot:1
+16 SET STR=^TMP("YTQ-JSON",$JOB,LN,0)
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-1)
SET ^TMP("YTQ-JSON",$JOB,LN,0)=STR
+17 SET LN=LN+1
SET ^TMP("YTQ-JSON",$JOB,LN,0)="]}"
+18 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+19 QUIT
+20 ;
ASMTLST(ARGS,RESULTS) ; get assgn by patid
+1 NEW ASMT,ORDBY,I,DATA,ENTRY,PROG,ASGNDT,IN
+2 NEW ADMINID,YSIENS,YSDATA,N,ASMTID,NOD,LSTDG
+3 NEW ASTR,PROG,NWA,IADM
+4 NEW MHADLST,IHIT,PATLST,DTGIVE,ADMLST
+5 NEW LSTINST,MHCMPLT,MHTST,APPSRC
+6 NEW HASINST,HASPROG,PNOT
+7 SET NM=""
SET N=0
+8 SET ASMT=""
SET ORDBY=""
+9 KILL ^TMP("YTQ-JSON",$JOB)
SET CNT=0
+10 SET DFN=+$GET(ARGS("dfn"))
+11 ; update Suicide Risk Flg
DO UPDTSRFL
+12 ;Lst MH ADMIN
DO ASMTIDA(DFN,.LSTINST)
+13 ;Get list partially complete
DO INCMPLT(DFN,DUZ,.INCMPL)
+14 DO SETRES("{""patientAssignments"":[")
+15 SET ORDBY=0
FOR
SET ORDBY=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY))
if 'ORDBY
QUIT
Begin DoDot:1
+16 SET ASMT=0
FOR
SET ASMT=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,ASMT))
if 'ASMT
QUIT
Begin DoDot:2
+17 if '$DATA(^XTMP("YTQASMT-SET-"_ASMT))
QUIT
+18 SET NOD="YTQASMT-SET-"_ASMT
+19 SET ENTRY=$GET(^XTMP(NOD,1,"entryMode"))
+20 SET DTGIVE=$GET(^XTMP(NOD,1,"date"))
+21 SET IN=0
FOR
SET IN=$ORDER(^XTMP(NOD,1,"instruments",IN))
if +IN=0
QUIT
Begin DoDot:3
+22 SET ADMINID=+$GET(^XTMP(NOD,1,"instruments",IN,"adminId"))
+23 if ADMINID=0
QUIT
+24 SET MHCMPLT(ADMINID)=$$GET1^DIQ(601.84,ADMINID_",",8,"I")
+25 SET LSTDG=$GET(MHADLST(ENTRY,ADMINID))
+26 IF $$FMDIFF^XLFDT(DTGIVE,LSTDG,2)>0
SET MHADLST(ENTRY,ADMINID)=DTGIVE
SET ADMLST(ADMINID)=ASMT
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+27 SET HIT=""
+28 FOR
SET ORDBY=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY))
if 'ORDBY
QUIT
Begin DoDot:1
+29 FOR
SET ASMT=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,ASMT))
if 'ASMT
QUIT
Begin DoDot:2
+30 if '$DATA(^XTMP("YTQASMT-SET-"_ASMT))
QUIT
+31 SET NOD="YTQASMT-SET-"_ASMT
+32 SET ENTRY=$GET(^XTMP(NOD,1,"entryMode"))
+33 SET APPSRC=$GET(^XTMP(NOD,1,"appSrc"))
+34 IF ENTRY="patient"
Begin DoDot:3
+35 SET (IHIT,I)=0
FOR
SET I=$ORDER(^XTMP(NOD,1,"instruments",I))
if +I=0
QUIT
Begin DoDot:4
+36 SET ADMINID=+$GET(^XTMP(NOD,1,"instruments",I,"adminId"))
if $DATA(PATLST(ADMINID))!(ADMINID=0)
QUIT
+37 SET IHIT=1
SET PATLST(ADMINID)=ENTRY_U_$GET(^XTMP(NOD,1,"date"))
End DoDot:4
+38 ;Q:IHIT=0
+39 ;Always include Patient Assignment for possible Staff completion
SET HIT=1
DO SETASGN(ASMT)
QUIT
End DoDot:3
QUIT
+40 SET ASGNDT=$PIECE(^XTMP(NOD,1,"date"),".")
+41 SET HASINST=$DATA(^XTMP(NOD,1,"instruments"))
+42 SET HASPROG=$DATA(^XTMP(NOD,2,"PNOTE"))
+43 SET (I,IHIT)=0
FOR
SET I=$ORDER(^XTMP(NOD,1,"instruments",I))
if +I=0
QUIT
Begin DoDot:3
+44 SET ADMINID=+$GET(^XTMP(NOD,1,"instruments",I,"adminId"))
+45 IF ADMINID'=0
Begin DoDot:4
+46 ;If part of PE Assignment, PE trumps SE - Legacy MHA flow.
if $DATA(MHADLST("patient",ADMINID))
QUIT
+47 IF $GET(MHCMPLT(ADMINID))="Y"
Begin DoDot:5
+48 ;S MHTST=^XTMP(NOD,1,"instruments",I,"name")
+49 ;D RMVTEST^YTQRQAD1(ASMT,MHTST,"","Y")
End DoDot:5
QUIT
+50 ;Assign has a MH ADMIN
IF $GET(ADMLST(ADMINID))=ASMT
SET IHIT=1
KILL INCMPL(ADMINID)
End DoDot:4
End DoDot:3
+51 ;No insts but Aggreg Prog note
IF (HASINST=0)
IF (HASPROG>0)
SET PNOT=$$FILPNOT^YTQRQAD8(ASMT)
QUIT
+52 ;If an MHA Assignment, always show
IF APPSRC="mhaweb"
IF (IHIT=0)
IF (HASINST>0)
DO SETASGN(ASMT)
QUIT
+53 IF IHIT=1
SET HIT=1
DO SETASGN(ASMT)
End DoDot:2
End DoDot:1
+54 ; Handle any remaining incomplete MH ADMINISTRATIONS
+55 IF $DATA(INCMPL)
SET IADM=""
FOR
SET IADM=$ORDER(INCMPL(IADM))
if IADM=""
QUIT
Begin DoDot:1
+56 if $DATA(MHADLST("patient",IADM))
QUIT
+57 SET ASTR=INCMPL(IADM)
+58 SET PROG=$$PROGRESS^YTQRQAD1(IADM,$PIECE(ASTR,U,4))
+59 KILL DATA
+60 SET DATA("adminDate")=$PIECE($PIECE(ASTR,U,2),"@")
+61 SET DATA("date")=$PIECE(ASTR,U,3)
+62 SET DATA("entryMode")="staff"
+63 SET DATA("catInfo")="null"
+64 SET DATA("interview")=$PIECE(ASTR,U,9)
+65 SET DATA("location")=$PIECE(ASTR,U,8)
+66 SET DATA("orderedBy")=DUZ
+67 ;S DATA("appSrc")="mhaweb"
+68 SET DATA("patient","dfn")=DFN
+69 IF $PIECE(ASTR,U,7)]""
SET DATA("consult")=$PIECE(ASTR,U,7)
+70 SET DATA("instruments",1,"adminId")=IADM
+71 SET DATA("instruments",1,"complete")="false"
+72 SET DATA("instruments",1,"name")=$PIECE(ASTR,U,5)
+73 SET DATA("instruments",1,"progress")=+PROG
+74 SET NWA=$$NEWASMT^YTQRQAD1(.ARGS,.DATA)
SET NWA=$PIECE(NWA,"/",$LENGTH(NWA,"/"))
+75 IF +NWA
DO SETASGN(NWA)
SET HIT=1
End DoDot:1
+76 ;Remove last trailing ","
SET STR=^TMP("YTQ-JSON",$JOB,CNT,0)
IF $EXTRACT(STR,$LENGTH(STR))=","
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-1)
SET ^TMP("YTQ-JSON",$JOB,CNT,0)=STR
+77 DO SETRES("]}")
+78 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+79 QUIT
SETASGN(ASMT) ;Set up the Assign JSON
+1 NEW DATA,ENTRY,ASSGNDT,CATHIT,STR,NAME,TSTIEN,CMPL,PROG,EXPDT,XSTR,XADMIN
+2 NEW LSTADMIN,LSTDT,STAFF
+3 ;Add Assign dt
SET ASSGNDT=$PIECE(^XTMP("YTQASMT-SET-"_ASMT,0),U,2)
+4 SET ENTRY=$GET(^XTMP("YTQASMT-SET-"_ASMT,1,"entryMode"))
+5 SET STR="{""assignmentId"":"""_ASMT_""" , ""entryMode"":"""_ENTRY_""",""assignDt"":"""_$PIECE($$FMTE^XLFDT($PIECE(ASSGNDT,".")),":",1,2)_""", ""instruments"": ["
+6 SET I=""
SET CATHIT=0
FOR
SET I=$ORDER(^XTMP("YTQASMT-SET-"_ASMT,1,"instruments",I))
if 'I
QUIT
Begin DoDot:1
+7 KILL DATA
+8 MERGE DATA=^XTMP("YTQASMT-SET-"_ASMT,1,"instruments",I)
+9 SET NAME=$GET(DATA("name"))
+10 SET TSTIEN=$GET(DATA("id"))
+11 SET CMPL=$GET(DATA("complete"))
+12 SET XADMIN=$GET(DATA("adminId"))
+13 IF XADMIN
IF '$DATA(^YTT(601.84,XADMIN))
DO RMVTEST^YTQRQAD1(ASMT,NAME)
QUIT
+14 ;MH ADMIN exists but was reused
IF XADMIN
IF '$$CHKADM(XADMIN,NAME,DFN)
DO RMVTEST^YTQRQAD1(ASMT,NAME)
QUIT
+15 SET PROG=$$PROGRESS^YTQRQAD1(XADMIN,TSTIEN,ASMT)
+16 IF PROG=""
SET PROG=0
+17 ; Add Expiration dt
SET EXPDT=$PIECE(^XTMP("YTQASMT-SET-"_ASMT,0),U)
+18 ;LSTINST set up from call to ASMTIDA2
SET (LSTADMIN,LSTDT)=""
SET STAFF="false"
+19 SET LSTDT=$ORDER(LSTINST(TSTIEN,""),-1)
IF LSTDT'=""
SET LSTADMIN=$ORDER(LSTINST(TSTIEN,LSTDT,""),-1)
SET STAFF=LSTINST(TSTIEN,LSTDT,LSTADMIN)
+20 SET XSTR="{""instrumentName"":"""_NAME_""",""lastDone"":"""_$PIECE($$FMTE^XLFDT($PIECE(LSTDT,".")),":",1,2)_""",""adminId"":"""_XADMIN_""",""instrumentComplete"":"""_CMPL_""",""staffOnly"":"_STAFF
+21 SET XSTR=XSTR_", ""progress"": """_PROG_""",""expDt"":"""_$PIECE($$FMTE^XLFDT($PIECE(EXPDT,".")),":",1,2)_"""},"
+22 SET STR=STR_XSTR
SET CATHIT=1
End DoDot:1
+23 ;Assign deleted if RMVTEST
IF '$DATA(^XTMP("YTQASMT-SET-"_ASMT))
QUIT
+24 IF $DATA(^XTMP("YTQASMT-SET-"_ASMT,1,"instruments"))
SET HIT=1
+25 DO SETRES(STR)
+26 IF CATHIT
SET STR=^TMP("YTQ-JSON",$JOB,CNT,0)
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-1)
SET ^TMP("YTQ-JSON",$JOB,CNT,0)=STR
+27 DO SETRES("]},")
+28 QUIT
INCMPLT(DFN,ORDBY,INCMPL) ; add list of incompl insts for DFN/ORDBY
+1 ; expects RSP,YSIDX,PTADMIN
+2 if 'ORDBY
QUIT
if 'DFN
QUIT
+3 NEW I,X,YS,YSDATA,YSNOW,YSDOW,OFFSET,YSDTSAV,YSRSTRT,YSDG,YSINAM,YSADMIN,YSORD,YSCONS,PID,PTNAM,YSARR
+4 NEW YSIN,YSINIEN,YSINTTL,YSLOC,YSINTRV,YSSRC
+5 NEW VA,VADM,VAERR
+6 DO DEM^VADPT
IF $GET(VAERR)
DO SETERROR^YTQRUTL(400,"Missing Pt Info")
QUIT
+7 SET PID=VA("BID")
SET PTNAM=VADM(1)
+8 SET YSNOW=$$NOW^XLFDT
+9 SET YSDOW=$$DOW^XLFDT(YSNOW)
+10 SET OFFSET=$SELECT(YSDOW=5:2,YSDOW=6:1,1:0)
+11 SET YS("DFN")=DFN
SET YS("COMPLETE")="N"
+12 DO ADMINS^YTQAPI5(.YSDATA,.YS)
+13 SET I=2
FOR
SET I=$ORDER(YSDATA(I))
if 'I
QUIT
Begin DoDot:1
+14 ; not same orderedBy
IF $PIECE(YSDATA(I),U,5)'=ORDBY
QUIT
+15 ; no date, bad entry
SET YSDTSAV=$PIECE(YSDATA(I),U,4)
IF 'YSDTSAV
QUIT
+16 ; account for weekends
SET YSRSTRT=$PIECE(YSDATA(I),U,15)
if 'YSRSTRT
SET YSRSTRT=2
+17 ; always restartable is -1, comparing full 24 hour periods so use seconds
+18 IF (YSRSTRT'=-1)
IF $$FMDIFF^XLFDT(YSNOW,YSDTSAV,2)>((YSRSTRT+OFFSET)*86400)
QUIT
+19 ; admin ien
SET YSADMIN=$PIECE(YSDATA(I),U)
+20 ; instrument name
SET YSINAM=$PIECE(YSDATA(I),U,2)
+21 ; instrument ien
SET YSINIEN=$PIECE(YSDATA(I),U,11)
+22 ; date given
SET YSDG=$PIECE(YSDATA(I),U,3)
+23 SET YSDG=$PIECE($PIECE($$FMTE^XLFDT(YSDG,5),":",1,2),".")
+24 SET YSLOC=$PIECE(YSDATA(I),U,14)
+25 SET YSINTRV=$PIECE(YSDATA(I),U,6)
+26 DO GETS^DIQ(601.84,YSADMIN_",","2;15;17","IE","YSARR")
+27 SET YSCONS=$GET(YSARR(601.84,YSADMIN_",",17,"I"))
+28 ;Incomplete MHA admins
SET YSSRC=$GET(YSARR(601.84,YSADMIN_",",15,"E"))
if YSSRC="web"
QUIT
+29 SET INCMPL(YSADMIN)=YSADMIN_U_YSDG_U_YSDTSAV_U_YSINIEN_U_YSINAM_U_YSRSTRT_U_YSCONS_U_YSLOC_U_YSINTRV_U_YSSRC
End DoDot:1
+30 QUIT
CHKADM(YSADMIN,YSNAM,YSDFN) ;Check Instrument Ad= what is in XTMP
+1 NEW STAT,YSIENS,YSARR,YSERR
+2 IF $GET(YSNAM)=""
SET STAT=0
QUIT STAT
+3 IF +$GET(YSDFN)=0
SET STAT=0
QUIT STAT
+4 IF +$GET(YSADMIN)=0
SET STAT=0
QUIT STAT
+5 ;OK
SET STAT=1
+6 SET YSIENS=YSADMIN_","
+7 DO GETS^DIQ(601.84,YSIENS,"1;2","EI","YSARR","YSERR")
+8 IF $DATA(YSERR)
SET STAT=0
QUIT STAT
+9 IF $GET(YSARR(601.84,YSIENS,2,"E"))'=$GET(YSNAM)
SET STAT=0
+10 IF $GET(YSARR(601.84,YSIENS,1,"I"))'=YSDFN
SET STAT=0
+11 QUIT STAT
+12 ;
ASMTIDA(DFN,LSTINST) ; get admins by DFN/TSTIEN
+1 ; Find last complete admin
+2 NEW ADMINDT,ADMINID,CMPL,PAT,NM
+3 KILL ARRAY
+4 SET NM=""
SET N=0
+5 IF DFN'?1N.NP
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad DFN"
QUIT
+6 IF '$DATA(^DPT(DFN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no pt"
QUIT
+7 FOR
SET NM=$ORDER(^YTT(601.84,"C",DFN,NM))
if 'NM
QUIT
Begin DoDot:1
+8 SET G=$GET(^YTT(601.84,NM,0))
+9 IF G=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)=YSIENS_" bad ien in 84"
+10 SET PAT=$PIECE(G,U,2)
if PAT'=DFN
QUIT
+11 SET TST=$PIECE(G,U,3)
+12 SET CMPL=$PIECE(G,U,9)
IF CMPL="Y"
Begin DoDot:2
+13 SET NAME=$PIECE($GET(^YTT(601.71,TST,0)),U,1)
+14 SET STAFF=$PIECE($GET(^YTT(601.71,TST,9)),U,4)
if STAFF=""
SET STAFF="N"
+15 SET STAFF=$SELECT(STAFF="Y":"true",1:"false")
+16 SET ADMINID=$PIECE(G,U,1)
SET ADMINDT=$PIECE(G,U,4)
+17 SET LSTINST(TST,ADMINDT,ADMINID)=STAFF
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
UPDTSRFL ;
+1 ; Set index for 601.84 MH ADMINISTRATIONS
+2 ; X(1)=Patient X(2)=Instrument X(3)=Date Given
+3 ; ^PXRMINDX(601.84,"IP",X(2),X(1),X(3),DA)=""
+4 ; ^PXRMINDX(601.84,"PI",X(1),X(2),X(3),DA)=""
+5 NEW INSTIEN,TEMP,SRCALL
+6 SET INSTIEN=""
+7 ;Get list of instr IENs
FOR
SET INSTIEN=$ORDER(^PXRMINDX(601.84,"PI",DFN,INSTIEN))
if INSTIEN=""
QUIT
Begin DoDot:1
+8 SET TEMP=$GET(^YTT(601.71,INSTIEN,9))
+9 ;Get Suicide Tag & routine
SET TEMP(1)=$PIECE(TEMP,U,5)
SET TEMP(2)=$PIECE(TEMP,U,6)
+10 IF TEMP(1)'=""
IF (TEMP(2)'="")
Begin DoDot:2
+11 SET SRCALL="D "_TEMP(2)_U_TEMP(1)
+12 XECUTE SRCALL
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
