- 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,240**;Dec 30, 1994;Build 10
- ;
- ; 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,YSEVDFN,YSEVTST,YSEVCPLT
- S YSEVDFN=+$P($G(^YTT(601.84,+YSADM,0)),U,2)
- S YSEVTST=+$P($G(^YTT(601.84,+YSADM,0)),U,3)
- S YSEVTST=$P($G(^YTT(601.71,YSEVTST,0)),U)
- S YSEVCPLT=($P($G(^YTT(601.84,+YSADM,0)),U,9)="Y")
- ; 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
- ; publish delete event for admin if it was completed
- I YSEVCPLT D DELETE^YTQEVNT(YSADM,YSEVDFN,YSEVTST,"webdel")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRQAD1 13780 printed Jan 18, 2025@03:20:01 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,240**;Dec 30, 1994;Build 10
- +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,YSEVDFN,YSEVTST,YSEVCPLT
- +2 SET YSEVDFN=+$PIECE($GET(^YTT(601.84,+YSADM,0)),U,2)
- +3 SET YSEVTST=+$PIECE($GET(^YTT(601.84,+YSADM,0)),U,3)
- +4 SET YSEVTST=$PIECE($GET(^YTT(601.71,YSEVTST,0)),U)
- +5 SET YSEVCPLT=($PIECE($GET(^YTT(601.84,+YSADM,0)),U,9)="Y")
- +6 ; delete the admin record
- +7 SET DIK="^YTT(601.84,"
- SET DA=YSADM
- DO ^DIK
- +8 ; delete the answer records
- +9 SET YSANS=0
- FOR
- SET YSANS=$ORDER(^YTT(601.85,"AD",YSADM,YSANS))
- if YSANS'>0
- QUIT
- Begin DoDot:1
- +10 ; admin doesn't match
- IF $PIECE(^YTT(601.85,YSANS,0),U,2)'=YSADM
- QUIT
- +11 SET DIK="^YTT(601.85,"
- SET DA=YSANS
- DO ^DIK
- End DoDot:1
- +12 ; delete the result records
- +13 SET YSRSLT=0
- FOR
- SET YSRSLT=$ORDER(^YTT(601.92,"AC",YSADM,YSRSLT))
- if YSRSLT'>0
- QUIT
- Begin DoDot:1
- +14 ; result doesn't match
- IF $PIECE(^YTT(601.92,YSRSLT,0),U,2)'=YSADM
- QUIT
- +15 SET DIK="^YTT(601.92,"
- SET DA=YSRSLT
- DO ^DIK
- End DoDot:1
- +16 ; publish delete event for admin if it was completed
- +17 IF YSEVCPLT
- DO DELETE^YTQEVNT(YSADM,YSEVDFN,YSEVTST,"webdel")
- +18 QUIT