- 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 Feb 18, 2025@23:45:14 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 ;