YTSPHI ;SLC/KCM - Score PHI and format report ;Mar 03, 2025@14:06:48
;;5.01;MENTAL HEALTH;**172,236**;DEC 30,1994;Build 25
;
DATA1 ; Loop YSDATA and map questions to choice values
; expects YTRESP from DLLSTR
N YTI,YTQSTN,YTCHC
F YTI=8555:1:8576 S YTRESP(YTI)="" ; ensure something is there
S YTI=2 F S YTI=$O(YSDATA(YTI)) Q:'YTI D ; set actual choice values
. S YTQSTN=$P(YSDATA(YTI),U),YTCHC=$P(YSDATA(YTI),U,3)
. I YTQSTN=8558!(YTQSTN=8577)!(YTQSTN=8578) D Q ; handle text answers
. . I YTCHC=1155!(YTCHC=1156)!(YTCHC=1157) D QUIT
. . . S YTRESP(YTQSTN)="SKIPPED"
. . S YTRESP(YTQSTN)=$G(YTRESP(YTQSTN))_$P(YSDATA(YTI),U,3,99)
. S YTRESP(YTQSTN)=$$MAPCHC(YTCHC)
Q
MAPCHC(YTCHC) ; Map score to choice
; expects YSTRNG from DLLSTR
I YTCHC=1155!(YTCHC=1156)!(YTCHC=1157) Q $S(YSTRNG=2:"SKIPPED",1:0)
I $D(^YTT(601.75,YTCHC,0)) Q +$P(^YTT(601.75,YTCHC,0),U,2)
Q YTCHC
;
SCORESV ; Save the scores (only used for graphing for PHI)
; expects YTRESP from DLLSTR
K ^TMP($J,"YSCOR")
I $D(^TMP($J,"YSG",1)),^TMP($J,"YSG",1)="[ERROR]" D Q ;-->out
. S ^TMP($J,"YSCOR",1)="[ERROR]"
. S ^TMP($J,"YSCOR",2)="No Scale found for ADMIN"
S ^TMP($J,"YSCOR",1)="[DATA]"
N X,YTI,YTS,YTSCALE
S YTI=1 F S YTI=$O(^TMP($J,"YSG",YTI)) Q:'YTI D
. S X=^TMP($J,"YSG",YTI) I $E(X,1,5)'="Scale" Q
. S X=$P(X,"=",2,99)
. S YTSCALE($P(X,U))=$P(X,U,4)_"="
S YTS=0,YTI=1 F S YTS=$O(YTSCALE(YTS)) Q:'YTS D
. I YTS=1354 S X=YTRESP(8555) ; Physical Well-Being
. I YTS=1355 S X=YTRESP(8556) ; Mental Well-Being
. I YTS=1356 S X=YTRESP(8557) ; Life Day-to-Day
. I YTS=1357 S X=YTRESP(8559) ; Moving the Body...Now
. I YTS=1358 S X=YTRESP(8560) ; Moving the Body...To Be
. I YTS=1359 S X=YTRESP(8561) ; Recharge...Now
. I YTS=1360 S X=YTRESP(8562) ; Recharge...To Be
. I YTS=1361 S X=YTRESP(8563) ; Food and Drink...Now
. I YTS=1362 S X=YTRESP(8564) ; Food and Drink...To Be
. I YTS=1363 S X=YTRESP(8565) ; Personal Development...Now
. I YTS=1364 S X=YTRESP(8566) ; Personal Development...To Be
. I YTS=1365 S X=YTRESP(8567) ; Family, Friends...Now
. I YTS=1366 S X=YTRESP(8568) ; Family, Friends...To Be
. I YTS=1367 S X=YTRESP(8569) ; Spirit and Soul...Now
. I YTS=1368 S X=YTRESP(8570) ; Spirit and Soul...To Be
. I YTS=1369 S X=YTRESP(8571) ; Surroundings...Now
. I YTS=1370 S X=YTRESP(8572) ; Surroundings...To Be
. I YTS=1371 S X=YTRESP(8573) ; Power of the Mind...Now
. I YTS=1372 S X=YTRESP(8574) ; Power of the Mind...To Be
. I YTS=1373 S X=YTRESP(8575) ; Professional Care...Now
. I YTS=1374 S X=YTRESP(8576) ; Professional Care...To Be
. S YTI=YTI+1,^TMP($J,"YSCOR",YTI)=YTSCALE(YTS)_X
Q
;
REPORT(REFLECT,CARE) ; Set the special text for the report
; expects YTRESP from DLLSTR
N X
S X=""
S X=X_"|Physical Well-Being: "_YTRESP(8555)
S X=X_"|Mental/Emotional Well-Being: "_YTRESP(8556)
S X=X_"|Life: How is it to live your day-to-day life? "_YTRESP(8557)
S REFLECT=X,X=""
S X=X_"|Moving the Body "_YTRESP(8559)_$$SPACED(8560)
S X=X_"|Recharge "_YTRESP(8561)_$$SPACED(8562)
S X=X_"|Food and Drink "_YTRESP(8563)_$$SPACED(8564)
S X=X_"|Personal Development "_YTRESP(8565)_$$SPACED(8566)
S X=X_"|Family, Friends, and Co-Workers "_YTRESP(8567)_$$SPACED(8568)
S X=X_"|Spirit and Soul "_YTRESP(8569)_$$SPACED(8570)
S X=X_"|Surroundings "_YTRESP(8571)_$$SPACED(8572)
S X=X_"|Power of the Mind "_YTRESP(8573)_$$SPACED(8574)
S X=X_"|Professional Care "_YTRESP(8575)_$$SPACED(8576)
S CARE=X
Q
SPACED(QSTN) ; Return answer text with aligned spacing
N SPACES S SPACES=" "
Q $E(SPACES,1,21-$L(YTRESP(QSTN-1)))_YTRESP(QSTN)
;
WRAPPED(TX,MAX) ; Wrap the response using "|" delimiters
N OUT,I,J,X,Y,YNEW
F I=1:1:$L(TX,"|") S X=$P(TX,"|",I) D
. I $L(X)'>MAX D ADDOUT(X) QUIT
. S Y=""
. F J=1:1:$L(X," ") D
. . S YNEW=Y_$S(J=1:"",1:" ")_$P(X," ",J)
. . I $L(YNEW)>MAX D ADDOUT(Y) S Y=$P(X," ",J) I 1
. . E S Y=YNEW
. D ADDOUT(Y) ; add any remaining
S X="",I=0 F S I=$O(OUT(I)) Q:'I S X=X_$S(I=1:"",1:"|")_OUT(I)
Q X
;
ADDOUT(S) ; add string to out array (expects OUT)
S OUT=+$G(OUT)+1,OUT(OUT)=S
Q
;
DLLSTR(YSDATA,YS,YSTRNG) ;
; input
; YSDATA(2)=adminId^patientDFN^instrumentName^dateGiven^complete?
; YSDATA(2+n)=questionId^sequence^choiceId
; YS("AD")=adminId
; YSTRNG=1 for score, 2 for report
; output if YSTRNG=1
; ^TMP($J,"YSCOR",n)=scaleId=score
; output if YSTRNG=2
; append special "answers" to YSDATA
;
N YTRESP
D DATA1
I YSTRNG=1 D SCORESV
I YSTRNG=2 D
. N REFLECT,CARE,N
. D REPORT(.REFLECT,.CARE)
. S N=$O(YSDATA(""),-1) ; get last node
. S YSDATA(N+1)="7771^9999;1^"_REFLECT
. S YSDATA(N+2)="7772^9999;1^"_CARE
. S YSDATA(N+3)="7773^9999;1^"_$$WRAPPED(YTRESP(8558),76)
. S YSDATA(N+4)="7774^9999;1^"_$$WRAPPED(YTRESP(8577),76)
. S YSDATA(N+5)="7775^9999;1^"_$$WRAPPED(YTRESP(8578),76)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSPHI 5130 printed Sep 23, 2025@19:56:41 Page 2
YTSPHI ;SLC/KCM - Score PHI and format report ;Mar 03, 2025@14:06:48
+1 ;;5.01;MENTAL HEALTH;**172,236**;DEC 30,1994;Build 25
+2 ;
DATA1 ; Loop YSDATA and map questions to choice values
+1 ; expects YTRESP from DLLSTR
+2 NEW YTI,YTQSTN,YTCHC
+3 ; ensure something is there
FOR YTI=8555:1:8576
SET YTRESP(YTI)=""
+4 ; set actual choice values
SET YTI=2
FOR
SET YTI=$ORDER(YSDATA(YTI))
if 'YTI
QUIT
Begin DoDot:1
+5 SET YTQSTN=$PIECE(YSDATA(YTI),U)
SET YTCHC=$PIECE(YSDATA(YTI),U,3)
+6 ; handle text answers
IF YTQSTN=8558!(YTQSTN=8577)!(YTQSTN=8578)
Begin DoDot:2
+7 IF YTCHC=1155!(YTCHC=1156)!(YTCHC=1157)
Begin DoDot:3
+8 SET YTRESP(YTQSTN)="SKIPPED"
End DoDot:3
QUIT
+9 SET YTRESP(YTQSTN)=$GET(YTRESP(YTQSTN))_$PIECE(YSDATA(YTI),U,3,99)
End DoDot:2
QUIT
+10 SET YTRESP(YTQSTN)=$$MAPCHC(YTCHC)
End DoDot:1
+11 QUIT
MAPCHC(YTCHC) ; Map score to choice
+1 ; expects YSTRNG from DLLSTR
+2 IF YTCHC=1155!(YTCHC=1156)!(YTCHC=1157)
QUIT $SELECT(YSTRNG=2:"SKIPPED",1:0)
+3 IF $DATA(^YTT(601.75,YTCHC,0))
QUIT +$PIECE(^YTT(601.75,YTCHC,0),U,2)
+4 QUIT YTCHC
+5 ;
SCORESV ; Save the scores (only used for graphing for PHI)
+1 ; expects YTRESP from DLLSTR
+2 KILL ^TMP($JOB,"YSCOR")
+3 ;-->out
IF $DATA(^TMP($JOB,"YSG",1))
IF ^TMP($JOB,"YSG",1)="[ERROR]"
Begin DoDot:1
+4 SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
+5 SET ^TMP($JOB,"YSCOR",2)="No Scale found for ADMIN"
End DoDot:1
QUIT
+6 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
+7 NEW X,YTI,YTS,YTSCALE
+8 SET YTI=1
FOR
SET YTI=$ORDER(^TMP($JOB,"YSG",YTI))
if 'YTI
QUIT
Begin DoDot:1
+9 SET X=^TMP($JOB,"YSG",YTI)
IF $EXTRACT(X,1,5)'="Scale"
QUIT
+10 SET X=$PIECE(X,"=",2,99)
+11 SET YTSCALE($PIECE(X,U))=$PIECE(X,U,4)_"="
End DoDot:1
+12 SET YTS=0
SET YTI=1
FOR
SET YTS=$ORDER(YTSCALE(YTS))
if 'YTS
QUIT
Begin DoDot:1
+13 ; Physical Well-Being
IF YTS=1354
SET X=YTRESP(8555)
+14 ; Mental Well-Being
IF YTS=1355
SET X=YTRESP(8556)
+15 ; Life Day-to-Day
IF YTS=1356
SET X=YTRESP(8557)
+16 ; Moving the Body...Now
IF YTS=1357
SET X=YTRESP(8559)
+17 ; Moving the Body...To Be
IF YTS=1358
SET X=YTRESP(8560)
+18 ; Recharge...Now
IF YTS=1359
SET X=YTRESP(8561)
+19 ; Recharge...To Be
IF YTS=1360
SET X=YTRESP(8562)
+20 ; Food and Drink...Now
IF YTS=1361
SET X=YTRESP(8563)
+21 ; Food and Drink...To Be
IF YTS=1362
SET X=YTRESP(8564)
+22 ; Personal Development...Now
IF YTS=1363
SET X=YTRESP(8565)
+23 ; Personal Development...To Be
IF YTS=1364
SET X=YTRESP(8566)
+24 ; Family, Friends...Now
IF YTS=1365
SET X=YTRESP(8567)
+25 ; Family, Friends...To Be
IF YTS=1366
SET X=YTRESP(8568)
+26 ; Spirit and Soul...Now
IF YTS=1367
SET X=YTRESP(8569)
+27 ; Spirit and Soul...To Be
IF YTS=1368
SET X=YTRESP(8570)
+28 ; Surroundings...Now
IF YTS=1369
SET X=YTRESP(8571)
+29 ; Surroundings...To Be
IF YTS=1370
SET X=YTRESP(8572)
+30 ; Power of the Mind...Now
IF YTS=1371
SET X=YTRESP(8573)
+31 ; Power of the Mind...To Be
IF YTS=1372
SET X=YTRESP(8574)
+32 ; Professional Care...Now
IF YTS=1373
SET X=YTRESP(8575)
+33 ; Professional Care...To Be
IF YTS=1374
SET X=YTRESP(8576)
+34 SET YTI=YTI+1
SET ^TMP($JOB,"YSCOR",YTI)=YTSCALE(YTS)_X
End DoDot:1
+35 QUIT
+36 ;
REPORT(REFLECT,CARE) ; Set the special text for the report
+1 ; expects YTRESP from DLLSTR
+2 NEW X
+3 SET X=""
+4 SET X=X_"|Physical Well-Being: "_YTRESP(8555)
+5 SET X=X_"|Mental/Emotional Well-Being: "_YTRESP(8556)
+6 SET X=X_"|Life: How is it to live your day-to-day life? "_YTRESP(8557)
+7 SET REFLECT=X
SET X=""
+8 SET X=X_"|Moving the Body "_YTRESP(8559)_$$SPACED(8560)
+9 SET X=X_"|Recharge "_YTRESP(8561)_$$SPACED(8562)
+10 SET X=X_"|Food and Drink "_YTRESP(8563)_$$SPACED(8564)
+11 SET X=X_"|Personal Development "_YTRESP(8565)_$$SPACED(8566)
+12 SET X=X_"|Family, Friends, and Co-Workers "_YTRESP(8567)_$$SPACED(8568)
+13 SET X=X_"|Spirit and Soul "_YTRESP(8569)_$$SPACED(8570)
+14 SET X=X_"|Surroundings "_YTRESP(8571)_$$SPACED(8572)
+15 SET X=X_"|Power of the Mind "_YTRESP(8573)_$$SPACED(8574)
+16 SET X=X_"|Professional Care "_YTRESP(8575)_$$SPACED(8576)
+17 SET CARE=X
+18 QUIT
SPACED(QSTN) ; Return answer text with aligned spacing
+1 NEW SPACES
SET SPACES=" "
+2 QUIT $EXTRACT(SPACES,1,21-$LENGTH(YTRESP(QSTN-1)))_YTRESP(QSTN)
+3 ;
WRAPPED(TX,MAX) ; Wrap the response using "|" delimiters
+1 NEW OUT,I,J,X,Y,YNEW
+2 FOR I=1:1:$LENGTH(TX,"|")
SET X=$PIECE(TX,"|",I)
Begin DoDot:1
+3 IF $LENGTH(X)'>MAX
DO ADDOUT(X)
QUIT
+4 SET Y=""
+5 FOR J=1:1:$LENGTH(X," ")
Begin DoDot:2
+6 SET YNEW=Y_$SELECT(J=1:"",1:" ")_$PIECE(X," ",J)
+7 IF $LENGTH(YNEW)>MAX
DO ADDOUT(Y)
SET Y=$PIECE(X," ",J)
IF 1
+8 IF '$TEST
SET Y=YNEW
End DoDot:2
+9 ; add any remaining
DO ADDOUT(Y)
End DoDot:1
+10 SET X=""
SET I=0
FOR
SET I=$ORDER(OUT(I))
if 'I
QUIT
SET X=X_$SELECT(I=1:"",1:"|")_OUT(I)
+11 QUIT X
+12 ;
ADDOUT(S) ; add string to out array (expects OUT)
+1 SET OUT=+$GET(OUT)+1
SET OUT(OUT)=S
+2 QUIT
+3 ;
DLLSTR(YSDATA,YS,YSTRNG) ;
+1 ; input
+2 ; YSDATA(2)=adminId^patientDFN^instrumentName^dateGiven^complete?
+3 ; YSDATA(2+n)=questionId^sequence^choiceId
+4 ; YS("AD")=adminId
+5 ; YSTRNG=1 for score, 2 for report
+6 ; output if YSTRNG=1
+7 ; ^TMP($J,"YSCOR",n)=scaleId=score
+8 ; output if YSTRNG=2
+9 ; append special "answers" to YSDATA
+10 ;
+11 NEW YTRESP
+12 DO DATA1
+13 IF YSTRNG=1
DO SCORESV
+14 IF YSTRNG=2
Begin DoDot:1
+15 NEW REFLECT,CARE,N
+16 DO REPORT(.REFLECT,.CARE)
+17 ; get last node
SET N=$ORDER(YSDATA(""),-1)
+18 SET YSDATA(N+1)="7771^9999;1^"_REFLECT
+19 SET YSDATA(N+2)="7772^9999;1^"_CARE
+20 SET YSDATA(N+3)="7773^9999;1^"_$$WRAPPED(YTRESP(8558),76)
+21 SET YSDATA(N+4)="7774^9999;1^"_$$WRAPPED(YTRESP(8577),76)
+22 SET YSDATA(N+5)="7775^9999;1^"_$$WRAPPED(YTRESP(8578),76)
End DoDot:1
+23 QUIT
