YTSCORE ;SLC/KCM - Scoring for complex instruments ;Jan 18, 2024@12:05:44
;;5.01;MENTAL HEALTH;**119,123,142,141,217,234,244**;Dec 30, 1994;Build 5
;
;
Q
DLL ; stub entry point for instruments scored by DLL
Q
;
DESGNTR(YSQN,DES) ; Create DESIGNTR variable, used for Reports
N STR76
S DES="NO DESIGNATOR"
Q:'$G(YSQN)
S STR76=$O(^YTT(601.76,"AE",YSQN,0))
Q:'$G(STR76)
S DES=$P($P($G(^YTT(601.76,STR76,0)),U,5),".")
Q
;
LOADANSW(YSDATA,YS) ; patch 123, loads answers, builds YSDATA array
;input:AD = ADMINISTRATION #
;output: [DATA]
; ADMIN ID^DFN^INSTRUMENT^DATE GIVEN^IS COMPLETE
; QUESTION #^seq^ANSWER
;
N G,G1,N,YSQN,YSTSTN,YSEQ,YSICON
N IEN71
S YSAD=$G(YS("AD"))
I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="Bad ADMIN num, admin is "_YSAD Q ;-->out
I '$D(^YTT(601.85,"AC",YSAD)) S YSDATA(1)="[ERROR]",YSDATA(2)="No entry in MH ANSWERS" Q ;-->out
S YSTSTN=$P(^YTT(601.84,YSAD,0),U,3)
S YSDATA(1)="[DATA]"
S YSDATA(2)=YSAD_U_$$GET1^DIQ(601.84,YSAD_",",1,"I")_U_$$GET1^DIQ(601.84,YSAD_",",2,"E")_U_$$GET1^DIQ(601.84,YSAD_",",3,"I")_U_$$GET1^DIQ(601.84,YSAD_",",8,"I")
S YSQN=0,N=2
F S YSQN=$O(^YTT(601.85,"AC",YSAD,YSQN)) Q:YSQN'>0 S G=0 D
.S G=$O(^YTT(601.85,"AC",YSAD,YSQN,G)) Q:G'>0 S G1=0 D
..S YSICON=$O(^YTT(601.76,"AF",YSTSTN,YSQN,0))
..S YSEQ=1
..I YSICON?1N.N S YSEQ=$P(^YTT(601.76,YSICON,0),U,3)
..S:$P(^YTT(601.85,G,0),U,4)?1N.N N=N+1,YSDATA(N)=YSQN_U_YSEQ_U_$P(^YTT(601.85,G,0),U,4)
..F S G1=$O(^YTT(601.85,G,1,G1)) Q:G1'>0 D
...S N=N+1,YSDATA(N)=YSQN_U_YSEQ_";"_G1_U_$G(^YTT(601.85,G,1,G1,0))
Q
;
SCOREINS(YSDATA,IEN71) ;
; patch 123, scores responses (answers) for a given instrument
; YSDATA contains Answers for instrument
N I,G,N,YSAI,YSAN,YSCALEI,YSKEYI,YSRAW,YSRTN,YSTARG,YSQN,YSVAL
K ^TMP($J,"YSCOR"),^TMP($J,"YSG")
I '$D(^YTT(601.86,"AD",IEN71)) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Scale grp not found" Q ;-->out
S YS("CODE")=$$GET1^DIQ(601.71,IEN71_",",.01) ; get the Instrument Name
D SCALEG^YTQAPI3(.YSDATA,.YS)
S YSDATA=$NA(^TMP($J,"YSCOR"))
S ^TMP($J,"YSCOR",1)="[DATA]",N=1
;
S YSRTN=$$GET1^DIQ(601.71,IEN71_",",92) ;routine for scoring
I (YSRTN'=""),(YSRTN'="YTSCORE") D Q
.S YSRTN="DLLSTR^"_YSRTN_"(.YSDATA,.YS,1)"
.D @YSRTN
; original code, this uses MH SCORING KEY File to calculate ^TMP for "regular instruments"
F I=2:1 Q:'$D(^TMP($J,"YSG",I)) I ^TMP($J,"YSG",I)?1"Scale".E S YSRAW="0",N=N+1,^TMP($J,"YSCOR",N)=$P(^TMP($J,"YSG",I),U,4)_"=" D S ^TMP($J,"YSCOR",N)=^TMP($J,"YSCOR",N)_YSRAW
.S YSCALEI=$P(^TMP($J,"YSG",I),U),YSCALEI=$P(YSCALEI,"=",2)
.S YSKEYI=0 F S YSKEYI=$O(^YTT(601.91,"AC",YSCALEI,YSKEYI)) Q:YSKEYI'>0 D
..S G=^YTT(601.91,YSKEYI,0)
..S YSQN=$P(G,U,3),YSTARG=$P(G,U,4),YSVAL=$P(G,U,5)
..S YSAI=$O(^YTT(601.85,"AC",YSAD,YSQN,0))
..Q:YSAI'>0
..Q:'$D(^YTT(601.85,YSAI,0)) ;ASF 11/15/07
..S YSAN=""
..I $D(^YTT(601.85,YSAI,1,1,0)) S YSAN=^YTT(601.85,YSAI,1,1,0)
..I $P(^YTT(601.85,YSAI,0),U,4)?1N.N S YSAN=$P(^YTT(601.85,YSAI,0),U,4),YSAN=$G(^YTT(601.75,YSAN,1))
..I YSAN=YSTARG S YSRAW=YSRAW+YSVAL
Q
;
CHKSCRE() ;
N REVSCR71,REVSCR84
S REVSCR71=$$GET1^DIQ(601.71,IEN71_",",93) ; Instrument scoring version number
S REVSCR84=$$GET1^DIQ(601.84,YSAD_",",14) ; Administration scoring version number
Q (REVSCR71=REVSCR84)
;
LDSCORES(YSDATA,YS) ; new call for patch 123
;input:AD = ADMINISTRATION #
;output: [DATA] in ^TMP($J,"YSCOR")
N G,N,IEN71,SCALE,YSAD,YSCODEN,YSCALE
S YSAD=$G(YS("AD"))
K ^TMP($J,"YSCOR") S YSDATA=$NA(^TMP($J,"YSCOR"))
I YSAD'?1N.N S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Bad ADMIN # in LDSCORES" Q ;-->out
S IEN71=$$GET1^DIQ(601.84,YSAD_",",2,"I") I IEN71'?1N.N D Q
.S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="No Instrument in 601.84"
;Check if scoring may have changed before loading scores
I '$$CHKSCRE D SCORSAVE^YTQAPI11(.YSDATA,.YS)
I '$D(^YTT(601.92,"AC",YSAD)) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="No entry in MH RESULTS" Q ;-->out
;
S YS("CODE")=$$GET1^DIQ(601.84,YSAD_",",2)
D SCALEG^YTQAPI3(.YSDATA,.YS)
;
S YSDATA=$NA(^TMP($J,"YSCOR"))
S ^TMP($J,"YSCOR",1)="[DATA]",N=1
;
S YSCALE=""
F S YSCALE=$O(^YTT(601.92,"AC",YSAD,YSCALE)) Q:'YSCALE D
.S G=$G(^YTT(601.92,YSCALE,0))
.S SCALE=$P(G,U,3),N=N+1
.S ^TMP($J,"YSCOR",N)=SCALE_"="_$P(G,U,4)_$S($P(G,U,5):U_$P(G,U,5),1:"")
Q
;
UPDSCORE(YSDATA,YS) ; files entries in MH RESULTS (601.92)
;input:AD = ADMINISTRATION #
;output: [DATA]
N DIFF,IEN71,YSAD,YSCALE,YSC,YSG,Z
S YSAD=$G(YS("AD"))
I YSAD'?1N.N S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="No ADMIN # in UPDSCORE" Q ;-->out
S IEN71=$$GET1^DIQ(601.84,YSAD_",",2,"I")
; are there existing scores in MH RESULT
I $D(^YTT(601.92,"AC",YSAD)) D OLDSCRES(.YSCALE,.YSAD)
;
S Z=1 F S Z=$O(^TMP($J,"YSCOR",Z)) Q:Z'>0 D
.S YSG=^TMP($J,"YSCOR",Z)
.S YSC=$P(YSG,"=")
.S DIFF=0
.I $D(YSCALE(YSC)) D Q
..S DIFF=$$CHKSCR(.YSC,.YSG)
..I DIFF D ADDAUDIT(.YSC,.YSG)
.D ADDSCRE
; set admin.revision = instrument.revision
D SETREV(.YSAD,.IEN71)
Q
;
CHKSCR(YSC,YSG) ; return 1 if there are different values, 0 if values in scoring are the same
N I,OLDSC,YSCOR
S DIFF=0
S YSCOR=$P(YSG,"=",2,7)
S OLDSC=$P(YSCALE(YSC),U,4,7)
F I=1:1:4 I $P($G(OLDSC),U,I)'=$P($G(YSCOR),U,I) S DIFF=1 Q:DIFF
Q DIFF
;
ADDAUDIT(YSC,YSG) ; add entry in AUDIT node, update value in existing MH RESULTS record
N AUDIEN,AUD,DIERR
S AUDIEN=$P(YSCALE(YSC),U)
D NOW^%DTC
S AUD(1,601.921,"+2,"_AUDIEN_",",.01)=%
S AUD(1,601.921,"+2,"_AUDIEN_",",2)=$$GET1^DIQ(601.84,YSAD_",",14)
F I=4:1:7 I $L($P(YSCALE(YSC),U,I)) S AUD(1,601.921,"+2,"_AUDIEN_",",(I-1))=$P(YSCALE(YSC),U,I)
D UPDATE^DIE("","AUD(1)")
I $D(DIERR) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Did not set Audit node in MH RESULTS" Q
D CLEAN^DILF
;
; update existing node with new ones; use FILE^DIE
N I,FDA,DIERR,YSGANS
S YSGANS=$P(YSG,"=",2,5)
F I=1:1:4 I $L($P(YSGANS,U,I))!$L($P(YSCALE(YSC),U,I+3)) S FDA(601.92,AUDIEN_",",(I+2))=$P(YSGANS,U,I)
D FILE^DIE("","FDA")
I $D(DIERR) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Did not update records in MH RESULTS File" Q
D CLEAN^DILF
K %,%H,%I,X
Q
;
ADDSCRE ;add score to MH RESULTS
N FDA,FDAIEN,DIERR,STR,YSRNEW,YSRFND
S YSRNEW=$P($G(^YTT(601.92,0)),U,3),YSRFND=0
S:YSRNEW<100000 YSRNEW=100000
L +^YTT(601.92,0):DILOCKTM+10
I '$T D QUIT
. S ^TMP($J,"YSCOR",1)="[ERROR]"
. S ^TMP($J,"YSCOR",2)="Could not get lock on MH RESULTS file"
F Q:YSRFND D:'$D(^YTT(601.92,YSRNEW)) S YSRNEW=YSRNEW+1
. L +^YTT(601.92,YSRNEW):DILOCKTM Q:'$T
. S STR=$P(YSG,"=",2)
. S FDAIEN(1)=YSRNEW
. S FDA(601.92,"+1,",.01)=YSRNEW
. S FDA(601.92,"+1,",1)=YSAD
. S FDA(601.92,"+1,",2)=$P(YSG,"=",1)
. S FDA(601.92,"+1,",3)=$P(STR,U,1) ; raw score
. S:$L($P(STR,U,2)) FDA(601.92,"+1,",4)=$P(STR,U,2) ; transformed score 1
. S:$L($P(STR,U,3)) FDA(601.92,"+1,",5)=$P(STR,U,3) ; transformed score 2
. S:$L($P(STR,U,4)) FDA(601.92,"+1,",6)=$P(STR,U,4) ; transformed score 3
. D UPDATE^DIE("","FDA","FDAIEN")
. L -^YTT(601.92,YSRNEW)
. S YSRFND=1
L -^YTT(601.92,0)
I $D(DIERR) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Did not add MH RESULTS entry" Q
Q
;
OLDSCRES(YSCALE,YSAD) ; if existing score, build array containing them
N IEN92,STR
S IEN92=0
F S IEN92=$O(^YTT(601.92,"AC",YSAD,IEN92)) Q:'IEN92 D
.S STR=$G(^YTT(601.92,IEN92,0))
.S YSCALE($P(STR,U,3))=STR
Q
;
SETREV(YSAD,IEN71) ; set revision value in MH ADMINISTRATIONS to value in MH TEST AND SURVEYS
N FDA,DIERR
S FDA(601.84,YSAD_",",14)=$$GET1^DIQ(601.71,IEN71_",",93)
D FILE^DIE("","FDA")
I $D(DIERR) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Did not set Scoring Revision in MH ADMIN"
D CLEAN^DILF
Q
;
LDTSCOR(TSARR,YSAD) ;
N CNT,DATA,IEN92,RAW,T1,T2,T3
S IEN92="",CNT=1
I YSAD'?1N.N S TSARR("NOADM")="No Administration to get scores" Q
I '$D(^YTT(601.92,"AC",YSAD)) S TSARR("NOADM")="No scores in MH RESULTS File" Q
F S IEN92=$O(^YTT(601.92,"AC",YSAD,IEN92)) Q:'IEN92 D
.S DATA=$G(^YTT(601.92,IEN92,0))
.S RAW=$P(DATA,U,4),T1=$P(DATA,U,5),T2=$P(DATA,U,6),T3=$P(DATA,U,7)
.S RAW=$S($L(RAW)=1:" "_RAW,1:RAW)
.S T1=$S($L(T1)=1:" "_T1,1:T1),T2=$S($L(T2)=1:" "_T2,1:T2),T3=$S($L(T3)=1:" "_T3,1:T3)
.S TSARR($P($P(DATA,U,3),":"))=$P(DATA,U,3)_U_RAW_U_T1_U_T2_U_T3
Q
BYKEY(YSDATA) ; use YSDATA to score by key and put into ^TMP($J,"YSCOR")
; expects scales to already be in ^TMP($J,"YSG")
N I,J,TEST,ANSWERS,SCORES,QID,CID,YS
K ^TMP($J,"YSCOR")
S TEST=$P(YSDATA(2),U,3),YS("CODE")=TEST
I $L(TEST) S TEST=$O(^YTT(601.71,"B",TEST,0))
I 'TEST S ^TMP($J,"YSCOR",1)="[ERROR]",^(2)="No test found" QUIT
S I=2,J=0 F S I=$O(YSDATA(I)) Q:'I D ; build ANSWERS array
. S QID=$P(YSDATA(I),U),CID=$P(YSDATA(I),U,3)
. S J=J+1,ANSWERS(J,"id")=QID,ANSWERS(J,"value")=CID
D SUMKEY^YTSCOREX(TEST,.ANSWERS,.SCORES)
S J=1,^TMP($J,"YSCOR",J)="[DATA]"
S I=0 F S I=$O(SCORES(I)) Q:'I D
. S J=J+1,^TMP($J,"YSCOR",J)=$G(SCORES(I,"name"))_"="_SCORES(I,"raw")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSCORE 9176 printed Apr 09, 2024@21:24:20 Page 2
YTSCORE ;SLC/KCM - Scoring for complex instruments ;Jan 18, 2024@12:05:44
+1 ;;5.01;MENTAL HEALTH;**119,123,142,141,217,234,244**;Dec 30, 1994;Build 5
+2 ;
+3 ;
+4 QUIT
DLL ; stub entry point for instruments scored by DLL
+1 QUIT
+2 ;
DESGNTR(YSQN,DES) ; Create DESIGNTR variable, used for Reports
+1 NEW STR76
+2 SET DES="NO DESIGNATOR"
+3 if '$GET(YSQN)
QUIT
+4 SET STR76=$ORDER(^YTT(601.76,"AE",YSQN,0))
+5 if '$GET(STR76)
QUIT
+6 SET DES=$PIECE($PIECE($GET(^YTT(601.76,STR76,0)),U,5),".")
+7 QUIT
+8 ;
LOADANSW(YSDATA,YS) ; patch 123, loads answers, builds YSDATA array
+1 ;input:AD = ADMINISTRATION #
+2 ;output: [DATA]
+3 ; ADMIN ID^DFN^INSTRUMENT^DATE GIVEN^IS COMPLETE
+4 ; QUESTION #^seq^ANSWER
+5 ;
+6 NEW G,G1,N,YSQN,YSTSTN,YSEQ,YSICON
+7 NEW IEN71
+8 SET YSAD=$GET(YS("AD"))
+9 ;-->out
IF YSAD'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="Bad ADMIN num, admin is "_YSAD
QUIT
+10 ;-->out
IF '$DATA(^YTT(601.85,"AC",YSAD))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="No entry in MH ANSWERS"
QUIT
+11 SET YSTSTN=$PIECE(^YTT(601.84,YSAD,0),U,3)
+12 SET YSDATA(1)="[DATA]"
+13 SET YSDATA(2)=YSAD_U_$$GET1^DIQ(601.84,YSAD_",",1,"I")_U_$$GET1^DIQ(601.84,YSAD_",",2,"E")_U_$$GET1^DIQ(601.84,YSAD_",",3,"I")_U_$$GET1^DIQ(601.84,YSAD_",",8,"I")
+14 SET YSQN=0
SET N=2
+15 FOR
SET YSQN=$ORDER(^YTT(601.85,"AC",YSAD,YSQN))
if YSQN'>0
QUIT
SET G=0
Begin DoDot:1
+16 SET G=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,G))
if G'>0
QUIT
SET G1=0
Begin DoDot:2
+17 SET YSICON=$ORDER(^YTT(601.76,"AF",YSTSTN,YSQN,0))
+18 SET YSEQ=1
+19 IF YSICON?1N.N
SET YSEQ=$PIECE(^YTT(601.76,YSICON,0),U,3)
+20 if $PIECE(^YTT(601.85,G,0),U,4)?1N.N
SET N=N+1
SET YSDATA(N)=YSQN_U_YSEQ_U_$PIECE(^YTT(601.85,G,0),U,4)
+21 FOR
SET G1=$ORDER(^YTT(601.85,G,1,G1))
if G1'>0
QUIT
Begin DoDot:3
+22 SET N=N+1
SET YSDATA(N)=YSQN_U_YSEQ_";"_G1_U_$GET(^YTT(601.85,G,1,G1,0))
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
SCOREINS(YSDATA,IEN71) ;
+1 ; patch 123, scores responses (answers) for a given instrument
+2 ; YSDATA contains Answers for instrument
+3 NEW I,G,N,YSAI,YSAN,YSCALEI,YSKEYI,YSRAW,YSRTN,YSTARG,YSQN,YSVAL
+4 KILL ^TMP($JOB,"YSCOR"),^TMP($JOB,"YSG")
+5 ;-->out
IF '$DATA(^YTT(601.86,"AD",IEN71))
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="Scale grp not found"
QUIT
+6 ; get the Instrument Name
SET YS("CODE")=$$GET1^DIQ(601.71,IEN71_",",.01)
+7 DO SCALEG^YTQAPI3(.YSDATA,.YS)
+8 SET YSDATA=$NAME(^TMP($JOB,"YSCOR"))
+9 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
SET N=1
+10 ;
+11 ;routine for scoring
SET YSRTN=$$GET1^DIQ(601.71,IEN71_",",92)
+12 IF (YSRTN'="")
IF (YSRTN'="YTSCORE")
Begin DoDot:1
+13 SET YSRTN="DLLSTR^"_YSRTN_"(.YSDATA,.YS,1)"
+14 DO @YSRTN
End DoDot:1
QUIT
+15 ; original code, this uses MH SCORING KEY File to calculate ^TMP for "regular instruments"
+16 FOR I=2:1
if '$DATA(^TMP($JOB,"YSG",I))
QUIT
IF ^TMP($JOB,"YSG",I)?1"Scale".E
SET YSRAW="0"
SET N=N+1
SET ^TMP($JOB,"YSCOR",N)=$PIECE(^TMP($JOB,"YSG",I),U,4)_"="
Begin DoDot:1
+17 SET YSCALEI=$PIECE(^TMP($JOB,"YSG",I),U)
SET YSCALEI=$PIECE(YSCALEI,"=",2)
+18 SET YSKEYI=0
FOR
SET YSKEYI=$ORDER(^YTT(601.91,"AC",YSCALEI,YSKEYI))
if YSKEYI'>0
QUIT
Begin DoDot:2
+19 SET G=^YTT(601.91,YSKEYI,0)
+20 SET YSQN=$PIECE(G,U,3)
SET YSTARG=$PIECE(G,U,4)
SET YSVAL=$PIECE(G,U,5)
+21 SET YSAI=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,0))
+22 if YSAI'>0
QUIT
+23 ;ASF 11/15/07
if '$DATA(^YTT(601.85,YSAI,0))
QUIT
+24 SET YSAN=""
+25 IF $DATA(^YTT(601.85,YSAI,1,1,0))
SET YSAN=^YTT(601.85,YSAI,1,1,0)
+26 IF $PIECE(^YTT(601.85,YSAI,0),U,4)?1N.N
SET YSAN=$PIECE(^YTT(601.85,YSAI,0),U,4)
SET YSAN=$GET(^YTT(601.75,YSAN,1))
+27 IF YSAN=YSTARG
SET YSRAW=YSRAW+YSVAL
End DoDot:2
End DoDot:1
SET ^TMP($JOB,"YSCOR",N)=^TMP($JOB,"YSCOR",N)_YSRAW
+28 QUIT
+29 ;
CHKSCRE() ;
+1 NEW REVSCR71,REVSCR84
+2 ; Instrument scoring version number
SET REVSCR71=$$GET1^DIQ(601.71,IEN71_",",93)
+3 ; Administration scoring version number
SET REVSCR84=$$GET1^DIQ(601.84,YSAD_",",14)
+4 QUIT (REVSCR71=REVSCR84)
+5 ;
LDSCORES(YSDATA,YS) ; new call for patch 123
+1 ;input:AD = ADMINISTRATION #
+2 ;output: [DATA] in ^TMP($J,"YSCOR")
+3 NEW G,N,IEN71,SCALE,YSAD,YSCODEN,YSCALE
+4 SET YSAD=$GET(YS("AD"))
+5 KILL ^TMP($JOB,"YSCOR")
SET YSDATA=$NAME(^TMP($JOB,"YSCOR"))
+6 ;-->out
IF YSAD'?1N.N
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="Bad ADMIN # in LDSCORES"
QUIT
+7 SET IEN71=$$GET1^DIQ(601.84,YSAD_",",2,"I")
IF IEN71'?1N.N
Begin DoDot:1
+8 SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="No Instrument in 601.84"
End DoDot:1
QUIT
+9 ;Check if scoring may have changed before loading scores
+10 IF '$$CHKSCRE
DO SCORSAVE^YTQAPI11(.YSDATA,.YS)
+11 ;-->out
IF '$DATA(^YTT(601.92,"AC",YSAD))
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="No entry in MH RESULTS"
QUIT
+12 ;
+13 SET YS("CODE")=$$GET1^DIQ(601.84,YSAD_",",2)
+14 DO SCALEG^YTQAPI3(.YSDATA,.YS)
+15 ;
+16 SET YSDATA=$NAME(^TMP($JOB,"YSCOR"))
+17 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
SET N=1
+18 ;
+19 SET YSCALE=""
+20 FOR
SET YSCALE=$ORDER(^YTT(601.92,"AC",YSAD,YSCALE))
if 'YSCALE
QUIT
Begin DoDot:1
+21 SET G=$GET(^YTT(601.92,YSCALE,0))
+22 SET SCALE=$PIECE(G,U,3)
SET N=N+1
+23 SET ^TMP($JOB,"YSCOR",N)=SCALE_"="_$PIECE(G,U,4)_$SELECT($PIECE(G,U,5):U_$PIECE(G,U,5),1:"")
End DoDot:1
+24 QUIT
+25 ;
UPDSCORE(YSDATA,YS) ; files entries in MH RESULTS (601.92)
+1 ;input:AD = ADMINISTRATION #
+2 ;output: [DATA]
+3 NEW DIFF,IEN71,YSAD,YSCALE,YSC,YSG,Z
+4 SET YSAD=$GET(YS("AD"))
+5 ;-->out
IF YSAD'?1N.N
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="No ADMIN # in UPDSCORE"
QUIT
+6 SET IEN71=$$GET1^DIQ(601.84,YSAD_",",2,"I")
+7 ; are there existing scores in MH RESULT
+8 IF $DATA(^YTT(601.92,"AC",YSAD))
DO OLDSCRES(.YSCALE,.YSAD)
+9 ;
+10 SET Z=1
FOR
SET Z=$ORDER(^TMP($JOB,"YSCOR",Z))
if Z'>0
QUIT
Begin DoDot:1
+11 SET YSG=^TMP($JOB,"YSCOR",Z)
+12 SET YSC=$PIECE(YSG,"=")
+13 SET DIFF=0
+14 IF $DATA(YSCALE(YSC))
Begin DoDot:2
+15 SET DIFF=$$CHKSCR(.YSC,.YSG)
+16 IF DIFF
DO ADDAUDIT(.YSC,.YSG)
End DoDot:2
QUIT
+17 DO ADDSCRE
End DoDot:1
+18 ; set admin.revision = instrument.revision
+19 DO SETREV(.YSAD,.IEN71)
+20 QUIT
+21 ;
CHKSCR(YSC,YSG) ; return 1 if there are different values, 0 if values in scoring are the same
+1 NEW I,OLDSC,YSCOR
+2 SET DIFF=0
+3 SET YSCOR=$PIECE(YSG,"=",2,7)
+4 SET OLDSC=$PIECE(YSCALE(YSC),U,4,7)
+5 FOR I=1:1:4
IF $PIECE($GET(OLDSC),U,I)'=$PIECE($GET(YSCOR),U,I)
SET DIFF=1
if DIFF
QUIT
+6 QUIT DIFF
+7 ;
ADDAUDIT(YSC,YSG) ; add entry in AUDIT node, update value in existing MH RESULTS record
+1 NEW AUDIEN,AUD,DIERR
+2 SET AUDIEN=$PIECE(YSCALE(YSC),U)
+3 DO NOW^%DTC
+4 SET AUD(1,601.921,"+2,"_AUDIEN_",",.01)=%
+5 SET AUD(1,601.921,"+2,"_AUDIEN_",",2)=$$GET1^DIQ(601.84,YSAD_",",14)
+6 FOR I=4:1:7
IF $LENGTH($PIECE(YSCALE(YSC),U,I))
SET AUD(1,601.921,"+2,"_AUDIEN_",",(I-1))=$PIECE(YSCALE(YSC),U,I)
+7 DO UPDATE^DIE("","AUD(1)")
+8 IF $DATA(DIERR)
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="Did not set Audit node in MH RESULTS"
QUIT
+9 DO CLEAN^DILF
+10 ;
+11 ; update existing node with new ones; use FILE^DIE
+12 NEW I,FDA,DIERR,YSGANS
+13 SET YSGANS=$PIECE(YSG,"=",2,5)
+14 FOR I=1:1:4
IF $LENGTH($PIECE(YSGANS,U,I))!$LENGTH($PIECE(YSCALE(YSC),U,I+3))
SET FDA(601.92,AUDIEN_",",(I+2))=$PIECE(YSGANS,U,I)
+15 DO FILE^DIE("","FDA")
+16 IF $DATA(DIERR)
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="Did not update records in MH RESULTS File"
QUIT
+17 DO CLEAN^DILF
+18 KILL %,%H,%I,X
+19 QUIT
+20 ;
ADDSCRE ;add score to MH RESULTS
+1 NEW FDA,FDAIEN,DIERR,STR,YSRNEW,YSRFND
+2 SET YSRNEW=$PIECE($GET(^YTT(601.92,0)),U,3)
SET YSRFND=0
+3 if YSRNEW<100000
SET YSRNEW=100000
+4 LOCK +^YTT(601.92,0):DILOCKTM+10
+5 IF '$TEST
Begin DoDot:1
+6 SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
+7 SET ^TMP($JOB,"YSCOR",2)="Could not get lock on MH RESULTS file"
End DoDot:1
QUIT
+8 FOR
if YSRFND
QUIT
if '$DATA(^YTT(601.92,YSRNEW))
Begin DoDot:1
+9 LOCK +^YTT(601.92,YSRNEW):DILOCKTM
if '$TEST
QUIT
+10 SET STR=$PIECE(YSG,"=",2)
+11 SET FDAIEN(1)=YSRNEW
+12 SET FDA(601.92,"+1,",.01)=YSRNEW
+13 SET FDA(601.92,"+1,",1)=YSAD
+14 SET FDA(601.92,"+1,",2)=$PIECE(YSG,"=",1)
+15 ; raw score
SET FDA(601.92,"+1,",3)=$PIECE(STR,U,1)
+16 ; transformed score 1
if $LENGTH($PIECE(STR,U,2))
SET FDA(601.92,"+1,",4)=$PIECE(STR,U,2)
+17 ; transformed score 2
if $LENGTH($PIECE(STR,U,3))
SET FDA(601.92,"+1,",5)=$PIECE(STR,U,3)
+18 ; transformed score 3
if $LENGTH($PIECE(STR,U,4))
SET FDA(601.92,"+1,",6)=$PIECE(STR,U,4)
+19 DO UPDATE^DIE("","FDA","FDAIEN")
+20 LOCK -^YTT(601.92,YSRNEW)
+21 SET YSRFND=1
End DoDot:1
SET YSRNEW=YSRNEW+1
+22 LOCK -^YTT(601.92,0)
+23 IF $DATA(DIERR)
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="Did not add MH RESULTS entry"
QUIT
+24 QUIT
+25 ;
OLDSCRES(YSCALE,YSAD) ; if existing score, build array containing them
+1 NEW IEN92,STR
+2 SET IEN92=0
+3 FOR
SET IEN92=$ORDER(^YTT(601.92,"AC",YSAD,IEN92))
if 'IEN92
QUIT
Begin DoDot:1
+4 SET STR=$GET(^YTT(601.92,IEN92,0))
+5 SET YSCALE($PIECE(STR,U,3))=STR
End DoDot:1
+6 QUIT
+7 ;
SETREV(YSAD,IEN71) ; set revision value in MH ADMINISTRATIONS to value in MH TEST AND SURVEYS
+1 NEW FDA,DIERR
+2 SET FDA(601.84,YSAD_",",14)=$$GET1^DIQ(601.71,IEN71_",",93)
+3 DO FILE^DIE("","FDA")
+4 IF $DATA(DIERR)
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="Did not set Scoring Revision in MH ADMIN"
+5 DO CLEAN^DILF
+6 QUIT
+7 ;
LDTSCOR(TSARR,YSAD) ;
+1 NEW CNT,DATA,IEN92,RAW,T1,T2,T3
+2 SET IEN92=""
SET CNT=1
+3 IF YSAD'?1N.N
SET TSARR("NOADM")="No Administration to get scores"
QUIT
+4 IF '$DATA(^YTT(601.92,"AC",YSAD))
SET TSARR("NOADM")="No scores in MH RESULTS File"
QUIT
+5 FOR
SET IEN92=$ORDER(^YTT(601.92,"AC",YSAD,IEN92))
if 'IEN92
QUIT
Begin DoDot:1
+6 SET DATA=$GET(^YTT(601.92,IEN92,0))
+7 SET RAW=$PIECE(DATA,U,4)
SET T1=$PIECE(DATA,U,5)
SET T2=$PIECE(DATA,U,6)
SET T3=$PIECE(DATA,U,7)
+8 SET RAW=$SELECT($LENGTH(RAW)=1:" "_RAW,1:RAW)
+9 SET T1=$SELECT($LENGTH(T1)=1:" "_T1,1:T1)
SET T2=$SELECT($LENGTH(T2)=1:" "_T2,1:T2)
SET T3=$SELECT($LENGTH(T3)=1:" "_T3,1:T3)
+10 SET TSARR($PIECE($PIECE(DATA,U,3),":"))=$PIECE(DATA,U,3)_U_RAW_U_T1_U_T2_U_T3
End DoDot:1
+11 QUIT
BYKEY(YSDATA) ; use YSDATA to score by key and put into ^TMP($J,"YSCOR")
+1 ; expects scales to already be in ^TMP($J,"YSG")
+2 NEW I,J,TEST,ANSWERS,SCORES,QID,CID,YS
+3 KILL ^TMP($JOB,"YSCOR")
+4 SET TEST=$PIECE(YSDATA(2),U,3)
SET YS("CODE")=TEST
+5 IF $LENGTH(TEST)
SET TEST=$ORDER(^YTT(601.71,"B",TEST,0))
+6 IF 'TEST
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^(2)="No test found"
QUIT
+7 ; build ANSWERS array
SET I=2
SET J=0
FOR
SET I=$ORDER(YSDATA(I))
if 'I
QUIT
Begin DoDot:1
+8 SET QID=$PIECE(YSDATA(I),U)
SET CID=$PIECE(YSDATA(I),U,3)
+9 SET J=J+1
SET ANSWERS(J,"id")=QID
SET ANSWERS(J,"value")=CID
End DoDot:1
+10 DO SUMKEY^YTSCOREX(TEST,.ANSWERS,.SCORES)
+11 SET J=1
SET ^TMP($JOB,"YSCOR",J)="[DATA]"
+12 SET I=0
FOR
SET I=$ORDER(SCORES(I))
if 'I
QUIT
Begin DoDot:1
+13 SET J=J+1
SET ^TMP($JOB,"YSCOR",J)=$GET(SCORES(I,"name"))_"="_SCORES(I,"raw")
End DoDot:1
+14 QUIT
