YTQRQAD6 ;SLC/LLB - Determine High Risk Flagging ; 07/15/2020
;;5.01;MENTAL HEALTH;**158,181,187,204**;Dec 30, 1994;Build 18
;
; The assumption is made that variable DFN will exist prior to calling this routine.
;
FLAG(DFN,INST,HRR,PR) ; ROUTINE to calculate Positive response and High Risk flagging
; ICR #4290 READ OF CLINICAL REMINDER INDEX (PXRMINDX)
; DFN: IEN to Patient file (#2)
; INST: Instriment name in MH TESTS AND SURVEYS file (#601.71)
; INSTIEN: IEN to instrument in MH TESTS AND SURVEYS file (#601.71)
; HRR: High Risk Requirement
; # score greater than #
; A# any question with a score >#
; I9 Positive I9 question
; Y1,2,3,n. Comma delimited list of question numbers. A yes to any is HR
; YA Yes to any question
; G3^0,5^1,q^n. Comma delimited list of question#^Value for question response Greater Than Value
; T#p Can be added to any HRR parameter where # is a positive integer and
; p is the time period M months, W weeks, D day. This will be treated as
; the most recent administration of the instrument but only if the
; Ex: "Y,1,2,3,T6M" indicates Yes to Q 1,2, or 3 within the last 6
; months.
; Ex: "Y,1,2,3,T6M-I9" is the same as the previous example except that
; a positive I9, without regard to time frame, triggers High Risk.
; HRR parameters can be combined by adding "-" between them indicating an "or"
; such as "Y,3,4,5,8-I9"
; PR: Positive Response threshold, Score greater than number passed in PR.
; Based solely on total score. Ex: 8 indicating any score greater than 8.
; YSFLAG: Will be 0 for no risk
; 1 for Positive Response
; 2 for High Risk
; 3 for Both Positive response & High Risk
; The field SUICIDE RISK (#16) in the MH ADMINISTRATION file (#601.84) will be
; populated with the result.
N DATE,ADMID,YSFLAG,YS,SI,MULT,INSTIEN,YSLIM,YSCORE
S SI=0
I 'DFN D SETERROR^YTQRUTL(404,"Not Found: No patient passed. Cannot continue.") Q
I INST="" D SETERROR^YTQRUTL(404,"Not Found: No instrument passed. Cannot continue.") Q
S YSFLAG=0
S INSTIEN=$O(^YTT(601.71,"B",INST,0)) Q:'$D(^PXRMINDX(601.84,"PI",DFN,INSTIEN))
S DATE=""
; Get date of administration most recent to oldest
F S DATE=$O(^PXRMINDX(601.84,"PI",DFN,INSTIEN,DATE),-1) Q:DATE="" D FLAG2
Q
;
FLAG2 ;
N X,YSHRT,CURFLG,AGE
S ADMID=$O(^PXRMINDX(601.84,"PI",DFN,INSTIEN,DATE,"")) ;IEN to file 601.84
; NOTE: The ARC index is only updated for completed administrations.
; A separate check for Administration COMPLETE is not necessary
S CURFLG=$P(^YTT(601.84,ADMID,0),U,14)
I CURFLG=0!(CURFLG=9) Q ;Flag already set to 'none' or 'expired'
;Any PR/HR flag older than 90 days should be set to 'expired'
I $$FMDIFF^XLFDT($$HTFM^XLFDT($H),DATE)>90 D Q
. S YSFLAG=9 D SETFLAG
I $P(^YTT(601.84,ADMID,0),U,14)'="" Q ; Flag already set don't recalculate
D QUEST(ADMID,INST) ; Retrieve questions and patient answers and set them into ^TMP("YSQA",$J,INST,CNT)
D SCORES ; Get scores for assessment
S YSFLAG=0
I PR,YSCORE>PR S YSFLAG=1 ; Evaluate Positive response
S MULT=$L(HRR,"-") ; Parse HRR for multiples
F X=1:1:MULT Q:YSFLAG>1 D
. S YSLIM=14600 ; 40 Yrs
. S YSHRT=$P(HRR,"-",X)
. I YSHRT["T" S YSLIM=$$TIME(YSHRT) ; Check for T specific parameter
. I $$FMDIFF^XLFDT($$NOW^XLFDT,DATE,1)>YSLIM Q ;Assignment too old
. I YSHRT?1N.E S SI=+YSHRT D HRSCR Q:YSFLAG>1 ; Test for HR based only on Total Raw score
. I YSFLAG>1 Q ; High Risk flag already set
. I $E(YSHRT,1,2)="YA" D YATAG
. I YSFLAG>1 Q ; High Risk flag already set
. I YSHRT?1"Y".N.E D YTAG
. I YSFLAG>1 Q ; High Risk flag already set
. I $E(YSHRT,1)="A" D ATAG
. I YSFLAG>1 Q ; High Risk flag already set
. I $E(YSHRT,1,2)="I9" D I9TAG ;Check for HR solely on I9 question
. I YSFLAG>1 Q ;High Risk flag already set
. I $E(YSHRT,1)="G" D GTTAG
K ^TMP("YSQA",$J) ; Cleanup ^TMP file
D SETFLAG Q
;
QUEST(ADMID,INST) ; Create core code to look at questions and answers
; Requires Administration ID (ADMID) and Instrument name (INST) as an pre-existing value.
N TEMP,QNUM,ANSID,QST,CHOICE,CNT,LEG,I
K ^TMP("YSQA",$J)
S (QNUM,CNT)=0
F S QNUM=$O(^YTT(601.85,"AC",ADMID,QNUM)) Q:QNUM="" D
. S ANSID=$O(^YTT(601.85,"AC",ADMID,QNUM,0))
. S TEMP=^YTT(601.85,ANSID,0)
. S QST="",I=0,CNT=CNT+1
. F S I=$O(^YTT(601.72,$P(TEMP,U,3),1,I)) Q:I="" D
. . I $E(QST,$L(QST))?1A S QST=QST_" "
. . S QST=QST_^YTT(601.72,$P(TEMP,U,3),1,I,0)
. I $P(TEMP,U,4)="NOT ASKED" S CHOICE="NOT ASKED",LEG=""
. E S CHOICE=$S($P(TEMP,U,4)="":"",1:$G(^YTT(601.75,$P(TEMP,U,4),1))),LEG=$S($P(TEMP,U,4)="":"",1:$P($G(^YTT(601.75,$P(TEMP,U,4),0)),U,2))
. I CHOICE="" S CHOICE="Skipped"
. S:'$D(LEG) LEG=""
. S ^TMP("YSQA",$J,INST,CNT)=QST_U_CHOICE_U_LEG
Q
;
SCORES ;
;Get total Raw score for administration
N YSDATA
S YS("AD")=ADMID
S YS("CODE")=INST
S YS("ADATE")=DATE ;$P(^YTT(601.84,ADMID,0),U,3)
S YS("DFN")=DFN
K ^TMP($J,"YSCOR"),^TMP($J,"YSG")
D GETSCORE^YTQAPI8(.YSDATA,.YS)
S YSCORE=$P(^TMP($J,"YSCOR",2),"=",2)
Q
;
TIME(TPAR) ;
N DAYS,INC,PERIOD
S TEMP=$P(TPAR,"T",2)
S INC=+TEMP
S PERIOD=$E(TEMP,$L(TEMP))
I PERIOD="D" S DAYS=INC
I PERIOD="W" S DAYS=INC*7
I PERIOD="M" S DAYS=$P(INC*365/12+.5,".") ;Assume 1 month=30.42 days
Q DAYS
;
HRSCR ;
I YSCORE>SI,YSFLAG=1 S YSFLAG=3 ; Both High Risk & Positive Response
I YSCORE>SI,YSFLAG<1 S YSFLAG=2 ; High Risk
Q
;
YTAG ; Yes to any of specific list of questions.
N CNT,CHOICE,TEMP
S TEMP=$E(YSHRT,2,$L(YSHRT))
I TEMP["T" S TEMP=$P(TEMP,"T",1)
S CNT=0
F S CNT=$O(^TMP("YSQA",$J,INST,CNT)) Q:CNT=""!(YSFLAG>1) D
. I TEMP'[CNT Q
. S CHOICE=$P(^TMP("YSQA",$J,INST,CNT),U,2) ; if any are Yes set flag and quit
. S CHOICE=$TR(CHOICE,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
. I CHOICE?1"Y".2U D
. . I YSFLAG=1 S YSFLAG=3
. . E S YSFLAG=2
Q
;
YATAG ; If Yes to any question is High Risk
N CNT,CHOICE
S CNT=0
F S CNT=$O(^TMP("YSQA",$J,INST,CNT)) Q:CNT=""!(YSFLAG>1) D
. S CHOICE=$P(^TMP("YSQA",$J,INST,CNT),U,2) ; if any are Yes set flag and quit
. S CHOICE=$TR(CHOICE,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
. I CHOICE?1"Y".2U D
. . I YSFLAG=1 S YSFLAG=3
. . E S YSFLAG=2
Q
;
ATAG ; any question with a score > that passed in with the A# parameter.
N MIN,AID,TEMP,QID,CHOICEID,LEG
S MIN=$E(YSHRT,2,$L(YSHRT))
S AID=""
F S AID=$O(^YTT(601.85,"AD",ADMID,AID)) Q:AID=""!(YSFLAG>1) D
. S TEMP=^YTT(601.85,AID,0)
. S QID=$P(TEMP,U,3),CHOICEID=$P(TEMP,U,4)
. S LEG=$P(^YTT(601.75,CHOICEID,0),U,2)
. I LEG>MIN D
. . I YSFLAG=1 S YSFLAG=3
. . E S YSFLAG=2
Q
;
I9TAG ;
N TEST,TEMP,CNT
S TEST="houghts that you would be better off dead",CNT=0
F S CNT=$O(^TMP("YSQA",$J,INST,CNT)) Q:CNT=""!(YSFLAG>1) D
. S TEMP=^TMP("YSQA",$J,INST,CNT)
. I $P(TEMP,U,1)[TEST D
. . I $P(TEMP,U,2)'="",($P(TEMP,U,2)'="Not at all") D
. . . I YSFLAG=1 S YSFLAG=3
. . . E S YSFLAG=2
Q
;
GTTAG ; specific question with a score > that passed in with the GT# parameter.
; If any of the comma delimited question#>value, then YSFLAG=2 for HIGH RISK
N MIN,AID,TEMP,QID,CHOICEID,LEG
N QARR,I,PR
S YSFLAG=0
S TEMP=$E(YSHRT,2,$L(YSHRT))
F I=1:1:$L(TEMP,",") D
. S PR=$P(TEMP,",",I)
. S AID=$P(PR,U) Q:AID="" ;If definition malformed
. S QARR(AID)=$P(PR,U,2) ;QARR(Ques#)=Greater Than value
S MIN=$E(YSHRT,2,$L(YSHRT))
S AID=""
F S AID=$O(QARR(AID)) Q:AID="" D
. S TEMP=$G(^TMP("YSQA",$J,INST,AID)) Q:TEMP=""
. S LEG=$P(TEMP,U,3)
. I LEG>QARR(AID) S YSFLAG=2
Q
SETFLAG ; Set YSFLAG into the MH ADMISISTRATION file (#601.84)
N XXX,YSFDA
S XXX=ADMID_","
S YSFDA(601.84,XXX,16)=YSFLAG D FILE^DIE("K","YSFDA","YSERR")
Q
;
BHS ; BHS
; High Risk: Score of > 8
; Positive Response: None
N INST,HRR,PR
S INST="BHS"
S HRR=8
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
BSS ; BSS
; High Risk: Score > 0 to any question
; Positive Response: None
N INST,HRR,PR
S INST="BSS"
S HRR="A0"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
PHQ2I9 ; PHQ-2+I9
; High Risk: I9 > 0
; Positive Response: Score >2
N INST,HRR,PR
S INST="PHQ-2+I9"
S HRR="I9"
S PR=2
D FLAG(DFN,INST,HRR,PR)
Q
;
PSS3 ; PSS-3
; High Risk: Yes to any of Q1,2,3 within the last 6 months
; Positive Response: None
N INST,HRR,PR
S INST="PSS-3"
S HRR="Y1,2,3,T6M"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
PSS32ND ; PSS-3 2ND
; High Risk: Yes to any of the questions
; Positive Response: None
N INST,HRR,PR
S INST="PSS-3 2ND"
S HRR="YA"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
CSSRS ; C-SSRS
; High Risk: Yes to any of Q3,4,5,8
; Positive Response: None
N INST,HRR,PR
S INST="C-SSRS"
S HRR="Y3,4,5,8"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
I9CSSRS ; I9+C-SSRS
; High Risk: Yes to any of Q3,4,5,8 or I9 > 0
; Positive Response: None
N INST,HRR,PR
S INST="I9+C-SSRS"
S HRR="Y3,4,5,8-I9"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
PHQ9 ; PHQ9 Instrument
; High Risk: I9 > 0
; Positive Response: Score > 9
N INST,HRR,PR
S INST="PHQ9"
S HRR="I9"
S PR=9
D FLAG(DFN,INST,HRR,PR)
Q
;
PTSD5I9 ; PC-PTSD-5+19
; High Risk: I9 > 0
; Positive Response: None
N INST,HRR,PR
S INST="PC-PTSD-5+I9"
S HRR="I9"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
BDI2 ; BDI2 Instrument
; High Risk: Question 9 > 0
N INST,HRR,PR
S INST="BDI2"
S HRR="G9^0"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
CCSA ; CCSA-DSM5 Instrument
; High Risk: Question 9 > 0
N INST,HRR,PR
S INST="CCSA-DSM5"
S HRR="G11^0"
S PR=""
D FLAG(DFN,INST,HRR,PR)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRQAD6 9991 printed Apr 09, 2024@21:19:22 Page 2
YTQRQAD6 ;SLC/LLB - Determine High Risk Flagging ; 07/15/2020
+1 ;;5.01;MENTAL HEALTH;**158,181,187,204**;Dec 30, 1994;Build 18
+2 ;
+3 ; The assumption is made that variable DFN will exist prior to calling this routine.
+4 ;
FLAG(DFN,INST,HRR,PR) ; ROUTINE to calculate Positive response and High Risk flagging
+1 ; ICR #4290 READ OF CLINICAL REMINDER INDEX (PXRMINDX)
+2 ; DFN: IEN to Patient file (#2)
+3 ; INST: Instriment name in MH TESTS AND SURVEYS file (#601.71)
+4 ; INSTIEN: IEN to instrument in MH TESTS AND SURVEYS file (#601.71)
+5 ; HRR: High Risk Requirement
+6 ; # score greater than #
+7 ; A# any question with a score >#
+8 ; I9 Positive I9 question
+9 ; Y1,2,3,n. Comma delimited list of question numbers. A yes to any is HR
+10 ; YA Yes to any question
+11 ; G3^0,5^1,q^n. Comma delimited list of question#^Value for question response Greater Than Value
+12 ; T#p Can be added to any HRR parameter where # is a positive integer and
+13 ; p is the time period M months, W weeks, D day. This will be treated as
+14 ; the most recent administration of the instrument but only if the
+15 ; Ex: "Y,1,2,3,T6M" indicates Yes to Q 1,2, or 3 within the last 6
+16 ; months.
+17 ; Ex: "Y,1,2,3,T6M-I9" is the same as the previous example except that
+18 ; a positive I9, without regard to time frame, triggers High Risk.
+19 ; HRR parameters can be combined by adding "-" between them indicating an "or"
+20 ; such as "Y,3,4,5,8-I9"
+21 ; PR: Positive Response threshold, Score greater than number passed in PR.
+22 ; Based solely on total score. Ex: 8 indicating any score greater than 8.
+23 ; YSFLAG: Will be 0 for no risk
+24 ; 1 for Positive Response
+25 ; 2 for High Risk
+26 ; 3 for Both Positive response & High Risk
+27 ; The field SUICIDE RISK (#16) in the MH ADMINISTRATION file (#601.84) will be
+28 ; populated with the result.
+29 NEW DATE,ADMID,YSFLAG,YS,SI,MULT,INSTIEN,YSLIM,YSCORE
+30 SET SI=0
+31 IF 'DFN
DO SETERROR^YTQRUTL(404,"Not Found: No patient passed. Cannot continue.")
QUIT
+32 IF INST=""
DO SETERROR^YTQRUTL(404,"Not Found: No instrument passed. Cannot continue.")
QUIT
+33 SET YSFLAG=0
+34 SET INSTIEN=$ORDER(^YTT(601.71,"B",INST,0))
if '$DATA(^PXRMINDX(601.84,"PI",DFN,INSTIEN))
QUIT
+35 SET DATE=""
+36 ; Get date of administration most recent to oldest
+37 FOR
SET DATE=$ORDER(^PXRMINDX(601.84,"PI",DFN,INSTIEN,DATE),-1)
if DATE=""
QUIT
DO FLAG2
+38 QUIT
+39 ;
FLAG2 ;
+1 NEW X,YSHRT,CURFLG,AGE
+2 ;IEN to file 601.84
SET ADMID=$ORDER(^PXRMINDX(601.84,"PI",DFN,INSTIEN,DATE,""))
+3 ; NOTE: The ARC index is only updated for completed administrations.
+4 ; A separate check for Administration COMPLETE is not necessary
+5 SET CURFLG=$PIECE(^YTT(601.84,ADMID,0),U,14)
+6 ;Flag already set to 'none' or 'expired'
IF CURFLG=0!(CURFLG=9)
QUIT
+7 ;Any PR/HR flag older than 90 days should be set to 'expired'
+8 IF $$FMDIFF^XLFDT($$HTFM^XLFDT($HOROLOG),DATE)>90
Begin DoDot:1
+9 SET YSFLAG=9
DO SETFLAG
End DoDot:1
QUIT
+10 ; Flag already set don't recalculate
IF $PIECE(^YTT(601.84,ADMID,0),U,14)'=""
QUIT
+11 ; Retrieve questions and patient answers and set them into ^TMP("YSQA",$J,INST,CNT)
DO QUEST(ADMID,INST)
+12 ; Get scores for assessment
DO SCORES
+13 SET YSFLAG=0
+14 ; Evaluate Positive response
IF PR
IF YSCORE>PR
SET YSFLAG=1
+15 ; Parse HRR for multiples
SET MULT=$LENGTH(HRR,"-")
+16 FOR X=1:1:MULT
if YSFLAG>1
QUIT
Begin DoDot:1
+17 ; 40 Yrs
SET YSLIM=14600
+18 SET YSHRT=$PIECE(HRR,"-",X)
+19 ; Check for T specific parameter
IF YSHRT["T"
SET YSLIM=$$TIME(YSHRT)
+20 ;Assignment too old
IF $$FMDIFF^XLFDT($$NOW^XLFDT,DATE,1)>YSLIM
QUIT
+21 ; Test for HR based only on Total Raw score
IF YSHRT?1N.E
SET SI=+YSHRT
DO HRSCR
if YSFLAG>1
QUIT
+22 ; High Risk flag already set
IF YSFLAG>1
QUIT
+23 IF $EXTRACT(YSHRT,1,2)="YA"
DO YATAG
+24 ; High Risk flag already set
IF YSFLAG>1
QUIT
+25 IF YSHRT?1"Y".N.E
DO YTAG
+26 ; High Risk flag already set
IF YSFLAG>1
QUIT
+27 IF $EXTRACT(YSHRT,1)="A"
DO ATAG
+28 ; High Risk flag already set
IF YSFLAG>1
QUIT
+29 ;Check for HR solely on I9 question
IF $EXTRACT(YSHRT,1,2)="I9"
DO I9TAG
+30 ;High Risk flag already set
IF YSFLAG>1
QUIT
+31 IF $EXTRACT(YSHRT,1)="G"
DO GTTAG
End DoDot:1
+32 ; Cleanup ^TMP file
KILL ^TMP("YSQA",$JOB)
+33 DO SETFLAG
QUIT
+34 ;
QUEST(ADMID,INST) ; Create core code to look at questions and answers
+1 ; Requires Administration ID (ADMID) and Instrument name (INST) as an pre-existing value.
+2 NEW TEMP,QNUM,ANSID,QST,CHOICE,CNT,LEG,I
+3 KILL ^TMP("YSQA",$JOB)
+4 SET (QNUM,CNT)=0
+5 FOR
SET QNUM=$ORDER(^YTT(601.85,"AC",ADMID,QNUM))
if QNUM=""
QUIT
Begin DoDot:1
+6 SET ANSID=$ORDER(^YTT(601.85,"AC",ADMID,QNUM,0))
+7 SET TEMP=^YTT(601.85,ANSID,0)
+8 SET QST=""
SET I=0
SET CNT=CNT+1
+9 FOR
SET I=$ORDER(^YTT(601.72,$PIECE(TEMP,U,3),1,I))
if I=""
QUIT
Begin DoDot:2
+10 IF $EXTRACT(QST,$LENGTH(QST))?1A
SET QST=QST_" "
+11 SET QST=QST_^YTT(601.72,$PIECE(TEMP,U,3),1,I,0)
End DoDot:2
+12 IF $PIECE(TEMP,U,4)="NOT ASKED"
SET CHOICE="NOT ASKED"
SET LEG=""
+13 IF '$TEST
SET CHOICE=$SELECT($PIECE(TEMP,U,4)="":"",1:$GET(^YTT(601.75,$PIECE(TEMP,U,4),1)))
SET LEG=$SELECT($PIECE(TEMP,U,4)="":"",1:$PIECE($GET(^YTT(601.75,$PIECE(TEMP,U,4),0)),U,2))
+14 IF CHOICE=""
SET CHOICE="Skipped"
+15 if '$DATA(LEG)
SET LEG=""
+16 SET ^TMP("YSQA",$JOB,INST,CNT)=QST_U_CHOICE_U_LEG
End DoDot:1
+17 QUIT
+18 ;
SCORES ;
+1 ;Get total Raw score for administration
+2 NEW YSDATA
+3 SET YS("AD")=ADMID
+4 SET YS("CODE")=INST
+5 ;$P(^YTT(601.84,ADMID,0),U,3)
SET YS("ADATE")=DATE
+6 SET YS("DFN")=DFN
+7 KILL ^TMP($JOB,"YSCOR"),^TMP($JOB,"YSG")
+8 DO GETSCORE^YTQAPI8(.YSDATA,.YS)
+9 SET YSCORE=$PIECE(^TMP($JOB,"YSCOR",2),"=",2)
+10 QUIT
+11 ;
TIME(TPAR) ;
+1 NEW DAYS,INC,PERIOD
+2 SET TEMP=$PIECE(TPAR,"T",2)
+3 SET INC=+TEMP
+4 SET PERIOD=$EXTRACT(TEMP,$LENGTH(TEMP))
+5 IF PERIOD="D"
SET DAYS=INC
+6 IF PERIOD="W"
SET DAYS=INC*7
+7 ;Assume 1 month=30.42 days
IF PERIOD="M"
SET DAYS=$PIECE(INC*365/12+.5,".")
+8 QUIT DAYS
+9 ;
HRSCR ;
+1 ; Both High Risk & Positive Response
IF YSCORE>SI
IF YSFLAG=1
SET YSFLAG=3
+2 ; High Risk
IF YSCORE>SI
IF YSFLAG<1
SET YSFLAG=2
+3 QUIT
+4 ;
YTAG ; Yes to any of specific list of questions.
+1 NEW CNT,CHOICE,TEMP
+2 SET TEMP=$EXTRACT(YSHRT,2,$LENGTH(YSHRT))
+3 IF TEMP["T"
SET TEMP=$PIECE(TEMP,"T",1)
+4 SET CNT=0
+5 FOR
SET CNT=$ORDER(^TMP("YSQA",$JOB,INST,CNT))
if CNT=""!(YSFLAG>1)
QUIT
Begin DoDot:1
+6 IF TEMP'[CNT
QUIT
+7 ; if any are Yes set flag and quit
SET CHOICE=$PIECE(^TMP("YSQA",$JOB,INST,CNT),U,2)
+8 SET CHOICE=$TRANSLATE(CHOICE,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+9 IF CHOICE?1"Y".2U
Begin DoDot:2
+10 IF YSFLAG=1
SET YSFLAG=3
+11 IF '$TEST
SET YSFLAG=2
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
YATAG ; If Yes to any question is High Risk
+1 NEW CNT,CHOICE
+2 SET CNT=0
+3 FOR
SET CNT=$ORDER(^TMP("YSQA",$JOB,INST,CNT))
if CNT=""!(YSFLAG>1)
QUIT
Begin DoDot:1
+4 ; if any are Yes set flag and quit
SET CHOICE=$PIECE(^TMP("YSQA",$JOB,INST,CNT),U,2)
+5 SET CHOICE=$TRANSLATE(CHOICE,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+6 IF CHOICE?1"Y".2U
Begin DoDot:2
+7 IF YSFLAG=1
SET YSFLAG=3
+8 IF '$TEST
SET YSFLAG=2
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
ATAG ; any question with a score > that passed in with the A# parameter.
+1 NEW MIN,AID,TEMP,QID,CHOICEID,LEG
+2 SET MIN=$EXTRACT(YSHRT,2,$LENGTH(YSHRT))
+3 SET AID=""
+4 FOR
SET AID=$ORDER(^YTT(601.85,"AD",ADMID,AID))
if AID=""!(YSFLAG>1)
QUIT
Begin DoDot:1
+5 SET TEMP=^YTT(601.85,AID,0)
+6 SET QID=$PIECE(TEMP,U,3)
SET CHOICEID=$PIECE(TEMP,U,4)
+7 SET LEG=$PIECE(^YTT(601.75,CHOICEID,0),U,2)
+8 IF LEG>MIN
Begin DoDot:2
+9 IF YSFLAG=1
SET YSFLAG=3
+10 IF '$TEST
SET YSFLAG=2
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
I9TAG ;
+1 NEW TEST,TEMP,CNT
+2 SET TEST="houghts that you would be better off dead"
SET CNT=0
+3 FOR
SET CNT=$ORDER(^TMP("YSQA",$JOB,INST,CNT))
if CNT=""!(YSFLAG>1)
QUIT
Begin DoDot:1
+4 SET TEMP=^TMP("YSQA",$JOB,INST,CNT)
+5 IF $PIECE(TEMP,U,1)[TEST
Begin DoDot:2
+6 IF $PIECE(TEMP,U,2)'=""
IF ($PIECE(TEMP,U,2)'="Not at all")
Begin DoDot:3
+7 IF YSFLAG=1
SET YSFLAG=3
+8 IF '$TEST
SET YSFLAG=2
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
GTTAG ; specific question with a score > that passed in with the GT# parameter.
+1 ; If any of the comma delimited question#>value, then YSFLAG=2 for HIGH RISK
+2 NEW MIN,AID,TEMP,QID,CHOICEID,LEG
+3 NEW QARR,I,PR
+4 SET YSFLAG=0
+5 SET TEMP=$EXTRACT(YSHRT,2,$LENGTH(YSHRT))
+6 FOR I=1:1:$LENGTH(TEMP,",")
Begin DoDot:1
+7 SET PR=$PIECE(TEMP,",",I)
+8 ;If definition malformed
SET AID=$PIECE(PR,U)
if AID=""
QUIT
+9 ;QARR(Ques#)=Greater Than value
SET QARR(AID)=$PIECE(PR,U,2)
End DoDot:1
+10 SET MIN=$EXTRACT(YSHRT,2,$LENGTH(YSHRT))
+11 SET AID=""
+12 FOR
SET AID=$ORDER(QARR(AID))
if AID=""
QUIT
Begin DoDot:1
+13 SET TEMP=$GET(^TMP("YSQA",$JOB,INST,AID))
if TEMP=""
QUIT
+14 SET LEG=$PIECE(TEMP,U,3)
+15 IF LEG>QARR(AID)
SET YSFLAG=2
End DoDot:1
+16 QUIT
SETFLAG ; Set YSFLAG into the MH ADMISISTRATION file (#601.84)
+1 NEW XXX,YSFDA
+2 SET XXX=ADMID_","
+3 SET YSFDA(601.84,XXX,16)=YSFLAG
DO FILE^DIE("K","YSFDA","YSERR")
+4 QUIT
+5 ;
BHS ; BHS
+1 ; High Risk: Score of > 8
+2 ; Positive Response: None
+3 NEW INST,HRR,PR
+4 SET INST="BHS"
+5 SET HRR=8
+6 SET PR=""
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
BSS ; BSS
+1 ; High Risk: Score > 0 to any question
+2 ; Positive Response: None
+3 NEW INST,HRR,PR
+4 SET INST="BSS"
+5 SET HRR="A0"
+6 SET PR=""
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
PHQ2I9 ; PHQ-2+I9
+1 ; High Risk: I9 > 0
+2 ; Positive Response: Score >2
+3 NEW INST,HRR,PR
+4 SET INST="PHQ-2+I9"
+5 SET HRR="I9"
+6 SET PR=2
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
PSS3 ; PSS-3
+1 ; High Risk: Yes to any of Q1,2,3 within the last 6 months
+2 ; Positive Response: None
+3 NEW INST,HRR,PR
+4 SET INST="PSS-3"
+5 SET HRR="Y1,2,3,T6M"
+6 SET PR=""
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
PSS32ND ; PSS-3 2ND
+1 ; High Risk: Yes to any of the questions
+2 ; Positive Response: None
+3 NEW INST,HRR,PR
+4 SET INST="PSS-3 2ND"
+5 SET HRR="YA"
+6 SET PR=""
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
CSSRS ; C-SSRS
+1 ; High Risk: Yes to any of Q3,4,5,8
+2 ; Positive Response: None
+3 NEW INST,HRR,PR
+4 SET INST="C-SSRS"
+5 SET HRR="Y3,4,5,8"
+6 SET PR=""
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
I9CSSRS ; I9+C-SSRS
+1 ; High Risk: Yes to any of Q3,4,5,8 or I9 > 0
+2 ; Positive Response: None
+3 NEW INST,HRR,PR
+4 SET INST="I9+C-SSRS"
+5 SET HRR="Y3,4,5,8-I9"
+6 SET PR=""
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
PHQ9 ; PHQ9 Instrument
+1 ; High Risk: I9 > 0
+2 ; Positive Response: Score > 9
+3 NEW INST,HRR,PR
+4 SET INST="PHQ9"
+5 SET HRR="I9"
+6 SET PR=9
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
PTSD5I9 ; PC-PTSD-5+19
+1 ; High Risk: I9 > 0
+2 ; Positive Response: None
+3 NEW INST,HRR,PR
+4 SET INST="PC-PTSD-5+I9"
+5 SET HRR="I9"
+6 SET PR=""
+7 DO FLAG(DFN,INST,HRR,PR)
+8 QUIT
+9 ;
BDI2 ; BDI2 Instrument
+1 ; High Risk: Question 9 > 0
+2 NEW INST,HRR,PR
+3 SET INST="BDI2"
+4 SET HRR="G9^0"
+5 SET PR=""
+6 DO FLAG(DFN,INST,HRR,PR)
+7 QUIT
CCSA ; CCSA-DSM5 Instrument
+1 ; High Risk: Question 9 > 0
+2 NEW INST,HRR,PR
+3 SET INST="CCSA-DSM5"
+4 SET HRR="G11^0"
+5 SET PR=""
+6 DO FLAG(DFN,INST,HRR,PR)
+7 QUIT
+8 ;
