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

YTQRQAD1.m

Go to the documentation of this file.
  1. 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,240**;Dec 30, 1994;Build 10
  1. ;
  1. ; Reference to VADPT in ICR #10061
  1. ; Reference to XLFDT in ICR #10103
  1. ; Reference to XLFSTR in ICR #10104
  1. ; Reference to XPDMENU in ICR #1157
  1. ; Reference to XQCHK in ICR #10078
  1. ;
  1. ASMTBYID(ARGS,RESULTS) ; get assignment identified by assignmentId
  1. I $G(ARGS("assignmentId"))?36ANP G GETASMT^YTQRCRW ; CPRS DLL
  1. ;
  1. N ASMT,ADMIN,TEST,I
  1. S ASMT="YTQASMT-SET-"_$G(ARGS("assignmentId"))
  1. I '$D(^XTMP(ASMT)) D SETERROR^YTQRUTL(404,"Not Found: "_ARGS("assignmentId")) QUIT
  1. S I=0 F S I=$O(^XTMP(ASMT,1,"instruments",I)) Q:'I D ; calc progress
  1. . S ADMIN=+$G(^XTMP(ASMT,1,"instruments",I,"adminId"))
  1. . S TEST=+$G(^XTMP(ASMT,1,"instruments",I,"id"))
  1. . I $$ADMEXPD(ADMIN,TEST) D ; start over if this admin has expired
  1. . . S ^XTMP(ASMT,1,"instruments",I,"adminId")="null"
  1. . . I ^XTMP(ASMT,1,"patient","dfn")=$P(^YTT(601.84,ADMIN,0),U,2) D
  1. . . . D DELADMIN(ADMIN) ; double check DFN match just to make sure
  1. . . S ADMIN=0
  1. . S ^XTMP(ASMT,1,"instruments",I,"progress")=$$PROGRESS(ADMIN,TEST,$G(ARGS("assignmentId")))
  1. M RESULTS=^XTMP(ASMT,1) ; load assignment
  1. Q
  1. ASMTBYNM(ARGS,RESULTS) ; get assignment identified by lastName and last4
  1. N ASMT,PID,PTNAME,LAST
  1. S PID=ARGS("last4")
  1. S PTNAME=$$UP^XLFSTR(ARGS("lastName"))
  1. I 'PID!'$L(PTNAME) D SETERROR^YTQRUTL(400,"Missing Identifiers") QUIT
  1. S LAST=$O(^XTMP("YTQASMT-INDEX","AC",PID,PTNAME,0))
  1. S ASMT=$G(^XTMP("YTQASMT-INDEX","AC",PID,PTNAME,LAST))
  1. I 'ASMT D SETERROR^YTQRUTL(404,"Not Found: Assignment for Patient") QUIT
  1. S ARGS("assignmentId")=ASMT
  1. D ASMTBYID(.ARGS,.RESULTS)
  1. Q
  1. PROGRESS(ADMIN,TEST,ASMTID) ; return the progress for an administration
  1. ; progress in 100% if administration is complete
  1. I ADMIN,$P($G(^YTT(601.84,ADMIN,0)),U,9)="Y" Q 100
  1. ; check to see if this is a CAT that has been started
  1. N CATPROG S CATPROG=-1
  1. I $G(ASMTID,0) D I CATPROG>-1 Q CATPROG
  1. . I $G(^XTMP("YTQASMT-SET-"_ASMTID,1,"catInfo","credentials","interviewID")) S CATPROG=10
  1. ;
  1. Q:'ADMIN 0
  1. N I,QANS,QTOT
  1. S QANS=$P(^YTT(601.84,ADMIN,0),U,10)
  1. S (I,QTOT)=0 F S I=$O(^YTT(601.76,"AC",TEST,I)) Q:'I S QTOT=QTOT+1
  1. Q $S(QTOT>0:$P(((QANS/QTOT)*100)+.5,"."),1:0)
  1. ;
  1. NEWASMT(ARGS,DATA) ; save assignment, return /api/mha/assignment/{assignmentId}
  1. N I,DFN,ORDBY,VA,VADM,VAERR,SETID,FOUND,PID,PTNAME,EXPIRE,CONS,COSIGN
  1. N RETSTAT,REPLACE
  1. S DFN=+$G(DATA("patient","dfn"))
  1. S ORDBY=+$G(DATA("orderedBy"))
  1. S CONS=+$G(DATA("consult"))
  1. S COSIGN=+$G(DATA("cosigner"))
  1. I 'DFN!'ORDBY D SETERROR^YTQRUTL(400,"Missing Reqd Fields") QUIT ""
  1. D DEM^VADPT I $G(VAERR) D SETERROR^YTQRUTL(400,"Missing Pt Info") QUIT ""
  1. S PID=VA("BID"),PTNAME=VADM(1)
  1. ; set these "patient" nodes up in case called with just DFN
  1. S DATA("patient","name")=PTNAME
  1. S DATA("patient","pid")="xxx-xx-"_PID
  1. S DATA("patient","ssn")=DATA("patient","pid")
  1. ; get instrument Admin Date
  1. S DATA("adminDate")=$G(DATA("adminDate")) ;Ensure adminDate is set
  1. I $G(DATA("consult"))=""!($G(DATA("consult"))="null") K DATA("consult")
  1. S DATA("appSrc")=$G(DATA("appSrc"))
  1. S FOUND=""
  1. S I=0 F S I=$O(DATA("instruments",I)) Q:I=""!FOUND D
  1. . I $G(DATA("instruments",I,"replace"))]"" D
  1. .. S REPLACE=DATA("instruments",I,"replace") M DATA(2)=^XTMP("YTQASMT-SET-"_REPLACE,2) S FOUND=1
  1. ; look up IEN for each instrument in the assignment
  1. S RETSTAT=$$FILASGN(.ARGS,.DATA,"","NEW")
  1. Q RETSTAT
  1. FILASGN(ARGS,DATA,SETID,TYPE) ;File the Assignment Data
  1. ; ARGS = incoming arguments
  1. ; DATA = incoming data
  1. ; SETID = Assignment number if existing assignment(EDIT)
  1. ; TYPE = NEW or EDIT
  1. N I,PREFIX,FOUND,EXPIRE,OLDSET,YSTAT
  1. I $G(TYPE)="" S TYPE="NEW" ;default
  1. S SETID=$G(SETID)
  1. S I=0 F S I=$O(DATA("instruments",I)) Q:'I D
  1. . N TSTNM,TSTID,TSTFN,TSTRSTRT
  1. . S TSTNM=$G(DATA("instruments",I,"name")) Q:'$L(TSTNM)
  1. . S TSTID=$O(^YTT(601.71,"B",TSTNM,0)) Q:'TSTID
  1. . S TSTFN=$P(^YTT(601.71,TSTID,0),U,3)
  1. . S TSTRSTRT=$P($G(^YTT(601.71,TSTID,8)),U,7) S:TSTRSTRT="" TSTRSTRT=-1
  1. . S DATA("instruments",I,"id")=TSTID
  1. . S DATA("instruments",I,"printTitle")=TSTFN
  1. . S DATA("instruments",I,"restartDays")=TSTRSTRT
  1. . I +$G(DATA("instruments",I,"replace")) D ; creating from old asmt
  1. . . D RMVTEST(DATA("instruments",I,"replace"),DATA("instruments",I,"name"),,,1)
  1. . . I $E(DATA("instruments",I,"name"),1,4)="CAT-" D
  1. . . . S OLDSET=DATA("instruments",I,"replace")
  1. . . K DATA("instruments",I,"replace")
  1. ; randomly generate an instrument-set id and check for already used
  1. S YSTAT="",PREFIX="YTQASMT-SET-"
  1. I TYPE="NEW"!(SETID="") D
  1. . S FOUND=0,EXPIRE=$$FMADD^XLFDT(DT,7)
  1. . F I=1:1:500 S SETID=$R(100000) D Q:FOUND ; give up after 500 tries
  1. . . I $D(^XTMP(PREFIX_SETID)) QUIT ; already occupied
  1. . . L +^XTMP(PREFIX_SETID,0):DILOCKTM E S YSTAT="500^Cannot get Lock for Assignment" QUIT ; didn't get lock in time
  1. . . S ^XTMP(PREFIX_SETID,0)=EXPIRE_U_DT_U_"MH Assignment"
  1. . . S ^XTMP("YTQASMT-INDEX",0)=^XTMP(PREFIX_SETID,0)_" Index"
  1. . . L -^XTMP(PREFIX_SETID,0)
  1. . . ;M ^XTMP(PREFIX_SETID,1)=DATA ; save assignment object
  1. . . S ^XTMP(PREFIX_SETID,1,"id")=SETID
  1. . . S ^XTMP("YTQASMT-INDEX","AC",PID,$P(PTNAME,","),9999999-$$NOW^XLFDT)=SETID
  1. . . S ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,SETID)=EXPIRE
  1. . . I +$G(OLDSET) D MVAUTOSV^YTQRCAT(OLDSET,SETID)
  1. . . S FOUND=1
  1. . I 'FOUND S YSTAT="500^Could not create Assignment"
  1. I TYPE="EDIT" D
  1. . I SETID="" S YSTAT="500^Assignment not provided" Q
  1. . K ^XTMP("YTQASMT-SET-"_SETID,1,"instruments")
  1. . ;S I=0 F S I=$O(^XTMP("YTQASMT-SET-"_SETID,1,"instruments",I)) Q:I="" K ^XTMP("YTQASMT-SET-"_SETID,1,"instruments",I)
  1. . ;Re-file new instrument info into ^XTMP
  1. . I '$D(DATA("instruments")) D DELASMT1^YTQRQAD1(SETID) Q ;Assignment has no instruments
  1. . M ^XTMP(PREFIX_SETID,1,"instruments")=DATA("instruments") ; save assignment object
  1. . I $D(DATA("catInfo")) M ^XTMP(PREFIX_SETID,1,"catInfo")=DATA("catInfo")
  1. . ;Kill any changes of omission before merging
  1. . I '$D(DATA("consult")) K ^XTMP(PREFIX_SETID,1,"consult") ;Removed Consult
  1. . I '$D(DATA("adminDate")) K ^XTMP(PREFIX_SETID,1,"adminDate") ;Removed admin date
  1. . I '$D(DATA("cosigner")) K ^XTMP(PREFIX_SETID,1,"cosigner") ;Removed Cosigner
  1. . I '$D(^XTMP(PREFIX_SETID,1,"instruments")) S YSTAT="500^ERROR"
  1. I $D(DATA(2,"PNOTE")) M ^XTMP(PREFIX_SETID,2)=DATA(2) K DATA(2)
  1. I YSTAT'="" D Q ""
  1. . I $P(YSTAT,U)'>300 Q
  1. . D SETERROR^YTQRUTL($P(YSTAT,U),$P(YSTAT,U,2))
  1. M ^XTMP(PREFIX_SETID,1)=DATA
  1. Q "/api/mha/assignment/"_SETID
  1. ;
  1. DELASMT(ARGS) ; delete the assignment identified in ARGS("assignmentId")
  1. D DELASMT1(ARGS("assignmentId"))
  1. Q
  1. TRSASMT(ARGS) ; Delete an assignment from Staff Entry by Trash icon
  1. ; Allows deletion of any incomplete assignment (ie no instruments complete)
  1. ; *Deletes any incomplete MH ADMINISTRATIONS
  1. D DELASMT1(ARGS("assignmentId"),1)
  1. Q
  1. DELASMT1(ASMT,TRS,REPLACE) ; delete the assignment given the assignment number
  1. ;ASMT=Assignment number
  1. ;TRS=Called from Trash Assignment - allow deletion of incomplete MH ADMINISTRATION
  1. ;REPLACE=1 if called from FILASGN for moving one AssignmentID to a new AssignmentID
  1. N DATA,DFN,ORDBY,IARR,INST,TRSERR,VAERR,VA,VADM
  1. N AGPROG,PNOT
  1. S TRS=$G(TRS),TRSERR=""
  1. S REPLACE=$G(REPLACE)
  1. M DATA=^XTMP("YTQASMT-SET-"_ASMT,1)
  1. I $D(DATA)<10 D SETERROR^YTQRUTL(404,"Assignment not found") QUIT
  1. S DFN=+$G(DATA("patient","dfn"))
  1. S ORDBY=+$G(DATA("orderedBy"))
  1. S AGPROG=$D(^XTMP("YTQASMT-SET-"_ASMT,2))
  1. ; Moved Patient check here before deleting XREF otherwise XREF killed before Assignment killed/TRSERR=1
  1. D DEM^VADPT I $G(VAERR) D SETERROR^YTQRUTL(404,"Assignment missing pt info") QUIT ; missing pt info
  1. ;I '$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY) D SETERROR^YTQRUTL(404,"Assignment missing pt info") QUIT ; missing pt info
  1. I TRS=1 D
  1. . D AINSTS^YTQRQAD7(ASMT,.IARR)
  1. . I $G(IARR("STAT"))="NOTALLOWED" D SETERROR^YTQRUTL(405,"Delete assignment not allowed") S TRSERR=1 QUIT
  1. . I $G(IARR("STAT"))="NOTOK" D SETERROR^YTQRUTL(405,"One or more instruments complete") S TRSERR=1 QUIT
  1. . I '$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY) QUIT ; missing pt info
  1. . S INST=0 F S INST=$O(IARR(INST)) QUIT:+INST=0 D
  1. .. Q:IARR(INST)=0 ;Safety net
  1. .. Q:'$D(IARR(INST,"ADMINID"))
  1. .. D DELADMIN(IARR(INST,"ADMINID"))
  1. I TRSERR=1 QUIT
  1. 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
  1. N OK S OK=$$DELIDX^YTQRQAD1(ASMT,DFN,ORDBY)
  1. K ^XTMP("YTQASMT-SET-"_ASMT)
  1. Q
  1. DELIDX(ASMT,DFN,ORDBY) ; return true if able to remove "AC", "AD" indexes
  1. N VA,VADM,VAERR,PID,LNAME,INVDT
  1. D DEM^VADPT I $G(VAERR) D SETERROR^YTQRUTL(400,"Missing Pt Info") QUIT 0
  1. S PID=VA("BID"),LNAME=$P(VADM(1),",") ;VA("BID")=last 4 SSN
  1. K ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,ASMT)
  1. S INVDT=0 F S INVDT=$O(^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)) Q:'INVDT D
  1. . I ^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)=ASMT D
  1. . . K ^XTMP("YTQASMT-INDEX","AC",PID,LNAME,INVDT)
  1. Q 1
  1. ;
  1. DELTEST(ARGS) ; remove an instrument from an assignment
  1. I $L($G(ARGS("assignmentId")))=32 G GETASMT^YTQRCRW ; CPRS DLL
  1. ;
  1. N ASMT,TEST,TSLIST,II,DELFASGN
  1. S ASMT=$G(ARGS("assignmentId"))
  1. S DELFASGN=$G(ARGS("delfrmassign")) ;Flag to Delete Instrument from Assignment
  1. S:DELFASGN'="NO" DELFASGN="YES" ;Default is Delete from Assignment
  1. I $D(^XTMP("YTQASMT-SET-"_ASMT))<10 D SETERROR^YTQRUTL(404,"Assignment not found") QUIT
  1. S TSLIST=$G(ARGS("instrument")) I '$L(TSLIST) D SETERROR^YTQRUTL(404,"Instrument for deletion not sent") QUIT
  1. F II=1:1:$L(TSLIST,",") D
  1. . S TEST=$P(TSLIST,",",II)
  1. . Q:TEST=""
  1. . I +TEST=TEST S TEST=$P($G(^YTT(601.71,TEST,0)),U) ; use instrument name
  1. . I '$L(TEST) D SETERROR^YTQRUTL(404,"Instrument not found") QUIT
  1. . D RMVTEST(ASMT,TEST,1,DELFASGN)
  1. Q "/api/mha/assignment/"_ASMT_"/"_TSLIST_"/OK"
  1. RMVTEST(ASMT,TEST,DELADMIN,DELFASGN,REPLACE) ; remove test from assignment, delete assignment if empty
  1. ;Delete MH ADMINISTRATION if DELADMIN=1.
  1. ;Do Not Delete Instrument from Assignment if DELFASGN="NO". Used for 0 days restart instruments that need to be restarted same day.
  1. ;REPLACE=1 if called from FILASGN for moving one AssignmentID to a new AssignmentID
  1. N I,NODE,IARR
  1. S DELFASGN=$G(DELFASGN) S:DELFASGN'="NO" DELFASGN="YES" ;Default is to delete from Assignment
  1. S DELADMIN=$G(DELADMIN)
  1. S REPLACE=$G(REPLACE)
  1. D AINSTS^YTQRQAD7(ASMT,.IARR) ;Get Delete status of instruments for an Assignment
  1. S NODE="YTQASMT-SET-"_ASMT
  1. S I=0 F S I=$O(^XTMP(NODE,1,"instruments",I)) Q:'I D
  1. . I ^XTMP(NODE,1,"instruments",I,"name")=TEST D
  1. . . ;I DELADMIN=1,(IARR(I)'=0),($D(IARR(I,"ADMINID"))) D
  1. . . I DELADMIN=1,($D(IARR(I,"ADMINID"))) D ;Not Interview, Not Ordering OK
  1. . . . D DELADMIN(IARR(I,"ADMINID"))
  1. . . I DELFASGN="YES" K ^XTMP(NODE,1,"instruments",I)
  1. . . I DELFASGN="NO" D
  1. . . . S ^XTMP(NODE,1,"instruments",I,"adminId")="null"
  1. . . . S ^XTMP(NODE,1,"instruments",I,"complete")="false"
  1. . . . S ^XTMP(NODE,1,"instruments",I,"progress")=0
  1. I $D(^XTMP(NODE,1,"instruments"))<10 D DELASMT1(ASMT,,REPLACE)
  1. Q
  1. ;
  1. DELMHAD(ARGS,DATA) ;Delete Completed MH Admin
  1. N MGR,ADMINID,X0
  1. S MGR=$$ISMGR
  1. S ADMINID=$G(ARGS("adminId"))
  1. I ADMINID="" D SETERROR^YTQRUTL(404,"Admin ID Missing") Q "/api/mha/instrument/mhadmin/ERROR"
  1. I '$D(^YTT(601.84,ADMINID)) D SETERROR^YTQRUTL(404,"Admin ID not found") Q "/api/mha/instrument/mhadmin/ERROR"
  1. S X0=^YTT(601.84,ADMINID,0)
  1. ;I MGR!(DUZ=$P(X0,U,6))!(DUZ=$P(X0,U,7)) D DELADMIN(ADMINID) I 1
  1. I MGR D DELADMIN(ADMINID) I 1
  1. E D SETERROR^YTQRUTL(404,"Deletion not allowed: insufficient privilege") Q "/api/mha/instrument/mhadmin/ERROR"
  1. Q "/api/mha/instrument/mhadmin/OK"
  1. ISMGR() ; return 1 if admin access to admins
  1. N YSMENU,YSPRIV
  1. S YSMENU=$$LKOPT^XPDMENU("YSMANAGER") Q:'YSMENU 0
  1. S YSPRIV=$$ACCESS^XQCHK(DUZ,YSMENU)
  1. Q +YSPRIV>0
  1. ;
  1. ADMEXPD(ADMIN,TEST) ; return 1 if incomplete admin has expired
  1. QUIT:'ADMIN 0
  1. N X0,YSNOW,YSDOW,OFFSET,SAVED,RESTRT
  1. S X0=$G(^YTT(601.84,ADMIN,0))
  1. QUIT:$P(X0,U,9)="Y" 0 ; admin is complete
  1. QUIT:$P(X0,U,3)'=TEST 0 ; test mismatch, something wrong
  1. S YSNOW=$$NOW^XLFDT,YSDOW=$$DOW^XLFDT(YSNOW)
  1. S OFFSET=$S(YSDOW=5:2,YSDOW=6:1,1:0) ; account for weekends
  1. S SAVED=$P(X0,U,5) ; DATE SAVED (#4)
  1. S RESTRT=$P($G(^YTT(601.71,TEST,8)),U,7) ; DAYS TO RESTART (#27)
  1. QUIT:RESTRT=-1 0 ; -1 is always restartable
  1. S:'RESTRT RESTRT=2 ; default restart is 2
  1. I $$FMDIFF^XLFDT(YSNOW,SAVED,2)>((RESTRT+OFFSET)*86400) QUIT 1
  1. Q 0
  1. ;
  1. DELADMIN(YSADM) ; delete an admin & associated records
  1. N X,Y,DIK,DA,YSANS,YSRSLT,YSEVDFN,YSEVTST,YSEVCPLT
  1. S YSEVDFN=+$P($G(^YTT(601.84,+YSADM,0)),U,2)
  1. S YSEVTST=+$P($G(^YTT(601.84,+YSADM,0)),U,3)
  1. S YSEVTST=$P($G(^YTT(601.71,YSEVTST,0)),U)
  1. S YSEVCPLT=($P($G(^YTT(601.84,+YSADM,0)),U,9)="Y")
  1. ; delete the admin record
  1. S DIK="^YTT(601.84,",DA=YSADM D ^DIK
  1. ; delete the answer records
  1. S YSANS=0 F S YSANS=$O(^YTT(601.85,"AD",YSADM,YSANS)) Q:YSANS'>0 D
  1. . I $P(^YTT(601.85,YSANS,0),U,2)'=YSADM Q ; admin doesn't match
  1. . S DIK="^YTT(601.85,",DA=YSANS D ^DIK
  1. ; delete the result records
  1. S YSRSLT=0 F S YSRSLT=$O(^YTT(601.92,"AC",YSADM,YSRSLT)) Q:YSRSLT'>0 D
  1. . I $P(^YTT(601.92,YSRSLT,0),U,2)'=YSADM Q ; result doesn't match
  1. . S DIK="^YTT(601.92,",DA=YSRSLT D ^DIK
  1. ; publish delete event for admin if it was completed
  1. I YSEVCPLT D DELETE^YTQEVNT(YSADM,YSEVDFN,YSEVTST,"webdel")
  1. Q