YTSBAMR ;SLC/PIJ - Score BAM-Revision ; 01/08/2016
;;5.01;MENTAL HEALTH;**123,130**;DEC 30,1994;Build 62
;
;Public, Supported ICRs
; #2056 - Fileman API - $$GET1^DIQ
;
Q
;
DATA1 ; display scores for administration
N ANS,LEG,NODE,YSCDA,YSSEQ,YS
N DATA,DES,SCORE,YSANS,YSQN,CID
S SCORE=0
S YSINSNAM=$P($G(YSDATA(2)),U,3)
I $G(YSINSNAM)="" S YSINSNAM=$G(YS("CODE"),"NO NAME PASSED")
S NODE=2 F S NODE=$O(YSDATA(NODE)) Q:NODE="" D ; Start at YSDATA(3)
.S DATA=YSDATA(NODE)
.S YSQN=$P(DATA,U,1)
.S YSSEQ=$P($P(DATA,U,2),";",1) ; Sequence Number
.;if $P(YSSEQ,";",2)'"" then no Choice ID, piece 3 is data
.S YSANS=$P($P(DATA,U,2),";",2)
.S ANS=$P(DATA,U,3),ANS=$S(ANS=1155:0,ANS=1156:0,1:ANS)
.D DESGNTR^YTSCORE(YSQN,.DES)
.S YSCDA=$P($G(DATA),U,3) ; Choice ID
.I $G(YSANS) S LEG=YSCDA
.; legacy values are not correct for numerous CHOICE ID's, therefore set value from ID
.I '$G(YSANS) S CID=YSCDA D
..S LEG=$S(CID=212:0,CID=1059:0,CID=1060:1,CID=1061:2,CID=1062:3,CID=1063:4,CID=717:1,CID=685:2,CID=2312:3,CID=687:4,CID=241:"Y",1:"")
.I (DES="A")!(DES="B") Q
.D SCORE
Q
;
SCORE ;
I DES=1 D
.S HEALTH=HEALTH+LEG
.S RISK=RISK+$$SCORADJ(LEG)
I DES=2 D
.S SLEEP=LEG
.S RISK=RISK+LEG
I DES=3 D
.S DISTR=LEG
.S RISK=RISK+LEG
I DES=4 D
.S DAYSAU=LEG
.S USE=USE+LEG
I DES=5 D
.S DAYSHA=LEG
.S USE=USE+LEG
I DES=6 D
.S DAYSDRUG=LEG
.S USE=USE+LEG
I DES=8 D
.S URGE=LEG
.S RISK=RISK+$$SCORADJ(LEG)
I DES=9 D
.S CONFID=LEG
.S PROTECT=PROTECT+$$SCORADJ(LEG)
I DES=10 D
.S SELF=LEG
.S PROTECT=PROTECT+LEG
I DES=11 D
.S RISKY=LEG
.S RISK=RISK+LEG
I DES=12 D
.S SPIRIT=LEG
.S PROTECT=PROTECT+$$SCORADJ(LEG)
I DES=13 D
.S WORK=LEG
.S PROTECT=PROTECT+LEG
I DES=14 D
.I LEG="Y" S INCME=4,PROTECT=PROTECT+30
I DES=15 D
.S RELAT=LEG
.S RISK=RISK+$$SCORADJ(LEG)
I DES=16 D
.S SUPT=LEG
.S PROTECT=PROTECT+LEG
Q
;
SCORADJ(SCOR) ;
S ANS=0
I SCOR=1 S ANS=8
I SCOR=2 S ANS=15
I SCOR=3 S ANS=22
I SCOR=4 S ANS=30
Q ANS
;
SCORESV ;
I $D(^TMP($J,"YSG",1)),^TMP($J,"YSG",1)="[ERROR]" D Q ;-->out
.K ^TMP($J,"YSCOR")
.S ^TMP($J,"YSCOR",1)="[ERROR]"
.S ^TMP($J,"YSCOR",2)="BAMR Scale not found"
;
K ^TMP($J,"YSCOR")
S ^TMP($J,"YSCOR",1)="[DATA]"
S ^TMP($J,"YSCOR",2)=$$GET1^DIQ(601.87,861_",",3,"I")_"="_USE
S ^TMP($J,"YSCOR",3)=$$GET1^DIQ(601.87,863_",",3,"I")_"="_RISK
S ^TMP($J,"YSCOR",4)=$$GET1^DIQ(601.87,864_",",3,"I")_"="_PROTECT
S ^TMP($J,"YSCOR",5)=$$GET1^DIQ(601.87,865_",",3,"I")_"="_DAYSAU
S ^TMP($J,"YSCOR",6)=$$GET1^DIQ(601.87,866_",",3,"I")_"="_DAYSHA
S ^TMP($J,"YSCOR",7)=$$GET1^DIQ(601.87,867_",",3,"I")_"="_DAYSDRUG
S ^TMP($J,"YSCOR",8)=$$GET1^DIQ(601.87,868_",",3,"I")_"="_HEALTH
S ^TMP($J,"YSCOR",9)=$$GET1^DIQ(601.87,869_",",3,"I")_"="_SLEEP
S ^TMP($J,"YSCOR",10)=$$GET1^DIQ(601.87,870_",",3,"I")_"="_DISTR
S ^TMP($J,"YSCOR",11)=$$GET1^DIQ(601.87,871_",",3,"I")_"="_URGE
S ^TMP($J,"YSCOR",12)=$$GET1^DIQ(601.87,872_",",3,"I")_"="_RISKY
S ^TMP($J,"YSCOR",13)=$$GET1^DIQ(601.87,873_",",3,"I")_"="_RELAT
S ^TMP($J,"YSCOR",14)=$$GET1^DIQ(601.87,874_",",3,"I")_"="_CONFID
S ^TMP($J,"YSCOR",15)=$$GET1^DIQ(601.87,875_",",3,"I")_"="_SELF
S ^TMP($J,"YSCOR",16)=$$GET1^DIQ(601.87,876_",",3,"I")_"="_SPIRIT
S ^TMP($J,"YSCOR",17)=$$GET1^DIQ(601.87,877_",",3,"I")_"="_WORK
S ^TMP($J,"YSCOR",18)=$$GET1^DIQ(601.87,878_",",3,"I")_"="_INCME
S ^TMP($J,"YSCOR",19)=$$GET1^DIQ(601.87,879_",",3,"I")_"="_SUPT
;
Q
DLLSTR(YSDATA,YS,YSTRNG) ;
; YSTRNG = 1 Score Instrument
; YSTRNG = 2 get Report Answers and Text
N YSINSNAM
N USE,RISK,PROTECT,DAYSAU,DAYSHA,DAYSDRUG,HEALTH,SLEEP
N DISTR,URGE,RISKY,RELAT,CONFID,SELF,SPIRIT,WORK,INCME,SUPT
;
S (USE,RISK,PROTECT,DAYSAU,DAYSHA,DAYSDRUG,HEALTH,SLEEP)=0
S (DISTR,URGE,RISKY,RELAT,CONFID,SELF,SPIRIT,WORK,INCME,SUPT)=0
;
I YSTRNG=2 Q ; No special text, computations in the report.
;
D DATA1
D SCORESV
Q
;
VERIFY(ARGS,RESULTS) ; Add inconsistency messages based on set of answers in ARGS
N MSGCNT S MSGCNT=0
I $$LT("q6501","q6502") D MSG("more","4","5")
I $$LT("q6503","q6504") D MSG("less","7A","6")
I $$LT("q6503","q6505") D MSG("less","7B","6")
I $$LT("q6503","q6506") D MSG("less","7C","6")
I $$LT("q6503","q6507") D MSG("less","7D","6")
I $$LT("q6503","q6508") D MSG("less","7E","6")
I $$LT("q6503","q6509") D MSG("less","7F","6")
I $$LT("q6503","q6510") D MSG("less","7G","6")
S RESULTS("count")=MSGCNT
Q
LT(ID1,ID2) ; returns 1 if ID1 is less than ID2
; expects ARGS from VERIFY
N VAL1,VAL2
S VAL1=$G(ARGS(ID1)) S:VAL1="c1156" VAL1=0 ; 1156 = skipped by rule
S VAL2=$G(ARGS(ID2)) S:VAL2="c1156" VAL2=0
I +VAL1<+VAL2 Q 1
Q 0
;
MSG(REL,Q1,Q2) ; Add text of message to RESULTS
; expects MSGCNT, RESULTS from VERIFY
N X
S X="There is an inconsistency: The number of days entered in Question "_Q1
S X=X_" should be equal to, or "_REL_" than,"
S X=X_" the number of days in Question "_Q2_"."
S MSGCNT=MSGCNT+1,RESULTS("messages",MSGCNT)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSBAMR 5071 printed Sep 23, 2025@19:55:25 Page 2
YTSBAMR ;SLC/PIJ - Score BAM-Revision ; 01/08/2016
+1 ;;5.01;MENTAL HEALTH;**123,130**;DEC 30,1994;Build 62
+2 ;
+3 ;Public, Supported ICRs
+4 ; #2056 - Fileman API - $$GET1^DIQ
+5 ;
+6 QUIT
+7 ;
DATA1 ; display scores for administration
+1 NEW ANS,LEG,NODE,YSCDA,YSSEQ,YS
+2 NEW DATA,DES,SCORE,YSANS,YSQN,CID
+3 SET SCORE=0
+4 SET YSINSNAM=$PIECE($GET(YSDATA(2)),U,3)
+5 IF $GET(YSINSNAM)=""
SET YSINSNAM=$GET(YS("CODE"),"NO NAME PASSED")
+6 ; Start at YSDATA(3)
SET NODE=2
FOR
SET NODE=$ORDER(YSDATA(NODE))
if NODE=""
QUIT
Begin DoDot:1
+7 SET DATA=YSDATA(NODE)
+8 SET YSQN=$PIECE(DATA,U,1)
+9 ; Sequence Number
SET YSSEQ=$PIECE($PIECE(DATA,U,2),";",1)
+10 ;if $P(YSSEQ,";",2)'"" then no Choice ID, piece 3 is data
+11 SET YSANS=$PIECE($PIECE(DATA,U,2),";",2)
+12 SET ANS=$PIECE(DATA,U,3)
SET ANS=$SELECT(ANS=1155:0,ANS=1156:0,1:ANS)
+13 DO DESGNTR^YTSCORE(YSQN,.DES)
+14 ; Choice ID
SET YSCDA=$PIECE($GET(DATA),U,3)
+15 IF $GET(YSANS)
SET LEG=YSCDA
+16 ; legacy values are not correct for numerous CHOICE ID's, therefore set value from ID
+17 IF '$GET(YSANS)
SET CID=YSCDA
Begin DoDot:2
+18 SET LEG=$SELECT(CID=212:0,CID=1059:0,CID=1060:1,CID=1061:2,CID=1062:3,CID=1063:4,CID=717:1,CID=685:2,CID=2312:3,CID=687:4,CID=241:"Y",1:"")
End DoDot:2
+19 IF (DES="A")!(DES="B")
QUIT
+20 DO SCORE
End DoDot:1
+21 QUIT
+22 ;
SCORE ;
+1 IF DES=1
Begin DoDot:1
+2 SET HEALTH=HEALTH+LEG
+3 SET RISK=RISK+$$SCORADJ(LEG)
End DoDot:1
+4 IF DES=2
Begin DoDot:1
+5 SET SLEEP=LEG
+6 SET RISK=RISK+LEG
End DoDot:1
+7 IF DES=3
Begin DoDot:1
+8 SET DISTR=LEG
+9 SET RISK=RISK+LEG
End DoDot:1
+10 IF DES=4
Begin DoDot:1
+11 SET DAYSAU=LEG
+12 SET USE=USE+LEG
End DoDot:1
+13 IF DES=5
Begin DoDot:1
+14 SET DAYSHA=LEG
+15 SET USE=USE+LEG
End DoDot:1
+16 IF DES=6
Begin DoDot:1
+17 SET DAYSDRUG=LEG
+18 SET USE=USE+LEG
End DoDot:1
+19 IF DES=8
Begin DoDot:1
+20 SET URGE=LEG
+21 SET RISK=RISK+$$SCORADJ(LEG)
End DoDot:1
+22 IF DES=9
Begin DoDot:1
+23 SET CONFID=LEG
+24 SET PROTECT=PROTECT+$$SCORADJ(LEG)
End DoDot:1
+25 IF DES=10
Begin DoDot:1
+26 SET SELF=LEG
+27 SET PROTECT=PROTECT+LEG
End DoDot:1
+28 IF DES=11
Begin DoDot:1
+29 SET RISKY=LEG
+30 SET RISK=RISK+LEG
End DoDot:1
+31 IF DES=12
Begin DoDot:1
+32 SET SPIRIT=LEG
+33 SET PROTECT=PROTECT+$$SCORADJ(LEG)
End DoDot:1
+34 IF DES=13
Begin DoDot:1
+35 SET WORK=LEG
+36 SET PROTECT=PROTECT+LEG
End DoDot:1
+37 IF DES=14
Begin DoDot:1
+38 IF LEG="Y"
SET INCME=4
SET PROTECT=PROTECT+30
End DoDot:1
+39 IF DES=15
Begin DoDot:1
+40 SET RELAT=LEG
+41 SET RISK=RISK+$$SCORADJ(LEG)
End DoDot:1
+42 IF DES=16
Begin DoDot:1
+43 SET SUPT=LEG
+44 SET PROTECT=PROTECT+LEG
End DoDot:1
+45 QUIT
+46 ;
SCORADJ(SCOR) ;
+1 SET ANS=0
+2 IF SCOR=1
SET ANS=8
+3 IF SCOR=2
SET ANS=15
+4 IF SCOR=3
SET ANS=22
+5 IF SCOR=4
SET ANS=30
+6 QUIT ANS
+7 ;
SCORESV ;
+1 ;-->out
IF $DATA(^TMP($JOB,"YSG",1))
IF ^TMP($JOB,"YSG",1)="[ERROR]"
Begin DoDot:1
+2 KILL ^TMP($JOB,"YSCOR")
+3 SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
+4 SET ^TMP($JOB,"YSCOR",2)="BAMR Scale not found"
End DoDot:1
QUIT
+5 ;
+6 KILL ^TMP($JOB,"YSCOR")
+7 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
+8 SET ^TMP($JOB,"YSCOR",2)=$$GET1^DIQ(601.87,861_",",3,"I")_"="_USE
+9 SET ^TMP($JOB,"YSCOR",3)=$$GET1^DIQ(601.87,863_",",3,"I")_"="_RISK
+10 SET ^TMP($JOB,"YSCOR",4)=$$GET1^DIQ(601.87,864_",",3,"I")_"="_PROTECT
+11 SET ^TMP($JOB,"YSCOR",5)=$$GET1^DIQ(601.87,865_",",3,"I")_"="_DAYSAU
+12 SET ^TMP($JOB,"YSCOR",6)=$$GET1^DIQ(601.87,866_",",3,"I")_"="_DAYSHA
+13 SET ^TMP($JOB,"YSCOR",7)=$$GET1^DIQ(601.87,867_",",3,"I")_"="_DAYSDRUG
+14 SET ^TMP($JOB,"YSCOR",8)=$$GET1^DIQ(601.87,868_",",3,"I")_"="_HEALTH
+15 SET ^TMP($JOB,"YSCOR",9)=$$GET1^DIQ(601.87,869_",",3,"I")_"="_SLEEP
+16 SET ^TMP($JOB,"YSCOR",10)=$$GET1^DIQ(601.87,870_",",3,"I")_"="_DISTR
+17 SET ^TMP($JOB,"YSCOR",11)=$$GET1^DIQ(601.87,871_",",3,"I")_"="_URGE
+18 SET ^TMP($JOB,"YSCOR",12)=$$GET1^DIQ(601.87,872_",",3,"I")_"="_RISKY
+19 SET ^TMP($JOB,"YSCOR",13)=$$GET1^DIQ(601.87,873_",",3,"I")_"="_RELAT
+20 SET ^TMP($JOB,"YSCOR",14)=$$GET1^DIQ(601.87,874_",",3,"I")_"="_CONFID
+21 SET ^TMP($JOB,"YSCOR",15)=$$GET1^DIQ(601.87,875_",",3,"I")_"="_SELF
+22 SET ^TMP($JOB,"YSCOR",16)=$$GET1^DIQ(601.87,876_",",3,"I")_"="_SPIRIT
+23 SET ^TMP($JOB,"YSCOR",17)=$$GET1^DIQ(601.87,877_",",3,"I")_"="_WORK
+24 SET ^TMP($JOB,"YSCOR",18)=$$GET1^DIQ(601.87,878_",",3,"I")_"="_INCME
+25 SET ^TMP($JOB,"YSCOR",19)=$$GET1^DIQ(601.87,879_",",3,"I")_"="_SUPT
+26 ;
+27 QUIT
DLLSTR(YSDATA,YS,YSTRNG) ;
+1 ; YSTRNG = 1 Score Instrument
+2 ; YSTRNG = 2 get Report Answers and Text
+3 NEW YSINSNAM
+4 NEW USE,RISK,PROTECT,DAYSAU,DAYSHA,DAYSDRUG,HEALTH,SLEEP
+5 NEW DISTR,URGE,RISKY,RELAT,CONFID,SELF,SPIRIT,WORK,INCME,SUPT
+6 ;
+7 SET (USE,RISK,PROTECT,DAYSAU,DAYSHA,DAYSDRUG,HEALTH,SLEEP)=0
+8 SET (DISTR,URGE,RISKY,RELAT,CONFID,SELF,SPIRIT,WORK,INCME,SUPT)=0
+9 ;
+10 ; No special text, computations in the report.
IF YSTRNG=2
QUIT
+11 ;
+12 DO DATA1
+13 DO SCORESV
+14 QUIT
+15 ;
VERIFY(ARGS,RESULTS) ; Add inconsistency messages based on set of answers in ARGS
+1 NEW MSGCNT
SET MSGCNT=0
+2 IF $$LT("q6501","q6502")
DO MSG("more","4","5")
+3 IF $$LT("q6503","q6504")
DO MSG("less","7A","6")
+4 IF $$LT("q6503","q6505")
DO MSG("less","7B","6")
+5 IF $$LT("q6503","q6506")
DO MSG("less","7C","6")
+6 IF $$LT("q6503","q6507")
DO MSG("less","7D","6")
+7 IF $$LT("q6503","q6508")
DO MSG("less","7E","6")
+8 IF $$LT("q6503","q6509")
DO MSG("less","7F","6")
+9 IF $$LT("q6503","q6510")
DO MSG("less","7G","6")
+10 SET RESULTS("count")=MSGCNT
+11 QUIT
LT(ID1,ID2) ; returns 1 if ID1 is less than ID2
+1 ; expects ARGS from VERIFY
+2 NEW VAL1,VAL2
+3 ; 1156 = skipped by rule
SET VAL1=$GET(ARGS(ID1))
if VAL1="c1156"
SET VAL1=0
+4 SET VAL2=$GET(ARGS(ID2))
if VAL2="c1156"
SET VAL2=0
+5 IF +VAL1<+VAL2
QUIT 1
+6 QUIT 0
+7 ;
MSG(REL,Q1,Q2) ; Add text of message to RESULTS
+1 ; expects MSGCNT, RESULTS from VERIFY
+2 NEW X
+3 SET X="There is an inconsistency: The number of days entered in Question "_Q1
+4 SET X=X_" should be equal to, or "_REL_" than,"
+5 SET X=X_" the number of days in Question "_Q2_"."
+6 SET MSGCNT=MSGCNT+1
SET RESULTS("messages",MSGCNT)=X
+7 QUIT
