Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQRQAD4

YTQRQAD4.m

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