YTQRQAD1 ;SLC/KCM - RESTful Calls to handle MHA assignments ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,141,178,182,181,187,199,207,204,223**;Dec 30, 1994;Build 22
;
; Reference to VADPT in ICR #10061
; Reference to XLFDT in ICR #10103
; Reference to XLFSTR in ICR #10104
; Reference to XPDMENU in ICR #1157
; Reference to XQCHK in ICR #10078
;
ASMTBYID(ARGS,RESULTS) ; get assignment identified by assignmentId
I $G(ARGS("assignmentId"))?36ANP G GETASMT^YTQRCRW ; CPRS DLL
;
N ASMT,ADMIN,TEST,I
S ASMT="YTQASMT-SET-"_$G(ARGS("assignmentId"))
I '$D(^XTMP(ASMT)) D SETERROR^YTQRUTL(404,"Not Found: "_ARGS("assignmentId")) QUIT
S I=0 F S I=$O(^XTMP(ASMT,1,"instruments",I)) Q:'I D ; calc progress
. S ADMIN=+$G(^XTMP(ASMT,1,"instruments",I,"adminId"))
. S TEST=+$G(^XTMP(ASMT,1,"instruments",I,"id"))
. I $$ADMEXPD(ADMIN,TEST) D ; start over if this admin has expired
. . S ^XTMP(ASMT,1,"instruments",I,"adminId")="null"
. . I ^XTMP(ASMT,1,"patient","dfn")=$P(^YTT(601.84,ADMIN,0),U,2) D
. . . D DELADMIN(ADMIN) ; double check DFN match just to make sure
. . S ADMIN=0
. S ^XTMP(ASMT,1,"instruments",I,"progress")=$$PROGRESS(ADMIN,TEST,$G(ARGS("assignmentId")))
M RESULTS=^XTMP(ASMT,1) ; load assignment
Q
ASMTBYNM(ARGS,RESULTS) ; get assignment identified by lastName and last4
N ASMT,PID,PTNAME,LAST
S PID=ARGS("last4")
S PTNAME=$$UP^XLFSTR(ARGS("lastName"))
I 'PID!'$L(PTNAME) D SETERROR^YTQRUTL(400,"Missing Identifiers") QUIT
S LAST=$O(^XTMP("YTQASMT-INDEX","AC",PID,PTNAME,0))
S ASMT=$G(^XTMP("YTQASMT-INDEX","AC",PID,PTNAME,LAST))
I 'ASMT D SETERROR^YTQRUTL(404,"Not Found: Assignment for Patient") QUIT
S ARGS("assignmentId")=ASMT
D ASMTBYID(.ARGS,.RESULTS)
Q
PROGRESS(ADMIN,TEST,ASMTID) ; return the progress for an administration
; progress in 100% if administration is complete
I ADMIN,$P($G(^YTT(601.84,ADMIN,0)),U,9)="Y" Q 100
; check to see if this is a CAT that has been started
N CATPROG S CATPROG=-1
I $G(ASMTID,0) D I CATPROG>-1 Q CATPROG
. I $G(^XTMP("YTQASMT-SET-"_ASMTID,1,"catInfo","credentials","interviewID")) S CATPROG=10
;
Q:'ADMIN 0
N I,QANS,QTOT
S QANS=$P(^YTT(601.84,ADMIN,0),U,10)
S (I,QTOT)=0 F S I=$O(^YTT(601.76,"AC",TEST,I)) Q:'I S QTOT=QTOT+1
Q $S(QTOT>0:$P(((QANS/QTOT)*100)+.5,"."),1:0)
;
NEWASMT(ARGS,DATA) ; save assignment, return /api/mha/assignment/{assignmentId}
N I,DFN,ORDBY,VA,VADM,VAERR,SETID,FOUND,PID,PTNAME,EXPIRE,CONS,COSIGN
N RETSTAT,REPLACE
S DFN=+$G(DATA("patient","dfn"))
S ORDBY=+$G(DATA("orderedBy"))
S CONS=+$G(DATA("consult"))
S COSIGN=+$G(DATA("cosigner"))
I 'DFN!'ORDBY D SETERROR^YTQRUTL(400,"Missing Reqd Fields") QUIT ""
D DEM^VADPT I $G(VAERR) D SETERROR^YTQRUTL(400,"Missing Pt Info") QUIT ""
S PID=VA("BID"),PTNAME=VADM(1)
; set these "patient" nodes up in case called with just DFN
S DATA("patient","name")=PTNAME
S DATA("patient","pid")="xxx-xx-"_PID
S DATA("patient","ssn")=DATA("patient","pid")
; get instrument Admin Date
S DATA("adminDate")=$G(DATA("adminDate")) ;Ensure adminDate is set
I $G(DATA("consult"))=""!($G(DATA("consult"))="null") K DATA("consult")
S DATA("appSrc")=$G(DATA("appSrc"))
S FOUND=""
S I=0 F S I=$O(DATA("instruments",I)) Q:I=""!FOUND D
. I $G(DATA("instruments",I,"replace"))]"" D
.. S REPLACE=DATA("instruments",I,"replace") M DATA(2)=^XTMP("YTQASMT-SET-"_REPLACE,2) S FOUND=1
; look up IEN for each instrument in the assignment
S RETSTAT=$$FILASGN(.ARGS,.DATA,"","NEW")
Q RETSTAT
FILASGN(ARGS,DATA,SETID,TYPE) ;File the Assignment Data
; ARGS = incoming arguments
; DATA = incoming data
; SETID = Assignment number if existing assignment(EDIT)
; TYPE = NEW or EDIT
N I,PREFIX,FOUND,EXPIRE,OLDSET,YSTAT
I $G(TYPE)="" S TYPE="NEW" ;default
S SETID=$G(SETID)
S I=0 F S I=$O(DATA("instruments",I)) Q:'I D
. N TSTNM,TSTID,TSTFN,TSTRSTRT
. S TSTNM=$G(DATA("instruments",I,"name")) Q:'$L(TSTNM)
. S TSTID=$O(^YTT(601.71,"B",TSTNM,0)) Q:'TSTID
. S TSTFN=$P(^YTT(601.71,TSTID,0),U,3)
. S TSTRSTRT=$P($G(^YTT(601.71,TSTID,8)),U,7) S:TSTRSTRT="" TSTRSTRT=-1
. S DATA("instruments",I,"id")=TSTID
. S DATA("instruments",I,"printTitle")=TSTFN
. S DATA("instruments",I,"restartDays")=TSTRSTRT
. I +$G(DATA("instruments",I,"replace")) D ; creating from old asmt
. . D RMVTEST(DATA("instruments",I,"replace"),DATA("instruments",I,"name"),,,1)
. . I $E(DATA("instruments",I,"name"),1,4)="CAT-" D
. . . S OLDSET=DATA("instruments",I,"replace")
. . K DATA("instruments",I,"replace")
; randomly generate an instrument-set id and check for already used
S YSTAT="",PREFIX="YTQASMT-SET-"
I TYPE="NEW"!(SETID="") D
. S FOUND=0,EXPIRE=$$FMADD^XLFDT(DT,7)
. F I=1:1:500 S SETID=$R(100000) D Q:FOUND ; give up after 500 tries
. . I $D(^XTMP(PREFIX_SETID)) QUIT ; already occupied
. . L +^XTMP(PREFIX_SETID,0):DILOCKTM E S YSTAT="500^Cannot get Lock for Assignment" QUIT ; didn't get lock in time
. . S ^XTMP(PREFIX_SETID,0)=EXPIRE_U_DT_U_"MH Assignment"
. . S ^XTMP("YTQASMT-INDEX",0)=^XTMP(PREFIX_SETID,0)_" Index"
. . L -^XTMP(PREFIX_SETID,0)
. . ;M ^XTMP(PREFIX_SETID,1)=DATA ; save assignment object
. . S ^XTMP(PREFIX_SETID,1,"id")=SETID
. . S ^XTMP("YTQASMT-INDEX","AC",PID,$P(PTNAME,","),9999999-$$NOW^XLFDT)=SETID
. . S ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,SETID)=EXPIRE
. . I +$G(OLDSET) D MVAUTOSV^YTQRCAT(OLDSET,SETID)
. . S FOUND=1
. I 'FOUND S YSTAT="500^Could not create Assignment"
I TYPE="EDIT" D
. I SETID="" S YSTAT="500^Assignment not provided" Q
. K ^XTMP("YTQASMT-SET-"_SETID,1,"instruments")
. ;S I=0 F S I=$O(^XTMP("YTQASMT-SET-"_SETID,1,"instruments",I)) Q:I="" K ^XTMP("YTQASMT-SET-"_SETID,1,"instruments",I)
. ;Re-file new instrument info into ^XTMP
. I '$D(DATA("instruments")) D DELASMT1^YTQRQAD1(SETID) Q ;Assignment has no instruments
. M ^XTMP(PREFIX_SETID,1,"instruments")=DATA("instruments") ; save assignment object
. I $D(DATA("catInfo")) M ^XTMP(PREFIX_SETID,1,"catInfo")=DATA("catInfo")
. ;Kill any changes of omission before merging
. I '$D(DATA("consult")) K ^XTMP(PREFIX_SETID,1,"consult") ;Removed Consult
. I '$D(DATA("adminDate")) K ^XTMP(PREFIX_SETID,1,"adminDate") ;Removed admin date
. I '$D(DATA("cosigner")) K ^XTMP(PREFIX_SETID,1,"cosigner") ;Removed Cosigner
. I '$D(^XTMP(PREFIX_SETID,1,"instruments")) S YSTAT="500^ERROR"
I $D(DATA(2,"PNOTE")) M ^XTMP(PREFIX_SETID,2)=DATA(2) K DATA(2)
I YSTAT'="" D Q ""
. I $P(YSTAT,U)'>300 Q
. D SETERROR^YTQRUTL($P(YSTAT,U),$P(YSTAT,U,2))
M ^XTMP(PREFIX_SETID,1)=DATA
Q "/api/mha/assignment/"_SETID
;
DELASMT(ARGS) ; delete the assignment identified in ARGS("assignmentId")
D DELASMT1(ARGS("assignmentId"))
Q
TRSASMT(ARGS) ; Delete an assignment from Staff Entry by Trash icon
; Allows deletion of any incomplete assignment (ie no instruments complete)
; *Deletes any incomplete MH ADMINISTRATIONS
D DELASMT1(ARGS("assignmentId"),1)
Q
DELASMT1(ASMT,TRS,REPLACE) ; delete the assignment given the assignment number
;ASMT=Assignment number
;TRS=Called from Trash Assignment - allow deletion of incomplete MH ADMINISTRATION
;REPLACE=1 if called from FILASGN for moving one AssignmentID to a new AssignmentID
N DATA,DFN,ORDBY,IARR,INST,TRSERR,VAERR,VA,VADM
N AGPROG,PNOT
S TRS=$G(TRS),TRSERR=""
S REPLACE=$G(REPLACE)
M DATA=^XTMP("YTQASMT-SET-"_ASMT,1)
I $D(DATA)<10 D SETERROR^YTQRUTL(404,"Assignment not found") QUIT
S DFN=+$G(DATA("patient","dfn"))
S ORDBY=+$G(DATA("orderedBy"))
S AGPROG=$D(^XTMP("YTQASMT-SET-"_ASMT,2))
; Moved Patient check here before deleting XREF otherwise XREF killed before Assignment killed/TRSERR=1
D DEM^VADPT I $G(VAERR) D SETERROR^YTQRUTL(404,"Assignment missing pt info") QUIT ; missing pt info
;I '$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY) D SETERROR^YTQRUTL(404,"Assignment missing pt info") QUIT ; missing pt info
I TRS=1 D
. D AINSTS^YTQRQAD7(ASMT,.IARR)
. I $G(IARR("STAT"))="NOTALLOWED" D SETERROR^YTQRUTL(405,"Delete assignment not allowed") S TRSERR=1 QUIT
. I $G(IARR("STAT"))="NOTOK" D SETERROR^YTQRUTL(405,"One or more instruments complete") S TRSERR=1 QUIT
. I '$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY) QUIT ; missing pt info
. S INST=0 F S INST=$O(IARR(INST)) QUIT:+INST=0 D
.. Q:IARR(INST)=0 ;Safety net
.. Q:'$D(IARR(INST,"ADMINID"))
.. D DELADMIN(IARR(INST,"ADMINID"))
I TRSERR=1 QUIT
I AGPROG>0,(REPLACE'=1) S PNOT=$$FILPNOT^YTQRQAD8(ASMT,,,,,1) ;File any completed instrument Progress Note before deleting an Assignment if NOT from a moved assignment
N OK S OK=$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY)
K ^XTMP("YTQASMT-SET-"_ASMT)
Q
DELIDX(ASMT,DFN,ORDBY) ; return true if able to remove "AC", "AD" indexes
N VA,VADM,VAERR,PID,LNAME,INVDT
D DEM^VADPT I $G(VAERR) D SETERROR^YTQRUTL(400,"Missing Pt Info") QUIT 0
S PID=VA("BID"),LNAME=$P(VADM(1),",") ;VA("BID")=last 4 SSN
K ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,ASMT)
S INVDT=0 F S INVDT=$O(^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)) Q:'INVDT D
. I ^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)=ASMT D
. . K ^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)
Q 1
;
DELTEST(ARGS) ; remove an instrument from an assignment
I $L($G(ARGS("assignmentId")))=32 G GETASMT^YTQRCRW ; CPRS DLL
;
N ASMT,TEST,TSLIST,II,DELFASGN
S ASMT=$G(ARGS("assignmentId"))
S DELFASGN=$G(ARGS("delfrmassign")) ;Flag to Delete Instrument from Assignment
S:DELFASGN'="NO" DELFASGN="YES" ;Default is Delete from Assignment
I $D(^XTMP("YTQASMT-SET-"_ASMT))<10 D SETERROR^YTQRUTL(404,"Assignment not found") QUIT
S TSLIST=$G(ARGS("instrument")) I '$L(TSLIST) D SETERROR^YTQRUTL(404,"Instrument for deletion not sent") QUIT
F II=1:1:$L(TSLIST,",") D
. S TEST=$P(TSLIST,",",II)
. Q:TEST=""
. I +TEST=TEST S TEST=$P($G(^YTT(601.71,TEST,0)),U) ; use instrument name
. I '$L(TEST) D SETERROR^YTQRUTL(404,"Instrument not found") QUIT
. D RMVTEST(ASMT,TEST,1,DELFASGN)
Q "/api/mha/assignment/"_ASMT_"/"_TSLIST_"/OK"
RMVTEST(ASMT,TEST,DELADMIN,DELFASGN,REPLACE) ; remove test from assignment, delete assignment if empty
;Delete MH ADMINISTRATION if DELADMIN=1.
;Do Not Delete Instrument from Assignment if DELFASGN="NO". Used for 0 days restart instruments that need to be restarted same day.
;REPLACE=1 if called from FILASGN for moving one AssignmentID to a new AssignmentID
N I,NODE,IARR
S DELFASGN=$G(DELFASGN) S:DELFASGN'="NO" DELFASGN="YES" ;Default is to delete from Assignment
S DELADMIN=$G(DELADMIN)
S REPLACE=$G(REPLACE)
D AINSTS^YTQRQAD7(ASMT,.IARR) ;Get Delete status of instruments for an Assignment
S NODE="YTQASMT-SET-"_ASMT
S I=0 F S I=$O(^XTMP(NODE,1,"instruments",I)) Q:'I D
. I ^XTMP(NODE,1,"instruments",I,"name")=TEST D
. . ;I DELADMIN=1,(IARR(I)'=0),($D(IARR(I,"ADMINID"))) D
. . I DELADMIN=1,($D(IARR(I,"ADMINID"))) D ;Not Interview, Not Ordering OK
. . . D DELADMIN(IARR(I,"ADMINID"))
. . I DELFASGN="YES" K ^XTMP(NODE,1,"instruments",I)
. . I DELFASGN="NO" D
. . . S ^XTMP(NODE,1,"instruments",I,"adminId")="null"
. . . S ^XTMP(NODE,1,"instruments",I,"complete")="false"
. . . S ^XTMP(NODE,1,"instruments",I,"progress")=0
I $D(^XTMP(NODE,1,"instruments"))<10 D DELASMT1(ASMT,,REPLACE)
Q
;
DELMHAD(ARGS,DATA) ;Delete Completed MH Admin
N MGR,ADMINID,X0
S MGR=$$ISMGR
S ADMINID=$G(ARGS("adminId"))
I ADMINID="" D SETERROR^YTQRUTL(404,"Admin ID Missing") Q "/api/mha/instrument/mhadmin/ERROR"
I '$D(^YTT(601.84,ADMINID)) D SETERROR^YTQRUTL(404,"Admin ID not found") Q "/api/mha/instrument/mhadmin/ERROR"
S X0=^YTT(601.84,ADMINID,0)
;I MGR!(DUZ=$P(X0,U,6))!(DUZ=$P(X0,U,7)) D DELADMIN(ADMINID) I 1
I MGR D DELADMIN(ADMINID) I 1
E D SETERROR^YTQRUTL(404,"Deletion not allowed: insufficient privilege") Q "/api/mha/instrument/mhadmin/ERROR"
Q "/api/mha/instrument/mhadmin/OK"
ISMGR() ; return 1 if admin access to admins
N YSMENU,YSPRIV
S YSMENU=$$LKOPT^XPDMENU("YSMANAGER") Q:'YSMENU 0
S YSPRIV=$$ACCESS^XQCHK(DUZ,YSMENU)
Q +YSPRIV>0
;
ADMEXPD(ADMIN,TEST) ; return 1 if incomplete admin has expired
QUIT:'ADMIN 0
N X0,YSNOW,YSDOW,OFFSET,SAVED,RESTRT
S X0=$G(^YTT(601.84,ADMIN,0))
QUIT:$P(X0,U,9)="Y" 0 ; admin is complete
QUIT:$P(X0,U,3)'=TEST 0 ; test mismatch, something wrong
S YSNOW=$$NOW^XLFDT,YSDOW=$$DOW^XLFDT(YSNOW)
S OFFSET=$S(YSDOW=5:2,YSDOW=6:1,1:0) ; account for weekends
S SAVED=$P(X0,U,5) ; DATE SAVED (#4)
S RESTRT=$P($G(^YTT(601.71,TEST,8)),U,7) ; DAYS TO RESTART (#27)
QUIT:RESTRT=-1 0 ; -1 is always restartable
S:'RESTRT RESTRT=2 ; default restart is 2
I $$FMDIFF^XLFDT(YSNOW,SAVED,2)>((RESTRT+OFFSET)*86400) QUIT 1
Q 0
;
DELADMIN(YSADM) ; delete an admin & associated records
N X,Y,DIK,DA,YSANS,YSRSLT
; delete the admin record
S DIK="^YTT(601.84,",DA=YSADM D ^DIK
; delete the answer records
S YSANS=0 F S YSANS=$O(^YTT(601.85,"AD",YSADM,YSANS)) Q:YSANS'>0 D
. I $P(^YTT(601.85,YSANS,0),U,2)'=YSADM Q ; admin doesn't match
. S DIK="^YTT(601.85,",DA=YSANS D ^DIK
; delete the result records
S YSRSLT=0 F S YSRSLT=$O(^YTT(601.92,"AC",YSADM,YSRSLT)) Q:YSRSLT'>0 D
. I $P(^YTT(601.92,YSRSLT,0),U,2)'=YSADM Q ; result doesn't match
. S DIK="^YTT(601.92,",DA=YSRSLT D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRQAD1 13442 printed Apr 09, 2024@21:21:18 Page 2
YTQRQAD1 ;SLC/KCM - RESTful Calls to handle MHA assignments ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,141,178,182,181,187,199,207,204,223**;Dec 30, 1994;Build 22
+2 ;
+3 ; Reference to VADPT in ICR #10061
+4 ; Reference to XLFDT in ICR #10103
+5 ; Reference to XLFSTR in ICR #10104
+6 ; Reference to XPDMENU in ICR #1157
+7 ; Reference to XQCHK in ICR #10078
+8 ;
ASMTBYID(ARGS,RESULTS) ; get assignment identified by assignmentId
+1 ; CPRS DLL
IF $GET(ARGS("assignmentId"))?36ANP
GOTO GETASMT^YTQRCRW
+2 ;
+3 NEW ASMT,ADMIN,TEST,I
+4 SET ASMT="YTQASMT-SET-"_$GET(ARGS("assignmentId"))
+5 IF '$DATA(^XTMP(ASMT))
DO SETERROR^YTQRUTL(404,"Not Found: "_ARGS("assignmentId"))
QUIT
+6 ; calc progress
SET I=0
FOR
SET I=$ORDER(^XTMP(ASMT,1,"instruments",I))
if 'I
QUIT
Begin DoDot:1
+7 SET ADMIN=+$GET(^XTMP(ASMT,1,"instruments",I,"adminId"))
+8 SET TEST=+$GET(^XTMP(ASMT,1,"instruments",I,"id"))
+9 ; start over if this admin has expired
IF $$ADMEXPD(ADMIN,TEST)
Begin DoDot:2
+10 SET ^XTMP(ASMT,1,"instruments",I,"adminId")="null"
+11 IF ^XTMP(ASMT,1,"patient","dfn")=$PIECE(^YTT(601.84,ADMIN,0),U,2)
Begin DoDot:3
+12 ; double check DFN match just to make sure
DO DELADMIN(ADMIN)
End DoDot:3
+13 SET ADMIN=0
End DoDot:2
+14 SET ^XTMP(ASMT,1,"instruments",I,"progress")=$$PROGRESS(ADMIN,TEST,$GET(ARGS("assignmentId")))
End DoDot:1
+15 ; load assignment
MERGE RESULTS=^XTMP(ASMT,1)
+16 QUIT
ASMTBYNM(ARGS,RESULTS) ; get assignment identified by lastName and last4
+1 NEW ASMT,PID,PTNAME,LAST
+2 SET PID=ARGS("last4")
+3 SET PTNAME=$$UP^XLFSTR(ARGS("lastName"))
+4 IF 'PID!'$LENGTH(PTNAME)
DO SETERROR^YTQRUTL(400,"Missing Identifiers")
QUIT
+5 SET LAST=$ORDER(^XTMP("YTQASMT-INDEX","AC",PID,PTNAME,0))
+6 SET ASMT=$GET(^XTMP("YTQASMT-INDEX","AC",PID,PTNAME,LAST))
+7 IF 'ASMT
DO SETERROR^YTQRUTL(404,"Not Found: Assignment for Patient")
QUIT
+8 SET ARGS("assignmentId")=ASMT
+9 DO ASMTBYID(.ARGS,.RESULTS)
+10 QUIT
PROGRESS(ADMIN,TEST,ASMTID) ; return the progress for an administration
+1 ; progress in 100% if administration is complete
+2 IF ADMIN
IF $PIECE($GET(^YTT(601.84,ADMIN,0)),U,9)="Y"
QUIT 100
+3 ; check to see if this is a CAT that has been started
+4 NEW CATPROG
SET CATPROG=-1
+5 IF $GET(ASMTID,0)
Begin DoDot:1
+6 IF $GET(^XTMP("YTQASMT-SET-"_ASMTID,1,"catInfo","credentials","interviewID"))
SET CATPROG=10
End DoDot:1
IF CATPROG>-1
QUIT CATPROG
+7 ;
+8 if 'ADMIN
QUIT 0
+9 NEW I,QANS,QTOT
+10 SET QANS=$PIECE(^YTT(601.84,ADMIN,0),U,10)
+11 SET (I,QTOT)=0
FOR
SET I=$ORDER(^YTT(601.76,"AC",TEST,I))
if 'I
QUIT
SET QTOT=QTOT+1
+12 QUIT $SELECT(QTOT>0:$PIECE(((QANS/QTOT)*100)+.5,"."),1:0)
+13 ;
NEWASMT(ARGS,DATA) ; save assignment, return /api/mha/assignment/{assignmentId}
+1 NEW I,DFN,ORDBY,VA,VADM,VAERR,SETID,FOUND,PID,PTNAME,EXPIRE,CONS,COSIGN
+2 NEW RETSTAT,REPLACE
+3 SET DFN=+$GET(DATA("patient","dfn"))
+4 SET ORDBY=+$GET(DATA("orderedBy"))
+5 SET CONS=+$GET(DATA("consult"))
+6 SET COSIGN=+$GET(DATA("cosigner"))
+7 IF 'DFN!'ORDBY
DO SETERROR^YTQRUTL(400,"Missing Reqd Fields")
QUIT ""
+8 DO DEM^VADPT
IF $GET(VAERR)
DO SETERROR^YTQRUTL(400,"Missing Pt Info")
QUIT ""
+9 SET PID=VA("BID")
SET PTNAME=VADM(1)
+10 ; set these "patient" nodes up in case called with just DFN
+11 SET DATA("patient","name")=PTNAME
+12 SET DATA("patient","pid")="xxx-xx-"_PID
+13 SET DATA("patient","ssn")=DATA("patient","pid")
+14 ; get instrument Admin Date
+15 ;Ensure adminDate is set
SET DATA("adminDate")=$GET(DATA("adminDate"))
+16 IF $GET(DATA("consult"))=""!($GET(DATA("consult"))="null")
KILL DATA("consult")
+17 SET DATA("appSrc")=$GET(DATA("appSrc"))
+18 SET FOUND=""
+19 SET I=0
FOR
SET I=$ORDER(DATA("instruments",I))
if I=""!FOUND
QUIT
Begin DoDot:1
+20 IF $GET(DATA("instruments",I,"replace"))]""
Begin DoDot:2
+21 SET REPLACE=DATA("instruments",I,"replace")
MERGE DATA(2)=^XTMP("YTQASMT-SET-"_REPLACE,2)
SET FOUND=1
End DoDot:2
End DoDot:1
+22 ; look up IEN for each instrument in the assignment
+23 SET RETSTAT=$$FILASGN(.ARGS,.DATA,"","NEW")
+24 QUIT RETSTAT
FILASGN(ARGS,DATA,SETID,TYPE) ;File the Assignment Data
+1 ; ARGS = incoming arguments
+2 ; DATA = incoming data
+3 ; SETID = Assignment number if existing assignment(EDIT)
+4 ; TYPE = NEW or EDIT
+5 NEW I,PREFIX,FOUND,EXPIRE,OLDSET,YSTAT
+6 ;default
IF $GET(TYPE)=""
SET TYPE="NEW"
+7 SET SETID=$GET(SETID)
+8 SET I=0
FOR
SET I=$ORDER(DATA("instruments",I))
if 'I
QUIT
Begin DoDot:1
+9 NEW TSTNM,TSTID,TSTFN,TSTRSTRT
+10 SET TSTNM=$GET(DATA("instruments",I,"name"))
if '$LENGTH(TSTNM)
QUIT
+11 SET TSTID=$ORDER(^YTT(601.71,"B",TSTNM,0))
if 'TSTID
QUIT
+12 SET TSTFN=$PIECE(^YTT(601.71,TSTID,0),U,3)
+13 SET TSTRSTRT=$PIECE($GET(^YTT(601.71,TSTID,8)),U,7)
if TSTRSTRT=""
SET TSTRSTRT=-1
+14 SET DATA("instruments",I,"id")=TSTID
+15 SET DATA("instruments",I,"printTitle")=TSTFN
+16 SET DATA("instruments",I,"restartDays")=TSTRSTRT
+17 ; creating from old asmt
IF +$GET(DATA("instruments",I,"replace"))
Begin DoDot:2
+18 DO RMVTEST(DATA("instruments",I,"replace"),DATA("instruments",I,"name"),,,1)
+19 IF $EXTRACT(DATA("instruments",I,"name"),1,4)="CAT-"
Begin DoDot:3
+20 SET OLDSET=DATA("instruments",I,"replace")
End DoDot:3
+21 KILL DATA("instruments",I,"replace")
End DoDot:2
End DoDot:1
+22 ; randomly generate an instrument-set id and check for already used
+23 SET YSTAT=""
SET PREFIX="YTQASMT-SET-"
+24 IF TYPE="NEW"!(SETID="")
Begin DoDot:1
+25 SET FOUND=0
SET EXPIRE=$$FMADD^XLFDT(DT,7)
+26 ; give up after 500 tries
FOR I=1:1:500
SET SETID=$RANDOM(100000)
Begin DoDot:2
+27 ; already occupied
IF $DATA(^XTMP(PREFIX_SETID))
QUIT
+28 ; didn't get lock in time
LOCK +^XTMP(PREFIX_SETID,0):DILOCKTM
IF '$TEST
SET YSTAT="500^Cannot get Lock for Assignment"
QUIT
+29 SET ^XTMP(PREFIX_SETID,0)=EXPIRE_U_DT_U_"MH Assignment"
+30 SET ^XTMP("YTQASMT-INDEX",0)=^XTMP(PREFIX_SETID,0)_" Index"
+31 LOCK -^XTMP(PREFIX_SETID,0)
+32 ;M ^XTMP(PREFIX_SETID,1)=DATA ; save assignment object
+33 SET ^XTMP(PREFIX_SETID,1,"id")=SETID
+34 SET ^XTMP("YTQASMT-INDEX","AC",PID,$PIECE(PTNAME,","),9999999-$$NOW^XLFDT)=SETID
+35 SET ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,SETID)=EXPIRE
+36 IF +$GET(OLDSET)
DO MVAUTOSV^YTQRCAT(OLDSET,SETID)
+37 SET FOUND=1
End DoDot:2
if FOUND
QUIT
+38 IF 'FOUND
SET YSTAT="500^Could not create Assignment"
End DoDot:1
+39 IF TYPE="EDIT"
Begin DoDot:1
+40 IF SETID=""
SET YSTAT="500^Assignment not provided"
QUIT
+41 KILL ^XTMP("YTQASMT-SET-"_SETID,1,"instruments")
+42 ;S I=0 F S I=$O(^XTMP("YTQASMT-SET-"_SETID,1,"instruments",I)) Q:I="" K ^XTMP("YTQASMT-SET-"_SETID,1,"instruments",I)
+43 ;Re-file new instrument info into ^XTMP
+44 ;Assignment has no instruments
IF '$DATA(DATA("instruments"))
DO DELASMT1^YTQRQAD1(SETID)
QUIT
+45 ; save assignment object
MERGE ^XTMP(PREFIX_SETID,1,"instruments")=DATA("instruments")
+46 IF $DATA(DATA("catInfo"))
MERGE ^XTMP(PREFIX_SETID,1,"catInfo")=DATA("catInfo")
+47 ;Kill any changes of omission before merging
+48 ;Removed Consult
IF '$DATA(DATA("consult"))
KILL ^XTMP(PREFIX_SETID,1,"consult")
+49 ;Removed admin date
IF '$DATA(DATA("adminDate"))
KILL ^XTMP(PREFIX_SETID,1,"adminDate")
+50 ;Removed Cosigner
IF '$DATA(DATA("cosigner"))
KILL ^XTMP(PREFIX_SETID,1,"cosigner")
+51 IF '$DATA(^XTMP(PREFIX_SETID,1,"instruments"))
SET YSTAT="500^ERROR"
End DoDot:1
+52 IF $DATA(DATA(2,"PNOTE"))
MERGE ^XTMP(PREFIX_SETID,2)=DATA(2)
KILL DATA(2)
+53 IF YSTAT'=""
Begin DoDot:1
+54 IF $PIECE(YSTAT,U)'>300
QUIT
+55 DO SETERROR^YTQRUTL($PIECE(YSTAT,U),$PIECE(YSTAT,U,2))
End DoDot:1
QUIT ""
+56 MERGE ^XTMP(PREFIX_SETID,1)=DATA
+57 QUIT "/api/mha/assignment/"_SETID
+58 ;
DELASMT(ARGS) ; delete the assignment identified in ARGS("assignmentId")
+1 DO DELASMT1(ARGS("assignmentId"))
+2 QUIT
TRSASMT(ARGS) ; Delete an assignment from Staff Entry by Trash icon
+1 ; Allows deletion of any incomplete assignment (ie no instruments complete)
+2 ; *Deletes any incomplete MH ADMINISTRATIONS
+3 DO DELASMT1(ARGS("assignmentId"),1)
+4 QUIT
DELASMT1(ASMT,TRS,REPLACE) ; delete the assignment given the assignment number
+1 ;ASMT=Assignment number
+2 ;TRS=Called from Trash Assignment - allow deletion of incomplete MH ADMINISTRATION
+3 ;REPLACE=1 if called from FILASGN for moving one AssignmentID to a new AssignmentID
+4 NEW DATA,DFN,ORDBY,IARR,INST,TRSERR,VAERR,VA,VADM
+5 NEW AGPROG,PNOT
+6 SET TRS=$GET(TRS)
SET TRSERR=""
+7 SET REPLACE=$GET(REPLACE)
+8 MERGE DATA=^XTMP("YTQASMT-SET-"_ASMT,1)
+9 IF $DATA(DATA)<10
DO SETERROR^YTQRUTL(404,"Assignment not found")
QUIT
+10 SET DFN=+$GET(DATA("patient","dfn"))
+11 SET ORDBY=+$GET(DATA("orderedBy"))
+12 SET AGPROG=$DATA(^XTMP("YTQASMT-SET-"_ASMT,2))
+13 ; Moved Patient check here before deleting XREF otherwise XREF killed before Assignment killed/TRSERR=1
+14 ; missing pt info
DO DEM^VADPT
IF $GET(VAERR)
DO SETERROR^YTQRUTL(404,"Assignment missing pt info")
QUIT
+15 ;I '$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY) D SETERROR^YTQRUTL(404,"Assignment missing pt info") QUIT ; missing pt info
+16 IF TRS=1
Begin DoDot:1
+17 DO AINSTS^YTQRQAD7(ASMT,.IARR)
+18 IF $GET(IARR("STAT"))="NOTALLOWED"
DO SETERROR^YTQRUTL(405,"Delete assignment not allowed")
SET TRSERR=1
QUIT
+19 IF $GET(IARR("STAT"))="NOTOK"
DO SETERROR^YTQRUTL(405,"One or more instruments complete")
SET TRSERR=1
QUIT
+20 ; missing pt info
IF '$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY)
QUIT
+21 SET INST=0
FOR
SET INST=$ORDER(IARR(INST))
if +INST=0
QUIT
Begin DoDot:2
+22 ;Safety net
if IARR(INST)=0
QUIT
+23 if '$DATA(IARR(INST,"ADMINID"))
QUIT
+24 DO DELADMIN(IARR(INST,"ADMINID"))
End DoDot:2
End DoDot:1
+25 IF TRSERR=1
QUIT
+26 ;File any completed instrument Progress Note before deleting an Assignment if NOT from a moved assignment
IF AGPROG>0
IF (REPLACE'=1)
SET PNOT=$$FILPNOT^YTQRQAD8(ASMT,,,,,1)
+27 NEW OK
SET OK=$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY)
+28 KILL ^XTMP("YTQASMT-SET-"_ASMT)
+29 QUIT
DELIDX(ASMT,DFN,ORDBY) ; return true if able to remove "AC", "AD" indexes
+1 NEW VA,VADM,VAERR,PID,LNAME,INVDT
+2 DO DEM^VADPT
IF $GET(VAERR)
DO SETERROR^YTQRUTL(400,"Missing Pt Info")
QUIT 0
+3 ;VA("BID")=last 4 SSN
SET PID=VA("BID")
SET LNAME=$PIECE(VADM(1),",")
+4 KILL ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,ASMT)
+5 SET INVDT=0
FOR
SET INVDT=$ORDER(^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT))
if 'INVDT
QUIT
Begin DoDot:1
+6 IF ^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)=ASMT
Begin DoDot:2
+7 KILL ^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)
End DoDot:2
End DoDot:1
+8 QUIT 1
+9 ;
DELTEST(ARGS) ; remove an instrument from an assignment
+1 ; CPRS DLL
IF $LENGTH($GET(ARGS("assignmentId")))=32
GOTO GETASMT^YTQRCRW
+2 ;
+3 NEW ASMT,TEST,TSLIST,II,DELFASGN
+4 SET ASMT=$GET(ARGS("assignmentId"))
+5 ;Flag to Delete Instrument from Assignment
SET DELFASGN=$GET(ARGS("delfrmassign"))
+6 ;Default is Delete from Assignment
if DELFASGN'="NO"
SET DELFASGN="YES"
+7 IF $DATA(^XTMP("YTQASMT-SET-"_ASMT))<10
DO SETERROR^YTQRUTL(404,"Assignment not found")
QUIT
+8 SET TSLIST=$GET(ARGS("instrument"))
IF '$LENGTH(TSLIST)
DO SETERROR^YTQRUTL(404,"Instrument for deletion not sent")
QUIT
+9 FOR II=1:1:$LENGTH(TSLIST,",")
Begin DoDot:1
+10 SET TEST=$PIECE(TSLIST,",",II)
+11 if TEST=""
QUIT
+12 ; use instrument name
IF +TEST=TEST
SET TEST=$PIECE($GET(^YTT(601.71,TEST,0)),U)
+13 IF '$LENGTH(TEST)
DO SETERROR^YTQRUTL(404,"Instrument not found")
QUIT
+14 DO RMVTEST(ASMT,TEST,1,DELFASGN)
End DoDot:1
+15 QUIT "/api/mha/assignment/"_ASMT_"/"_TSLIST_"/OK"
RMVTEST(ASMT,TEST,DELADMIN,DELFASGN,REPLACE) ; remove test from assignment, delete assignment if empty
+1 ;Delete MH ADMINISTRATION if DELADMIN=1.
+2 ;Do Not Delete Instrument from Assignment if DELFASGN="NO". Used for 0 days restart instruments that need to be restarted same day.
+3 ;REPLACE=1 if called from FILASGN for moving one AssignmentID to a new AssignmentID
+4 NEW I,NODE,IARR
+5 ;Default is to delete from Assignment
SET DELFASGN=$GET(DELFASGN)
if DELFASGN'="NO"
SET DELFASGN="YES"
+6 SET DELADMIN=$GET(DELADMIN)
+7 SET REPLACE=$GET(REPLACE)
+8 ;Get Delete status of instruments for an Assignment
DO AINSTS^YTQRQAD7(ASMT,.IARR)
+9 SET NODE="YTQASMT-SET-"_ASMT
+10 SET I=0
FOR
SET I=$ORDER(^XTMP(NODE,1,"instruments",I))
if 'I
QUIT
Begin DoDot:1
+11 IF ^XTMP(NODE,1,"instruments",I,"name")=TEST
Begin DoDot:2
+12 ;I DELADMIN=1,(IARR(I)'=0),($D(IARR(I,"ADMINID"))) D
+13 ;Not Interview, Not Ordering OK
IF DELADMIN=1
IF ($DATA(IARR(I,"ADMINID")))
Begin DoDot:3
+14 DO DELADMIN(IARR(I,"ADMINID"))
End DoDot:3
+15 IF DELFASGN="YES"
KILL ^XTMP(NODE,1,"instruments",I)
+16 IF DELFASGN="NO"
Begin DoDot:3
+17 SET ^XTMP(NODE,1,"instruments",I,"adminId")="null"
+18 SET ^XTMP(NODE,1,"instruments",I,"complete")="false"
+19 SET ^XTMP(NODE,1,"instruments",I,"progress")=0
End DoDot:3
End DoDot:2
End DoDot:1
+20 IF $DATA(^XTMP(NODE,1,"instruments"))<10
DO DELASMT1(ASMT,,REPLACE)
+21 QUIT
+22 ;
DELMHAD(ARGS,DATA) ;Delete Completed MH Admin
+1 NEW MGR,ADMINID,X0
+2 SET MGR=$$ISMGR
+3 SET ADMINID=$GET(ARGS("adminId"))
+4 IF ADMINID=""
DO SETERROR^YTQRUTL(404,"Admin ID Missing")
QUIT "/api/mha/instrument/mhadmin/ERROR"
+5 IF '$DATA(^YTT(601.84,ADMINID))
DO SETERROR^YTQRUTL(404,"Admin ID not found")
QUIT "/api/mha/instrument/mhadmin/ERROR"
+6 SET X0=^YTT(601.84,ADMINID,0)
+7 ;I MGR!(DUZ=$P(X0,U,6))!(DUZ=$P(X0,U,7)) D DELADMIN(ADMINID) I 1
+8 IF MGR
DO DELADMIN(ADMINID)
IF 1
+9 IF '$TEST
DO SETERROR^YTQRUTL(404,"Deletion not allowed: insufficient privilege")
QUIT "/api/mha/instrument/mhadmin/ERROR"
+10 QUIT "/api/mha/instrument/mhadmin/OK"
ISMGR() ; return 1 if admin access to admins
+1 NEW YSMENU,YSPRIV
+2 SET YSMENU=$$LKOPT^XPDMENU("YSMANAGER")
if 'YSMENU
QUIT 0
+3 SET YSPRIV=$$ACCESS^XQCHK(DUZ,YSMENU)
+4 QUIT +YSPRIV>0
+5 ;
ADMEXPD(ADMIN,TEST) ; return 1 if incomplete admin has expired
+1 if 'ADMIN
QUIT 0
+2 NEW X0,YSNOW,YSDOW,OFFSET,SAVED,RESTRT
+3 SET X0=$GET(^YTT(601.84,ADMIN,0))
+4 ; admin is complete
if $PIECE(X0,U,9)="Y"
QUIT 0
+5 ; test mismatch, something wrong
if $PIECE(X0,U,3)'=TEST
QUIT 0
+6 SET YSNOW=$$NOW^XLFDT
SET YSDOW=$$DOW^XLFDT(YSNOW)
+7 ; account for weekends
SET OFFSET=$SELECT(YSDOW=5:2,YSDOW=6:1,1:0)
+8 ; DATE SAVED (#4)
SET SAVED=$PIECE(X0,U,5)
+9 ; DAYS TO RESTART (#27)
SET RESTRT=$PIECE($GET(^YTT(601.71,TEST,8)),U,7)
+10 ; -1 is always restartable
if RESTRT=-1
QUIT 0
+11 ; default restart is 2
if 'RESTRT
SET RESTRT=2
+12 IF $$FMDIFF^XLFDT(YSNOW,SAVED,2)>((RESTRT+OFFSET)*86400)
QUIT 1
+13 QUIT 0
+14 ;
DELADMIN(YSADM) ; delete an admin & associated records
+1 NEW X,Y,DIK,DA,YSANS,YSRSLT
+2 ; delete the admin record
+3 SET DIK="^YTT(601.84,"
SET DA=YSADM
DO ^DIK
+4 ; delete the answer records
+5 SET YSANS=0
FOR
SET YSANS=$ORDER(^YTT(601.85,"AD",YSADM,YSANS))
if YSANS'>0
QUIT
Begin DoDot:1
+6 ; admin doesn't match
IF $PIECE(^YTT(601.85,YSANS,0),U,2)'=YSADM
QUIT
+7 SET DIK="^YTT(601.85,"
SET DA=YSANS
DO ^DIK
End DoDot:1
+8 ; delete the result records
+9 SET YSRSLT=0
FOR
SET YSRSLT=$ORDER(^YTT(601.92,"AC",YSADM,YSRSLT))
if YSRSLT'>0
QUIT
Begin DoDot:1
+10 ; result doesn't match
IF $PIECE(^YTT(601.92,YSRSLT,0),U,2)'=YSADM
QUIT
+11 SET DIK="^YTT(601.92,"
SET DA=YSRSLT
DO ^DIK
End DoDot:1
+12 QUIT
