YTQRIS ;SLC/KCM - Instrument Selection RPC's ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,141,182,240**;Dec 30, 1994;Build 10
;
; External Reference ICR#
; ------------------ -----
; ^VA(200) 1234
; ^XUSEC 10076
; DIK 10013
; DIQ 2056
; VADPT 10061
; XLFDT 10103
; XPDKEY 1367
; XPDMENU 1157
; XQCHK 10078
; XUAF4 2171
; XUSER 2343
;
NXT() ; return next RSP index
S YSIDX=$G(YSIDX)+1
Q YSIDX
;
ACTIVE(RSP,DFN,ORDBY) ; return list of active assignments
; return displayText^pin^name|adminId^name|adminId^...
; 1 2 3 4 n...
N PTADMIN,YSIDX
D ASSIGN(DFN) ; this has to be first to build PTADMIN
D INCPLT(DFN,ORDBY)
Q
ACTIVE1(RSP,DFN,ORDBY,TESTNM) ; return active assignments for one instrument
; return dfn[1]^ptNm[2]^assignmentId[3]^adminId[4]^ordById[5]^ordByNm[6]^
; dtGiven[7]^dtSaved[8]^locId[9]^locNm[10]
N PTADMIN,YSIDX
D ASSIGN1(DFN,TESTNM) ; this has to be first to build PTADMIN
D INCPLT1(DFN,ORDBY,TESTNM)
Q
ASSIGN(DFN) ; active patient-entry assignments
; expects RSP,YSIDX,PTADMIN
Q:'DFN
N ASMT,PRV
S PRV=0 F S PRV=$O(^XTMP("YTQASMT-INDEX","AD",DFN,PRV)) Q:'PRV D
. S ASMT=0 F S ASMT=$O(^XTMP("YTQASMT-INDEX","AD",DFN,PRV,ASMT)) Q:'ASMT D
. . N DATA,NAMES,TEST,ADMIN,X,I,J
. . I '$D(^XTMP("YTQASMT-SET-"_ASMT,0)) D Q ; assignment must have expired
. . . N OK S OK=$$DELIDX^YTQRQAD1(ASMT,DFN,PRV)
. . M DATA=^XTMP("YTQASMT-SET-"_ASMT,1)
. . I DATA("entryMode")="staff" Q ; only show patient entered
. . I $$ANYCAT^YTQRCAT(ASMT) Q ; web only for CAT/CAD
. . S (X,NAMES)="",J=2 ; J is piece offset for test name
. . S I=0 F S I=$O(DATA("instruments",I)) Q:'I D
. . . I $L(NAMES) S NAMES=NAMES_","
. . . S NAMES=NAMES_DATA("instruments",I,"name")
. . . S TEST=DATA("instruments",I,"name")
. . . S ADMIN=+$G(DATA("instruments",I,"adminId"))
. . . S TEST=TEST_"|"_ADMIN
. . . I ADMIN S PTADMIN(ADMIN)="" ; avoid including with staff
. . . S J=J+1,$P(X,U,J)=TEST ; 3rd, 4th, etc. pieces of X
. . S $P(X,U,1)=NAMES
. . S $P(X,U,2)=ASMT
. . S RSP($$NXT)=X
Q
ASSIGN1(DFN,TESTNM) ; active patient-entry assignments for 1 instrument
; expects RSP,YSIDX,PTADMIN
Q:'DFN
N ASMT,PRV,PRVNM,EXTRA
S PRV=0 F S PRV=$O(^XTMP("YTQASMT-INDEX","AD",DFN,PRV)) Q:'PRV D
. S ASMT=0 F S ASMT=$O(^XTMP("YTQASMT-INDEX","AD",DFN,PRV,ASMT)) Q:'ASMT D
. . N DATA,NAMES,TEST,ADMIN,X,X0,I
. . I '$D(^XTMP("YTQASMT-SET-"_ASMT,0)) D Q ; assignment must have expired
. . . N OK S OK=$$DELIDX^YTQRQAD1(ASMT,DFN,PRV)
. . M DATA=^XTMP("YTQASMT-SET-"_ASMT,1)
. . I DATA("entryMode")="staff" Q ; only show patient entered
. . I $$ANYCAT^YTQRCAT(ASMT) Q ; web only for CAT/CAD
. . S X="",EXTRA=""
. . S I=0 F S I=$O(DATA("instruments",I)) Q:'I D
. . . I DATA("instruments",I,"name")'=TESTNM D Q
. . . . S EXTRA=$S($L(EXTRA)=0:"+",1:",")_DATA("instruments",I,"name")
. . . S PRVNM=$$GET1^DIQ(200,+PRV_",",.01)
. . . S ADMIN=+$G(DATA("instruments",I,"adminId"))
. . . I ADMIN S PTADMIN(ADMIN)="" ; avoid including with staff
. . . S X=DFN_U_U_ASMT_U_ADMIN_U_PRV_U_PRVNM_"^^^^^^" ; need all pieces
. . . S $P(X,U,2)=$$GET1^DIQ(2,+DFN_",",.01)
. . . I ADMIN S X0=^YTT(601.84,ADMIN,0) D
. . . . I +$P(X0,U,4) S $P(X,U,7)=$P(X0,U,4)
. . . . I +$P(X0,U,5) S $P(X,U,8)=$P(X0,U,5)
. . . . I +$P(X0,U,11) S $P(X,U,9)=$P(X0,U,11)
. . . . I +$P(X0,U,11) S $P(X,U,10)=$$GET1^DIQ(44,+$P(X0,U,11)_",",.01)
. . I $L(X) S $P(X,U,11)=EXTRA S RSP($$NXT)=X
Q
INCPLT(DFN,ORDBY) ; add list of incomplete instruments for DFN and ORDBY
; expects RSP,YSIDX,PTADMIN
Q:'ORDBY Q:'DFN
N I,X,YS,YSDATA,YSNOW,YSDOW,OFFSET,YSDTSAV,YSRSTRT
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 $E($P(YSDATA(I),U,2),1,7)="CAT-CAD" QUIT ; web only
. I $D(PTADMIN(+YSDATA(I))) QUIT ; skip pt assigned
. 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 X=$P(YSDATA(I),U,2)_" ("_$$FMTE^XLFDT(YSDTSAV,"2Z")_")" ; test (date)
. S $P(X,U,2)=0 ; staff entry -- no PIN
. S $P(X,U,3)=$P(YSDATA(I),U,2)_"|"_$P(YSDATA(I),U) ; instrumentName|adminId
. S RSP($$NXT)=X
Q
INCPLT1(DFN,ORDBY,TESTNM) ; add list of incomplete instruments for DFN and ORDBY
; expects RSP,YSIDX,PTADMIN
Q:'ORDBY Q:'DFN
N I,X,YS,YSDATA,YSNOW,YSDOW,OFFSET,YSDTSAV,YSRSTRT
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 $E($P(YSDATA(I),U,2),1,7)="CAT-CAD" QUIT ; web only
. I $D(PTADMIN(+YSDATA(I))) QUIT ; skip pt-entry assigned
. I $P(YSDATA(I),U,5)'=ORDBY QUIT ; not same orderedBy
. I $P(YSDATA(I),U,2)'=TESTNM QUIT ; only want certain test
. 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 X=DFN_U_U_0_U_$P(YSDATA(I),U)_U_ORDBY_"^^^^^^^" ; exe needs all pieces
. S $P(X,U,2)=$$GET1^DIQ(2,DFN_",",.01)
. I +ORDBY S $P(X,U,6)=$$GET1^DIQ(200,+ORDBY_",",.01)
. I +$P(YSDATA(I),U,3) S $P(X,U,7)=$P(YSDATA(I),U,3) ; date given
. I +$P(YSDATA(I),U,4) S $P(X,U,8)=$P(YSDATA(I),U,4) ; date saved
. I +$P(YSDATA(I),U,14) S $P(X,U,9)=$P(YSDATA(I),U,14) ; location
. I +$P(YSDATA(I),U,14) S $P(X,U,10)=$$GET1^DIQ(44,+$P(X,U,9)_",",.01)
. S RSP($$NXT)=X
Q
PTINFO(RSP,DFN) ; return display info for patient
N VA,VADM,VAERR
D DEM^VADPT
I VAERR S RSP(1)="Error Encountered" QUIT
S RSP(1)=VADM(1)_U_"xxx-xx-"_VA("BID")
Q
USERINFO(RSP) ; return user info
S RSP(1)=DUZ_U_$$NAME^XUSER(DUZ,"F")_U_$$STA^XUAF4(DUZ(2))
Q
DESCRIBE(RSP,PIN,ADMINS) ; describe an assignment
; expects RSP
S RSP(1)="descriptive text will go here"
N YSIDX,DATA,EXPDT,I,IEN,X0
S YSIDX=0
I +PIN D
. M DATA=^XTMP("YTQASMT-SET-"_PIN,1)
. S EXPDT=$P($G(^XTMP("YTQASMT-SET-"_PIN,0)),U)
. S:EXPDT EXPDT=$$FMTE^XLFDT(EXPDT,"2Z")
. S RSP($$NXT)="PIN: "_PIN_" (expires "_EXPDT_")"
. S RSP($$NXT)="Ordered By: "_$$GET1^DIQ(200,+$G(DATA("orderedBy"))_",",.01)
I YSIDX>0 S RSP($$NXT)=" "
F I=1:1:$L(ADMINS,",") D
. S IEN=+$P(ADMINS,",",I) Q:'IEN Q:'$D(^YTT(601.84,IEN,0))
. S X0=^YTT(601.84,IEN,0)
. S RSP($$NXT)=$P($G(^YTT(601.71,+$P(X0,U,3),0)),U)
. I 'PIN S RSP($$NXT)=" Ordered By: "_$$GET1^DIQ(200,+$P(X0,U,6)_",",.01)
. S RSP($$NXT)=" Date/Time Begun: "_$$FMTE^XLFDT($P(X0,U,4),"2PZ")
. S RSP($$NXT)=" Date/Time Last Saved: "_$$FMTE^XLFDT($P(X0,U,5),"2PZ")
. S RSP($$NXT)=" Number of Questions Answered: "_$P(X0,U,10)
. I +PIN S RSP($$NXT)=" Completed: "_$S($P(X0,U,9)="Y":"Yes",1:"No")
Q
VALTSTS(RSP,MODE,ORDBY,TESTS) ; validate a set of instruments
N MSG,I,IEN,TEST,APRV
S MSG=""
F I=1:1:$L(TESTS,",") S TEST=$P(TESTS,",",I) I $L(TEST) D Q:$L(MSG)
. S IEN=$O(^YTT(601.71,"B",TEST,0)) I 'IEN D Q
. . S MSG=TEST_" is not found on the server."
. S APRV=$P($G(^YTT(601.71,IEN,1)),U,6) S:+APRV APRV=$$LKUP^XPDKEY(APRV)
. I $L(APRV),'$D(^XUSEC(APRV,ORDBY)) D Q
. . S MSG="Insufficient privilege to administer "_TEST
. I MODE="patient",$P($G(^YTT(601.71,IEN,9)),U,4)="Y" D Q
. . S MSG=TEST_"is identified as 'staff-entry only'"
S RSP(0)=$S($L(MSG):MSG,1:"OK")
Q
DELASMT(RSP,ATYP,ANID) ; delete an assignment or incomplete admin
I ATYP="A" D QUIT
. N YTQRERRS
. K ^TMP("YTQRERRS",$J)
. D DELASMT1^YTQRQAD1(ANID)
. S RSP(1)="ok" I $G(YTQRERRS) S RSP(1)=$$ERRTXT^YTQRUTL
. K ^TMP("YTQRERRS",$J)
I ATYP="I" D QUIT
. S RSP(1)="Deletion of instruments that have been started is not allowed."
S RSP(1)="Unrecognized Item Type"
Q
DELASMT2(RSP,PIN,ADMINS) ; delete an assignment or incomplete admin
N I,X0,IEN,MGR,ERRMSG
S MGR=$$ISMGR,ERRMSG=""
;
; delete the individual admin entries first
F I=1:1:$L(ADMINS,",") D Q:$L(ERRMSG)
. S IEN=+$P(ADMINS,",",I) Q:'IEN Q:'$D(^YTT(601.84,IEN,0))
. S X0=^YTT(601.84,IEN,0)
. I $P(X0,U,9)="Y" D Q
. . S ERRMSG="Deletion not allowed: status is 'completed'"
. I MGR!(DUZ=$P(X0,U,6))!(DUZ=$P(X0,U,7)) D DELADMIN(IEN) I 1
. E S ERRMSG="Deletion not allowed: insufficient privilege"
I $L(ERRMSG) S RSP(1)=ERRMSG Q
S RSP(1)="ok"
;
; now delete the assignment
I 'PIN QUIT
N YTQRERRS
K ^TMP("YTQRERRS",$J)
D DELASMT1^YTQRQAD1(PIN)
I $G(YTQRERRS) S RSP(1)=$$ERRTXT^YTQRUTL
K ^TMP("YTQRERRS",$J)
Q
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
;
DELADMIN(YSADM) ; delete an admin & associated records
N 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,"seldel")
Q
ACTCAT(RSP) ; return a list of active categories
N TEST,CAT,X0,NM,SORTED
S TEST=0 F S TEST=$O(^YTT(601.71,TEST)) Q:'TEST D
. I $P($G(^YTT(601.71,TEST,2)),U,2)'="Y" QUIT ; not active
. I $E($P(^YTT(601.71,TEST,0),U),1,4)="CAT-" QUIT
. I $E($P(^YTT(601.71,TEST,0),U),1,4)="CAD-" QUIT
. I $E($P(^YTT(601.71,TEST,0),U),1,7)="CAT-CAD" QUIT
. S CAT=0 F S CAT=$O(^YTT(601.71,TEST,10,CAT)) Q:'CAT D
. . S X0=^YTT(601.71,TEST,10,CAT,0)
. . S NM=^YTT(601.97,+X0,0)
. . S SORTED(NM)=""
S NM="" F S NM=$O(SORTED(NM)) Q:'$L(NM) S RSP($$NXT)=NM
Q
INBYCAT(RSP,NM) ; return a list of instruments by category
N TEST,CAT,SORTED,TESTNM
S CAT=$O(^YTT(601.97,"B",NM,0)) Q:'CAT
S TEST=0 F S TEST=$O(^YTT(601.71,TEST)) Q:'TEST D
. I $P($G(^YTT(601.71,TEST,2)),U,2)'="Y" QUIT ; not active
. I '$D(^YTT(601.71,TEST,10,"B",CAT)) QUIT ; not in category
. S TESTNM=$P(^YTT(601.71,TEST,0),U)
. I $E(TESTNM,1,4)="CAT-" QUIT ; CAT only in MHA-Web
. I $E(TESTNM,1,4)="CAD-" QUIT ; CAD only in MHA-Web
. S SORTED($P(^YTT(601.71,TEST,0),U))=""
S RSP(1)="Root="
S NM="" F S NM=$O(SORTED(NM)) Q:'$L(NM) S RSP(1)=RSP(1)_NM_U
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRIS 11733 printed Sep 23, 2025@19:54:57 Page 2
YTQRIS ;SLC/KCM - Instrument Selection RPC's ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,141,182,240**;Dec 30, 1994;Build 10
+2 ;
+3 ; External Reference ICR#
+4 ; ------------------ -----
+5 ; ^VA(200) 1234
+6 ; ^XUSEC 10076
+7 ; DIK 10013
+8 ; DIQ 2056
+9 ; VADPT 10061
+10 ; XLFDT 10103
+11 ; XPDKEY 1367
+12 ; XPDMENU 1157
+13 ; XQCHK 10078
+14 ; XUAF4 2171
+15 ; XUSER 2343
+16 ;
NXT() ; return next RSP index
+1 SET YSIDX=$GET(YSIDX)+1
+2 QUIT YSIDX
+3 ;
ACTIVE(RSP,DFN,ORDBY) ; return list of active assignments
+1 ; return displayText^pin^name|adminId^name|adminId^...
+2 ; 1 2 3 4 n...
+3 NEW PTADMIN,YSIDX
+4 ; this has to be first to build PTADMIN
DO ASSIGN(DFN)
+5 DO INCPLT(DFN,ORDBY)
+6 QUIT
ACTIVE1(RSP,DFN,ORDBY,TESTNM) ; return active assignments for one instrument
+1 ; return dfn[1]^ptNm[2]^assignmentId[3]^adminId[4]^ordById[5]^ordByNm[6]^
+2 ; dtGiven[7]^dtSaved[8]^locId[9]^locNm[10]
+3 NEW PTADMIN,YSIDX
+4 ; this has to be first to build PTADMIN
DO ASSIGN1(DFN,TESTNM)
+5 DO INCPLT1(DFN,ORDBY,TESTNM)
+6 QUIT
ASSIGN(DFN) ; active patient-entry assignments
+1 ; expects RSP,YSIDX,PTADMIN
+2 if 'DFN
QUIT
+3 NEW ASMT,PRV
+4 SET PRV=0
FOR
SET PRV=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,PRV))
if 'PRV
QUIT
Begin DoDot:1
+5 SET ASMT=0
FOR
SET ASMT=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,PRV,ASMT))
if 'ASMT
QUIT
Begin DoDot:2
+6 NEW DATA,NAMES,TEST,ADMIN,X,I,J
+7 ; assignment must have expired
IF '$DATA(^XTMP("YTQASMT-SET-"_ASMT,0))
Begin DoDot:3
+8 NEW OK
SET OK=$$DELIDX^YTQRQAD1(ASMT,DFN,PRV)
End DoDot:3
QUIT
+9 MERGE DATA=^XTMP("YTQASMT-SET-"_ASMT,1)
+10 ; only show patient entered
IF DATA("entryMode")="staff"
QUIT
+11 ; web only for CAT/CAD
IF $$ANYCAT^YTQRCAT(ASMT)
QUIT
+12 ; J is piece offset for test name
SET (X,NAMES)=""
SET J=2
+13 SET I=0
FOR
SET I=$ORDER(DATA("instruments",I))
if 'I
QUIT
Begin DoDot:3
+14 IF $LENGTH(NAMES)
SET NAMES=NAMES_","
+15 SET NAMES=NAMES_DATA("instruments",I,"name")
+16 SET TEST=DATA("instruments",I,"name")
+17 SET ADMIN=+$GET(DATA("instruments",I,"adminId"))
+18 SET TEST=TEST_"|"_ADMIN
+19 ; avoid including with staff
IF ADMIN
SET PTADMIN(ADMIN)=""
+20 ; 3rd, 4th, etc. pieces of X
SET J=J+1
SET $PIECE(X,U,J)=TEST
End DoDot:3
+21 SET $PIECE(X,U,1)=NAMES
+22 SET $PIECE(X,U,2)=ASMT
+23 SET RSP($$NXT)=X
End DoDot:2
End DoDot:1
+24 QUIT
ASSIGN1(DFN,TESTNM) ; active patient-entry assignments for 1 instrument
+1 ; expects RSP,YSIDX,PTADMIN
+2 if 'DFN
QUIT
+3 NEW ASMT,PRV,PRVNM,EXTRA
+4 SET PRV=0
FOR
SET PRV=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,PRV))
if 'PRV
QUIT
Begin DoDot:1
+5 SET ASMT=0
FOR
SET ASMT=$ORDER(^XTMP("YTQASMT-INDEX","AD",DFN,PRV,ASMT))
if 'ASMT
QUIT
Begin DoDot:2
+6 NEW DATA,NAMES,TEST,ADMIN,X,X0,I
+7 ; assignment must have expired
IF '$DATA(^XTMP("YTQASMT-SET-"_ASMT,0))
Begin DoDot:3
+8 NEW OK
SET OK=$$DELIDX^YTQRQAD1(ASMT,DFN,PRV)
End DoDot:3
QUIT
+9 MERGE DATA=^XTMP("YTQASMT-SET-"_ASMT,1)
+10 ; only show patient entered
IF DATA("entryMode")="staff"
QUIT
+11 ; web only for CAT/CAD
IF $$ANYCAT^YTQRCAT(ASMT)
QUIT
+12 SET X=""
SET EXTRA=""
+13 SET I=0
FOR
SET I=$ORDER(DATA("instruments",I))
if 'I
QUIT
Begin DoDot:3
+14 IF DATA("instruments",I,"name")'=TESTNM
Begin DoDot:4
+15 SET EXTRA=$SELECT($LENGTH(EXTRA)=0:"+",1:",")_DATA("instruments",I,"name")
End DoDot:4
QUIT
+16 SET PRVNM=$$GET1^DIQ(200,+PRV_",",.01)
+17 SET ADMIN=+$GET(DATA("instruments",I,"adminId"))
+18 ; avoid including with staff
IF ADMIN
SET PTADMIN(ADMIN)=""
+19 ; need all pieces
SET X=DFN_U_U_ASMT_U_ADMIN_U_PRV_U_PRVNM_"^^^^^^"
+20 SET $PIECE(X,U,2)=$$GET1^DIQ(2,+DFN_",",.01)
+21 IF ADMIN
SET X0=^YTT(601.84,ADMIN,0)
Begin DoDot:4
+22 IF +$PIECE(X0,U,4)
SET $PIECE(X,U,7)=$PIECE(X0,U,4)
+23 IF +$PIECE(X0,U,5)
SET $PIECE(X,U,8)=$PIECE(X0,U,5)
+24 IF +$PIECE(X0,U,11)
SET $PIECE(X,U,9)=$PIECE(X0,U,11)
+25 IF +$PIECE(X0,U,11)
SET $PIECE(X,U,10)=$$GET1^DIQ(44,+$PIECE(X0,U,11)_",",.01)
End DoDot:4
End DoDot:3
+26 IF $LENGTH(X)
SET $PIECE(X,U,11)=EXTRA
SET RSP($$NXT)=X
End DoDot:2
End DoDot:1
+27 QUIT
INCPLT(DFN,ORDBY) ; add list of incomplete instruments for DFN and ORDBY
+1 ; expects RSP,YSIDX,PTADMIN
+2 if 'ORDBY
QUIT
if 'DFN
QUIT
+3 NEW I,X,YS,YSDATA,YSNOW,YSDOW,OFFSET,YSDTSAV,YSRSTRT
+4 SET YSNOW=$$NOW^XLFDT
+5 SET YSDOW=$$DOW^XLFDT(YSNOW)
+6 SET OFFSET=$SELECT(YSDOW=5:2,YSDOW=6:1,1:0)
+7 SET YS("DFN")=DFN
SET YS("COMPLETE")="N"
+8 DO ADMINS^YTQAPI5(.YSDATA,.YS)
+9 SET I=2
FOR
SET I=$ORDER(YSDATA(I))
if 'I
QUIT
Begin DoDot:1
+10 ; web only
IF $EXTRACT($PIECE(YSDATA(I),U,2),1,7)="CAT-CAD"
QUIT
+11 ; skip pt assigned
IF $DATA(PTADMIN(+YSDATA(I)))
QUIT
+12 ; not same orderedBy
IF $PIECE(YSDATA(I),U,5)'=ORDBY
QUIT
+13 ; no date, bad entry
SET YSDTSAV=$PIECE(YSDATA(I),U,4)
IF 'YSDTSAV
QUIT
+14 ; account for weekends
SET YSRSTRT=$PIECE(YSDATA(I),U,15)
if 'YSRSTRT
SET YSRSTRT=2
+15 ; always restartable is -1, comparing full 24 hour periods so use seconds
+16 IF (YSRSTRT'=-1)
IF $$FMDIFF^XLFDT(YSNOW,YSDTSAV,2)>((YSRSTRT+OFFSET)*86400)
QUIT
+17 ; test (date)
SET X=$PIECE(YSDATA(I),U,2)_" ("_$$FMTE^XLFDT(YSDTSAV,"2Z")_")"
+18 ; staff entry -- no PIN
SET $PIECE(X,U,2)=0
+19 ; instrumentName|adminId
SET $PIECE(X,U,3)=$PIECE(YSDATA(I),U,2)_"|"_$PIECE(YSDATA(I),U)
+20 SET RSP($$NXT)=X
End DoDot:1
+21 QUIT
INCPLT1(DFN,ORDBY,TESTNM) ; add list of incomplete instruments for DFN and ORDBY
+1 ; expects RSP,YSIDX,PTADMIN
+2 if 'ORDBY
QUIT
if 'DFN
QUIT
+3 NEW I,X,YS,YSDATA,YSNOW,YSDOW,OFFSET,YSDTSAV,YSRSTRT
+4 SET YSNOW=$$NOW^XLFDT
+5 SET YSDOW=$$DOW^XLFDT(YSNOW)
+6 SET OFFSET=$SELECT(YSDOW=5:2,YSDOW=6:1,1:0)
+7 SET YS("DFN")=DFN
SET YS("COMPLETE")="N"
+8 DO ADMINS^YTQAPI5(.YSDATA,.YS)
+9 SET I=2
FOR
SET I=$ORDER(YSDATA(I))
if 'I
QUIT
Begin DoDot:1
+10 ; web only
IF $EXTRACT($PIECE(YSDATA(I),U,2),1,7)="CAT-CAD"
QUIT
+11 ; skip pt-entry assigned
IF $DATA(PTADMIN(+YSDATA(I)))
QUIT
+12 ; not same orderedBy
IF $PIECE(YSDATA(I),U,5)'=ORDBY
QUIT
+13 ; only want certain test
IF $PIECE(YSDATA(I),U,2)'=TESTNM
QUIT
+14 ; no date, bad entry
SET YSDTSAV=$PIECE(YSDATA(I),U,4)
IF 'YSDTSAV
QUIT
+15 ; account for weekends
SET YSRSTRT=$PIECE(YSDATA(I),U,15)
if 'YSRSTRT
SET YSRSTRT=2
+16 ; always restartable is -1, comparing full 24 hour periods so use seconds
+17 IF (YSRSTRT'=-1)
IF $$FMDIFF^XLFDT(YSNOW,YSDTSAV,2)>((YSRSTRT+OFFSET)*86400)
QUIT
+18 ; exe needs all pieces
SET X=DFN_U_U_0_U_$PIECE(YSDATA(I),U)_U_ORDBY_"^^^^^^^"
+19 SET $PIECE(X,U,2)=$$GET1^DIQ(2,DFN_",",.01)
+20 IF +ORDBY
SET $PIECE(X,U,6)=$$GET1^DIQ(200,+ORDBY_",",.01)
+21 ; date given
IF +$PIECE(YSDATA(I),U,3)
SET $PIECE(X,U,7)=$PIECE(YSDATA(I),U,3)
+22 ; date saved
IF +$PIECE(YSDATA(I),U,4)
SET $PIECE(X,U,8)=$PIECE(YSDATA(I),U,4)
+23 ; location
IF +$PIECE(YSDATA(I),U,14)
SET $PIECE(X,U,9)=$PIECE(YSDATA(I),U,14)
+24 IF +$PIECE(YSDATA(I),U,14)
SET $PIECE(X,U,10)=$$GET1^DIQ(44,+$PIECE(X,U,9)_",",.01)
+25 SET RSP($$NXT)=X
End DoDot:1
+26 QUIT
PTINFO(RSP,DFN) ; return display info for patient
+1 NEW VA,VADM,VAERR
+2 DO DEM^VADPT
+3 IF VAERR
SET RSP(1)="Error Encountered"
QUIT
+4 SET RSP(1)=VADM(1)_U_"xxx-xx-"_VA("BID")
+5 QUIT
USERINFO(RSP) ; return user info
+1 SET RSP(1)=DUZ_U_$$NAME^XUSER(DUZ,"F")_U_$$STA^XUAF4(DUZ(2))
+2 QUIT
DESCRIBE(RSP,PIN,ADMINS) ; describe an assignment
+1 ; expects RSP
+2 SET RSP(1)="descriptive text will go here"
+3 NEW YSIDX,DATA,EXPDT,I,IEN,X0
+4 SET YSIDX=0
+5 IF +PIN
Begin DoDot:1
+6 MERGE DATA=^XTMP("YTQASMT-SET-"_PIN,1)
+7 SET EXPDT=$PIECE($GET(^XTMP("YTQASMT-SET-"_PIN,0)),U)
+8 if EXPDT
SET EXPDT=$$FMTE^XLFDT(EXPDT,"2Z")
+9 SET RSP($$NXT)="PIN: "_PIN_" (expires "_EXPDT_")"
+10 SET RSP($$NXT)="Ordered By: "_$$GET1^DIQ(200,+$GET(DATA("orderedBy"))_",",.01)
End DoDot:1
+11 IF YSIDX>0
SET RSP($$NXT)=" "
+12 FOR I=1:1:$LENGTH(ADMINS,",")
Begin DoDot:1
+13 SET IEN=+$PIECE(ADMINS,",",I)
if 'IEN
QUIT
if '$DATA(^YTT(601.84,IEN,0))
QUIT
+14 SET X0=^YTT(601.84,IEN,0)
+15 SET RSP($$NXT)=$P($GET(^YTT(601.71,+$PIECE(X0,U,3),0)),U)
+16 IF 'PIN
SET RSP($$NXT)=" Ordered By: "_$$GET1^DIQ(200,+$PIECE(X0,U,6)_",",.01)
+17 SET RSP($$NXT)=" Date/Time Begun: "_$$FMTE^XLFDT($PIECE(X0,U,4),"2PZ")
+18 SET RSP($$NXT)=" Date/Time Last Saved: "_$$FMTE^XLFDT($PIECE(X0,U,5),"2PZ")
+19 SET RSP($$NXT)=" Number of Questions Answered: "_$P(X0,U,10)
+20 IF +PIN
SET RSP($$NXT)=" Completed: "_$S($PIECE(X0,U,9)="Y":"Yes",1:"No")
End DoDot:1
+21 QUIT
VALTSTS(RSP,MODE,ORDBY,TESTS) ; validate a set of instruments
+1 NEW MSG,I,IEN,TEST,APRV
+2 SET MSG=""
+3 FOR I=1:1:$LENGTH(TESTS,",")
SET TEST=$PIECE(TESTS,",",I)
IF $LENGTH(TEST)
Begin DoDot:1
+4 SET IEN=$ORDER(^YTT(601.71,"B",TEST,0))
IF 'IEN
Begin DoDot:2
+5 SET MSG=TEST_" is not found on the server."
End DoDot:2
QUIT
+6 SET APRV=$PIECE($GET(^YTT(601.71,IEN,1)),U,6)
if +APRV
SET APRV=$$LKUP^XPDKEY(APRV)
+7 IF $LENGTH(APRV)
IF '$DATA(^XUSEC(APRV,ORDBY))
Begin DoDot:2
+8 SET MSG="Insufficient privilege to administer "_TEST
End DoDot:2
QUIT
+9 IF MODE="patient"
IF $PIECE($GET(^YTT(601.71,IEN,9)),U,4)="Y"
Begin DoDot:2
+10 SET MSG=TEST_"is identified as 'staff-entry only'"
End DoDot:2
QUIT
End DoDot:1
if $LENGTH(MSG)
QUIT
+11 SET RSP(0)=$SELECT($LENGTH(MSG):MSG,1:"OK")
+12 QUIT
DELASMT(RSP,ATYP,ANID) ; delete an assignment or incomplete admin
+1 IF ATYP="A"
Begin DoDot:1
+2 NEW YTQRERRS
+3 KILL ^TMP("YTQRERRS",$JOB)
+4 DO DELASMT1^YTQRQAD1(ANID)
+5 SET RSP(1)="ok"
IF $GET(YTQRERRS)
SET RSP(1)=$$ERRTXT^YTQRUTL
+6 KILL ^TMP("YTQRERRS",$JOB)
End DoDot:1
QUIT
+7 IF ATYP="I"
Begin DoDot:1
+8 SET RSP(1)="Deletion of instruments that have been started is not allowed."
End DoDot:1
QUIT
+9 SET RSP(1)="Unrecognized Item Type"
+10 QUIT
DELASMT2(RSP,PIN,ADMINS) ; delete an assignment or incomplete admin
+1 NEW I,X0,IEN,MGR,ERRMSG
+2 SET MGR=$$ISMGR
SET ERRMSG=""
+3 ;
+4 ; delete the individual admin entries first
+5 FOR I=1:1:$LENGTH(ADMINS,",")
Begin DoDot:1
+6 SET IEN=+$PIECE(ADMINS,",",I)
if 'IEN
QUIT
if '$DATA(^YTT(601.84,IEN,0))
QUIT
+7 SET X0=^YTT(601.84,IEN,0)
+8 IF $PIECE(X0,U,9)="Y"
Begin DoDot:2
+9 SET ERRMSG="Deletion not allowed: status is 'completed'"
End DoDot:2
QUIT
+10 IF MGR!(DUZ=$PIECE(X0,U,6))!(DUZ=$PIECE(X0,U,7))
DO DELADMIN(IEN)
IF 1
+11 IF '$TEST
SET ERRMSG="Deletion not allowed: insufficient privilege"
End DoDot:1
if $LENGTH(ERRMSG)
QUIT
+12 IF $LENGTH(ERRMSG)
SET RSP(1)=ERRMSG
QUIT
+13 SET RSP(1)="ok"
+14 ;
+15 ; now delete the assignment
+16 IF 'PIN
QUIT
+17 NEW YTQRERRS
+18 KILL ^TMP("YTQRERRS",$JOB)
+19 DO DELASMT1^YTQRQAD1(PIN)
+20 IF $GET(YTQRERRS)
SET RSP(1)=$$ERRTXT^YTQRUTL
+21 KILL ^TMP("YTQRERRS",$JOB)
+22 QUIT
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 ;
DELADMIN(YSADM) ; delete an admin & associated records
+1 NEW 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,"seldel")
+18 QUIT
ACTCAT(RSP) ; return a list of active categories
+1 NEW TEST,CAT,X0,NM,SORTED
+2 SET TEST=0
FOR
SET TEST=$ORDER(^YTT(601.71,TEST))
if 'TEST
QUIT
Begin DoDot:1
+3 ; not active
IF $PIECE($GET(^YTT(601.71,TEST,2)),U,2)'="Y"
QUIT
+4 IF $EXTRACT($PIECE(^YTT(601.71,TEST,0),U),1,4)="CAT-"
QUIT
+5 IF $EXTRACT($PIECE(^YTT(601.71,TEST,0),U),1,4)="CAD-"
QUIT
+6 IF $EXTRACT($PIECE(^YTT(601.71,TEST,0),U),1,7)="CAT-CAD"
QUIT
+7 SET CAT=0
FOR
SET CAT=$ORDER(^YTT(601.71,TEST,10,CAT))
if 'CAT
QUIT
Begin DoDot:2
+8 SET X0=^YTT(601.71,TEST,10,CAT,0)
+9 SET NM=^YTT(601.97,+X0,0)
+10 SET SORTED(NM)=""
End DoDot:2
End DoDot:1
+11 SET NM=""
FOR
SET NM=$ORDER(SORTED(NM))
if '$LENGTH(NM)
QUIT
SET RSP($$NXT)=NM
+12 QUIT
INBYCAT(RSP,NM) ; return a list of instruments by category
+1 NEW TEST,CAT,SORTED,TESTNM
+2 SET CAT=$ORDER(^YTT(601.97,"B",NM,0))
if 'CAT
QUIT
+3 SET TEST=0
FOR
SET TEST=$ORDER(^YTT(601.71,TEST))
if 'TEST
QUIT
Begin DoDot:1
+4 ; not active
IF $PIECE($GET(^YTT(601.71,TEST,2)),U,2)'="Y"
QUIT
+5 ; not in category
IF '$DATA(^YTT(601.71,TEST,10,"B",CAT))
QUIT
+6 SET TESTNM=$PIECE(^YTT(601.71,TEST,0),U)
+7 ; CAT only in MHA-Web
IF $EXTRACT(TESTNM,1,4)="CAT-"
QUIT
+8 ; CAD only in MHA-Web
IF $EXTRACT(TESTNM,1,4)="CAD-"
QUIT
+9 SET SORTED($PIECE(^YTT(601.71,TEST,0),U))=""
End DoDot:1
+10 SET RSP(1)="Root="
+11 SET NM=""
FOR
SET NM=$ORDER(SORTED(NM))
if '$LENGTH(NM)
QUIT
SET RSP(1)=RSP(1)_NM_U
+12 QUIT
