- YTQRQAD6 ;SLC/LLB - Determine High Risk Flagging ; 07/15/2020
- ;;5.01;MENTAL HEALTH;**158,181,187,204,240**;Dec 30, 1994;Build 10
- ;
- ; 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: Instrument 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")
- D UPADM^YTQEVNT(ADMID,"flag") ; publish admin update event
- 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 10056 printed Feb 18, 2025@23:45:16 Page 2
- YTQRQAD6 ;SLC/LLB - Determine High Risk Flagging ; 07/15/2020
- +1 ;;5.01;MENTAL HEALTH;**158,181,187,204,240**;Dec 30, 1994;Build 10
- +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: Instrument 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 ; publish admin update event
- DO UPADM^YTQEVNT(ADMID,"flag")
- +5 QUIT
- +6 ;
- 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 ;