YTQPXRM8 ;ALB/ASF - PSYCH TEST API FOR CLINICAL REMINDERS ;Jan 19, 2024@12:23:12
;;5.01;MENTAL HEALTH;**98,123,141,244**;Dec 30, 1994;Build 5
;
;
Q
SETSCR(YSDATA,YS) ;save scratch CR
;input: DFN = Patient ien
;input: CODE= Test NAME from 601.71
;input: HANDLE= identifer for cprs GIU
;input: YS(1) thru YS(N) WP entries as
; QuestionID^AnswerID^LegacyValue^IsMultipleChoice
;output: [DATA] vs [ERROR]
N YSHANDLE,YSDFN,YSFLAG,YSTN,YSNOW,YSCODE,YSIEN,N,N2,N3,X,Y,%
S YSDATA(1)="[ERROR]",YSDATA(2)=U_U_YS("CODE")
S YSHANDLE=$G(YS("HANDLE"),0)
S YSDFN=$G(YS("DFN"))
S YSCODE=$G(YS("CODE"),0)
S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
I YSDFN'?1N.N S YSDATA(2)="bad DFN setscr" Q ;-->out
I YSTN'?1N.N S YSDATA(2)="bad test num setcr" Q ;-->out
D NOW^%DTC S YSNOW=%
S YSFLAG=0
S N=0
F S N=N+1 Q:'$D(YS(N)) D
.S YSIEN=$$NEW(601.94)
.I YSIEN'?1N.N D QUIT
..S YSFLAG=1
..S YSDATA(1)="[ERROR]"
..S YSDATA(2)="bad cr scratch ien"
. ;
.L +^YTT(601.94,YSIEN):DILOCKTM+10
.I '$T D QUIT
..S YSFLAG=1
..S YSDATA(1)="[ERROR]"
..S YSDATA(2)="time out"
.S ^YTT(601.94,YSIEN,0)=YSIEN_U_YSDFN_U_YSNOW_U_YSTN_U_YS(N)_DUZ
.S:YSHANDLE'=0 ^YTT(601.94,YSIEN,2)=YSHANDLE
.S ^YTT(601.94,"B",YSIEN,YSIEN)=""
.S ^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN)=""
.S ^YTT(601.94,"AD",YSNOW,YSIEN)=""
.S ^YTT(601.94,"AE",YSHANDLE,YSIEN)=""
.;answer wp
.S N2=N,N3=0 F S N2=$O(YS(N2)) Q:(N2=(N+1))!(N2'>0) S N3=N3+1,^YTT(601.94,YSIEN,1,N3,0)=YS(N2)
.L -^YTT(601.94,YSIEN)
I 'YSFLAG S YSDATA(1)="[DATA]",YSDATA(2)="OK"
Q
;
NEW(YSFILEN) ;Adding New Entries - return an internal number - EXTRINSIC FUNCTION
;if $D YSPROG then National and pointers less than 100,000 else pointers greater than 100,000
N MHQ2X,YS
K YSPROG
S:$D(^XUSEC("YSPROG",DUZ)) YSPROG=1
S YS=$P($G(^YTT(YSFILEN,0)),U,3) S:YS<1 YS=1
I $D(YSPROG) S YS=$S(YS<100000:YS,1:1)
I '$D(YSPROG) S YS=$S(YS>100000:YS,1:100000)
L +^YTT(YSFILEN,0):DILOCKTM+10
I '$T QUIT ""
F MHQ2X=YS:1 I '$D(^YTT(YSFILEN,MHQ2X)) D Q:MHQ2XFND
. S MHQ2XFND=1
. S ^YTT(YSFILEN,MHQ2X,0)=MHQ2X
. S $P(^YTT(YSFILEN,0),U,3)=MHQ2X
. S $P(^YTT(YSFILEN,0),U,4)=$P($G(^YTT(YSFILEN,0)),U,4)+1
L -^YTT(YSFILEN,0)
Q MHQ2X
;
GETSCR(YSDATA,YS) ;get CR scratch -for a user,patient and instrument
; input: DFN as Patient Ien
; input: CODE as Instrument name- 601.71
; input: HANDLE= identifer for cprs GIU
; output: SCRATCH list in format
; QuestionID^AnswerValue^AnswerLegacyValue^IsMultipleChoice^Response Date
N G,G2,YSQN,YSTN,YSDFN,N,N1,N2,X1,X2,X,YSIEN,YSRDATE,%,YSHANDLE,YSCODE
K ^TMP($J,"YSSCR") S YSDATA=$NA(^TMP($J,"YSSCR"))
S ^TMP($J,"YSSCR",1)="[ERROR]"
S YSDFN=$G(YS("DFN"))
S YSCODE=$G(YS("CODE"),0)
S YSHANDLE=$G(YS("HANDLE"),0)
S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
I YSDFN'?1N.N S ^TMP($J,"YSSCR",2)="bad ad num getscr" Q ;-->out
I YSTN'?1N.N S ^TMP($J,"YSSCR",2)="bad test num getscr" Q ;-->out
D NOW^%DTC S X=%
D H^%DTC S X1=%H*86400+%T
S YSIEN=0,N1=1
F S YSIEN=$O(^YTT(601.94,"AE",YSHANDLE,YSIEN)) Q:YSIEN'>0 D
. S G=$G(^YTT(601.94,YSIEN,0))
. Q:($P(G,U,2)'=YSDFN) ;--> out wrong patient
. Q:($P(G,U,9)'=DUZ) ;--> out wrong user
. Q:($P(G,U,4)'=YSTN) ;--> out wrong test
. S X=$P(G,U,3)
. D H^%DTC S X2=%H*86400+%T
. Q:((X1-X2)>86400) ;-->out too old
. S G2=$G(^YTT(601.94,YSIEN,2))
. S YSQN=$P(G,U,5)
. S N1=N1+1
. S ^TMP($J,"YSSCR",N1)=$P(G,U,5,8)_U_$P(G,U,3)
. S N2=0 F S N2=$O(^YTT(601.94,YSIEN,1,N2)) Q:N2'>0 D
.. S N1=N1+1
.. S ^TMP($J,"YSSCR",N1)=YSQN_U_$G(^YTT(601.94,YSIEN,1,N2,0))
S ^TMP($J,"YSSCR",1)="[DATA]"
S:'$D(^TMP($J,"YSSCR",2)) ^TMP($J,"YSSCR",2)="ok-none found!"
Q
KILLSCR(YSDATA,YS) ;delete scratch data
;input: DFN = Patient ien
;input: CODE= Test name from 601.71
;input: HANDLE= identifer for cprs GIU
;output: [DATA] vs [ERROR]
N YSDFN,YSTN,YSIEN,DA,YSRDATE,N,DIK
S YSDATA(1)="[ERROR]"
S YSDFN=$G(YS("DFN"))
I YSDFN'?1N.N S YSDATA(2)="bad DFN killscr" Q ;-->out
S YSHANDLE=$G(YS("HANDLE"),0)
S YSCODE=$G(YS("CODE"),0)
I YSCODE=0 D MULTT Q ;-->out ASF 8/27/08
S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
I YSTN'?1N.N S YSDATA(2)="bad test num killscr" Q ;-->out
S YSIEN=0
F S YSIEN=$O(^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN)) Q:YSIEN'>0 D
. D KILLS(YSDFN,YSTN,YSIEN)
S YSDATA(1)="[DATA]"
Q
MULTT ;multiple test remover
S YSTN=0 F S YSTN=$O(^YTT(601.94,"AF",DUZ,YSDFN,YSTN)) Q:YSTN'>0 D
. S YSIEN=0
. F S YSIEN=$O(^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN)) Q:YSIEN'>0 D
. . D KILLS(YSDFN,YSTN,YSIEN)
S YSDATA(1)="[DATA]"
Q
;
KILLS(YSDFN,YSTN,YSIEN) ;
N YSNODE0,DA,DIK
S YSNODE0=$G(^YTT(601.94,YSIEN,0))
Q:($P(YSNODE0,U,2)'=YSDFN) ;--> out wrong patient
Q:($P(YSNODE0,U,9)'=DUZ) ;--> out wrong user
Q:($P(YSNODE0,U,4)'=YSTN) ;--> out wrong test
L +^YTT(601.94,0):DILOCKTM+10
I '$T QUIT
S DA=YSIEN
S DIK="^YTT(601.94,"
D ^DIK
L -^YTT(601.94,0)
Q
;
OLDKILL ;clean up scratch file
N X1,X2,X,DA,DIK,YSWHEN,YSOUT
S X1=DT,X2=-2 D C^%DTC
S YSOUT=X
S DIK="^YTT(601.94,"
S YSWHEN=0 F S YSWHEN=$O(^YTT(601.94,"AD",YSWHEN)) Q:YSWHEN'>0!(YSWHEN>YSOUT) D
. S DA=0 F S DA=$O(^YTT(601.94,"AD",YSWHEN,DA)) Q:DA'>0 D ^DIK
Q
;
GETTSC(YSCRA,YS) ;patch 123, calculate Scale scores from Scratch Global
; input: DFN as Patient Ien
; input: CODE as Instrument name- 601.71
; input: HANDLE= identifer for cprs GIU
; output: Temp SCALE SCORES in format: '*' + Scale IEN + '~' + Scale Score
N YSKEYI,YSQN,YSTN,YSDFN,YSIEN,YSTARG,YSVAL,YSRTN71,YSHANDLE,YSCODE,YSRAW,YSCH,YSCH1
N ARR,FAIL,G,SCA,SCARR,STR,N,N1,N2,X1,X2,X,%
S YSDFN=$G(YS("DFN"))
S YSCODE=$G(YS("CODE"),0)
S YSHANDLE=$G(YS("HANDLE"),0)
S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
S FAIL=0
K ^TMP($J,"YSSCR")
S YSCRA=$NA(^TMP($J,"YSSCR"))
S ^TMP($J,"YSSCR",1)="[ERROR]"
I YSDFN'?1N.N S ^TMP($J,"YSSCR",2)="bad ad num getscr" Q ;-->out
I YSTN'?1N.N S ^TMP($J,"YSSCR",2)="bad test num getscr" Q ;-->out
;map scratch answers to questions, put in ARR
D MAPSCR I FAIL Q
;get scales for instrument
D SCALEG^YTQAPI3(.YSDATA,.YS)
;determine if M scoring routine exists, if yes, score, quit
S YSRTN71=$$GET1^DIQ(601.71,YSTN_",",92)
I (YSRTN71'=""),(YSRTN71'="YTSCORE") D CMPLX Q
;otherwise scoring keys used to score
D SETARR(.SCARR,"SIEN")
S SCA=""
F S SCA=$O(SCARR(SCA)) Q:'SCA S YSRAW="0" D S SCARR(SCA)=YSRAW
.S YSKEYI=0 F S YSKEYI=$O(^YTT(601.91,"AC",SCA,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 YSCH=$G(ARR(YSQN),0)
..Q:YSCH'>0
..S YSCH1=$G(^YTT(601.75,YSCH,1))
..I YSCH1=YSTARG S YSRAW=YSRAW+YSVAL
I ^TMP($J,"YSSCR",1)'="[DATA]" S ^TMP($J,"YSSCR",2)="Scratch data not found for Scoring Keys!" Q
S STR="",SCA="",N=1
F S SCA=$O(SCARR(SCA)) Q:'SCA D
.S N=N+1,^TMP($J,"YSSCR",N)="*"_SCA_"~"_SCARR(SCA)
Q
;
MAPSCR ;
N NX
D NOW^%DTC S X=%
D H^%DTC S X1=%H*86400+%T
S YSIEN=0
F S YSIEN=$O(^YTT(601.94,"AE",YSHANDLE,YSIEN)) Q:YSIEN'>0 D
.S G=$G(^YTT(601.94,YSIEN,0))
.Q:($P(G,U,2)'=YSDFN) ;--> out wrong patient
.Q:($P(G,U,9)'=DUZ) ;--> out wrong user
.Q:($P(G,U,4)'=YSTN) ;--> out wrong test
.S X=$P(G,U,3)
.D H^%DTC S X2=%H*86400+%T
.Q:((X1-X2)>86400) ;-->out too old
.S YSQN=$P(G,U,5)
.Q:'$D(YSQN)
.;
.S ARR(YSQN)=$P(G,U,6)
.;need to handle questions that are not multiple choice but have integer answeres
.I ARR(YSQN)="" D
..Q:'$$ANSWER(YSQN) ; make sure Answer is integer value
..S NX=0 F S NX=$O(^YTT(601.94,YSIEN,1,NX)) Q:NX'>0 D
...S ANS=^YTT(601.94,YSIEN,1,NX,0)
...I ANS?1N.N S ARR(YSQN)=";"_NX_U_ANS
.;
I '$D(ARR) S ^TMP($J,"YSSCR",2)="Scratch data not found!",FAIL=1 Q
S ^TMP($J,"YSSCR",1)="[DATA]"
Q
;
CMPLX ;
N FAIL,I,QUE,N,SCA,SNM,YS76,YSDATA,YSRTN
I '$D(ARR) S ^TMP($J,"YSSCR",2)="In Get Temp Score, ARR not built",FAIL=1 Q
;loop through ^TMP($J,"YSG" Set up a mapping array
I '$D(^TMP($J,"YSG")) S ^TMP($J,"YSSCR",2)="In Get Temp Score, No YSG global",FAIL=1 Q
;
D SETARR(.SCARR,"NM")
S QUE="",N=3
F S QUE=$O(ARR(QUE)) Q:'QUE D
.S YS76=$O(^YTT(601.76,"AE",QUE,"")) I '$G(YS76) Q
.I '$D(YSDATA(2)) S $P(YSDATA(2),U,3)=YSCODE
.S STR=$G(^YTT(601.76,YS76,0))
.I $G(ARR(QUE)) S ARR(QUE)=U_ARR(QUE)
.S YSDATA(N)=QUE_U_$P(STR,U,3)_ARR(QUE),N=N+1
S YSRTN="DLLSTR^"_YSRTN71_"(.YSDATA,.YS,1)"
D @YSRTN
I '$D(^TMP($J,"YSCOR")) S ^TMP($J,"YSSCR",2)="Complex scoring failed!" Q
S N=1
F I=2:1 Q:'$D(^TMP($J,"YSCOR",I)) D
.S SCA=^TMP($J,"YSCOR",I)
.S SNM=$P(SCA,"=",1)
.I $D(SCARR(SNM)) S N=N+1,^TMP($J,"YSSCR",N)="*"_SCARR(SNM)_"~"_$P($P(SCA,"=",2),U)
K ^TMP($J,"YSG"),^TMP($J,"YSCOR")
Q
SETARR(SCARR,NODE) ;
;set SCARR array to be used in calculating score
N I,STR1,SCA,SNM,IX,VAL
F I=2:1 Q:'$D(^TMP($J,"YSG",I)) I ^TMP($J,"YSG",I)?1"Scale".E D
.S STR1=$G(^TMP($J,"YSG",I)),SCA=$P($P(STR1,"=",2),U),SNM=$P($P(STR1,"=",2),U,4)
.S IX=$S(NODE="NM":SNM,NODE="SIEN":SCA,1:"ERR")
.S VAL=$S(NODE="NM":SCA,1:"")
.S SCARR(IX)=VAL
Q
ANSWER(YSQN) ;
N NODE
S NODE=$$GET1^DIQ(601.72,YSQN_",",3,"I")
I (NODE=2)!(NODE=7) Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPXRM8 9196 printed Dec 13, 2024@02:18:40 Page 2
YTQPXRM8 ;ALB/ASF - PSYCH TEST API FOR CLINICAL REMINDERS ;Jan 19, 2024@12:23:12
+1 ;;5.01;MENTAL HEALTH;**98,123,141,244**;Dec 30, 1994;Build 5
+2 ;
+3 ;
+4 QUIT
SETSCR(YSDATA,YS) ;save scratch CR
+1 ;input: DFN = Patient ien
+2 ;input: CODE= Test NAME from 601.71
+3 ;input: HANDLE= identifer for cprs GIU
+4 ;input: YS(1) thru YS(N) WP entries as
+5 ; QuestionID^AnswerID^LegacyValue^IsMultipleChoice
+6 ;output: [DATA] vs [ERROR]
+7 NEW YSHANDLE,YSDFN,YSFLAG,YSTN,YSNOW,YSCODE,YSIEN,N,N2,N3,X,Y,%
+8 SET YSDATA(1)="[ERROR]"
SET YSDATA(2)=U_U_YS("CODE")
+9 SET YSHANDLE=$GET(YS("HANDLE"),0)
+10 SET YSDFN=$GET(YS("DFN"))
+11 SET YSCODE=$GET(YS("CODE"),0)
+12 SET YSTN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+13 ;-->out
IF YSDFN'?1N.N
SET YSDATA(2)="bad DFN setscr"
QUIT
+14 ;-->out
IF YSTN'?1N.N
SET YSDATA(2)="bad test num setcr"
QUIT
+15 DO NOW^%DTC
SET YSNOW=%
+16 SET YSFLAG=0
+17 SET N=0
+18 FOR
SET N=N+1
if '$DATA(YS(N))
QUIT
Begin DoDot:1
+19 SET YSIEN=$$NEW(601.94)
+20 IF YSIEN'?1N.N
Begin DoDot:2
+21 SET YSFLAG=1
+22 SET YSDATA(1)="[ERROR]"
+23 SET YSDATA(2)="bad cr scratch ien"
End DoDot:2
QUIT
+24 ;
+25 LOCK +^YTT(601.94,YSIEN):DILOCKTM+10
+26 IF '$TEST
Begin DoDot:2
+27 SET YSFLAG=1
+28 SET YSDATA(1)="[ERROR]"
+29 SET YSDATA(2)="time out"
End DoDot:2
QUIT
+30 SET ^YTT(601.94,YSIEN,0)=YSIEN_U_YSDFN_U_YSNOW_U_YSTN_U_YS(N)_DUZ
+31 if YSHANDLE'=0
SET ^YTT(601.94,YSIEN,2)=YSHANDLE
+32 SET ^YTT(601.94,"B",YSIEN,YSIEN)=""
+33 SET ^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN)=""
+34 SET ^YTT(601.94,"AD",YSNOW,YSIEN)=""
+35 SET ^YTT(601.94,"AE",YSHANDLE,YSIEN)=""
+36 ;answer wp
+37 SET N2=N
SET N3=0
FOR
SET N2=$ORDER(YS(N2))
if (N2=(N+1))!(N2'>0)
QUIT
SET N3=N3+1
SET ^YTT(601.94,YSIEN,1,N3,0)=YS(N2)
+38 LOCK -^YTT(601.94,YSIEN)
End DoDot:1
+39 IF 'YSFLAG
SET YSDATA(1)="[DATA]"
SET YSDATA(2)="OK"
+40 QUIT
+41 ;
NEW(YSFILEN) ;Adding New Entries - return an internal number - EXTRINSIC FUNCTION
+1 ;if $D YSPROG then National and pointers less than 100,000 else pointers greater than 100,000
+2 NEW MHQ2X,YS
+3 KILL YSPROG
+4 if $DATA(^XUSEC("YSPROG",DUZ))
SET YSPROG=1
+5 SET YS=$PIECE($GET(^YTT(YSFILEN,0)),U,3)
if YS<1
SET YS=1
+6 IF $DATA(YSPROG)
SET YS=$SELECT(YS<100000:YS,1:1)
+7 IF '$DATA(YSPROG)
SET YS=$SELECT(YS>100000:YS,1:100000)
+8 LOCK +^YTT(YSFILEN,0):DILOCKTM+10
+9 IF '$TEST
QUIT ""
+10 FOR MHQ2X=YS:1
IF '$DATA(^YTT(YSFILEN,MHQ2X))
Begin DoDot:1
+11 SET MHQ2XFND=1
+12 SET ^YTT(YSFILEN,MHQ2X,0)=MHQ2X
+13 SET $PIECE(^YTT(YSFILEN,0),U,3)=MHQ2X
+14 SET $PIECE(^YTT(YSFILEN,0),U,4)=$PIECE($GET(^YTT(YSFILEN,0)),U,4)+1
End DoDot:1
if MHQ2XFND
QUIT
+15 LOCK -^YTT(YSFILEN,0)
+16 QUIT MHQ2X
+17 ;
GETSCR(YSDATA,YS) ;get CR scratch -for a user,patient and instrument
+1 ; input: DFN as Patient Ien
+2 ; input: CODE as Instrument name- 601.71
+3 ; input: HANDLE= identifer for cprs GIU
+4 ; output: SCRATCH list in format
+5 ; QuestionID^AnswerValue^AnswerLegacyValue^IsMultipleChoice^Response Date
+6 NEW G,G2,YSQN,YSTN,YSDFN,N,N1,N2,X1,X2,X,YSIEN,YSRDATE,%,YSHANDLE,YSCODE
+7 KILL ^TMP($JOB,"YSSCR")
SET YSDATA=$NAME(^TMP($JOB,"YSSCR"))
+8 SET ^TMP($JOB,"YSSCR",1)="[ERROR]"
+9 SET YSDFN=$GET(YS("DFN"))
+10 SET YSCODE=$GET(YS("CODE"),0)
+11 SET YSHANDLE=$GET(YS("HANDLE"),0)
+12 SET YSTN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+13 ;-->out
IF YSDFN'?1N.N
SET ^TMP($JOB,"YSSCR",2)="bad ad num getscr"
QUIT
+14 ;-->out
IF YSTN'?1N.N
SET ^TMP($JOB,"YSSCR",2)="bad test num getscr"
QUIT
+15 DO NOW^%DTC
SET X=%
+16 DO H^%DTC
SET X1=%H*86400+%T
+17 SET YSIEN=0
SET N1=1
+18 FOR
SET YSIEN=$ORDER(^YTT(601.94,"AE",YSHANDLE,YSIEN))
if YSIEN'>0
QUIT
Begin DoDot:1
+19 SET G=$GET(^YTT(601.94,YSIEN,0))
+20 ;--> out wrong patient
if ($PIECE(G,U,2)'=YSDFN)
QUIT
+21 ;--> out wrong user
if ($PIECE(G,U,9)'=DUZ)
QUIT
+22 ;--> out wrong test
if ($PIECE(G,U,4)'=YSTN)
QUIT
+23 SET X=$PIECE(G,U,3)
+24 DO H^%DTC
SET X2=%H*86400+%T
+25 ;-->out too old
if ((X1-X2)>86400)
QUIT
+26 SET G2=$GET(^YTT(601.94,YSIEN,2))
+27 SET YSQN=$PIECE(G,U,5)
+28 SET N1=N1+1
+29 SET ^TMP($JOB,"YSSCR",N1)=$PIECE(G,U,5,8)_U_$PIECE(G,U,3)
+30 SET N2=0
FOR
SET N2=$ORDER(^YTT(601.94,YSIEN,1,N2))
if N2'>0
QUIT
Begin DoDot:2
+31 SET N1=N1+1
+32 SET ^TMP($JOB,"YSSCR",N1)=YSQN_U_$GET(^YTT(601.94,YSIEN,1,N2,0))
End DoDot:2
End DoDot:1
+33 SET ^TMP($JOB,"YSSCR",1)="[DATA]"
+34 if '$DATA(^TMP($JOB,"YSSCR",2))
SET ^TMP($JOB,"YSSCR",2)="ok-none found!"
+35 QUIT
KILLSCR(YSDATA,YS) ;delete scratch data
+1 ;input: DFN = Patient ien
+2 ;input: CODE= Test name from 601.71
+3 ;input: HANDLE= identifer for cprs GIU
+4 ;output: [DATA] vs [ERROR]
+5 NEW YSDFN,YSTN,YSIEN,DA,YSRDATE,N,DIK
+6 SET YSDATA(1)="[ERROR]"
+7 SET YSDFN=$GET(YS("DFN"))
+8 ;-->out
IF YSDFN'?1N.N
SET YSDATA(2)="bad DFN killscr"
QUIT
+9 SET YSHANDLE=$GET(YS("HANDLE"),0)
+10 SET YSCODE=$GET(YS("CODE"),0)
+11 ;-->out ASF 8/27/08
IF YSCODE=0
DO MULTT
QUIT
+12 SET YSTN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+13 ;-->out
IF YSTN'?1N.N
SET YSDATA(2)="bad test num killscr"
QUIT
+14 SET YSIEN=0
+15 FOR
SET YSIEN=$ORDER(^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN))
if YSIEN'>0
QUIT
Begin DoDot:1
+16 DO KILLS(YSDFN,YSTN,YSIEN)
End DoDot:1
+17 SET YSDATA(1)="[DATA]"
+18 QUIT
MULTT ;multiple test remover
+1 SET YSTN=0
FOR
SET YSTN=$ORDER(^YTT(601.94,"AF",DUZ,YSDFN,YSTN))
if YSTN'>0
QUIT
Begin DoDot:1
+2 SET YSIEN=0
+3 FOR
SET YSIEN=$ORDER(^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN))
if YSIEN'>0
QUIT
Begin DoDot:2
+4 DO KILLS(YSDFN,YSTN,YSIEN)
End DoDot:2
End DoDot:1
+5 SET YSDATA(1)="[DATA]"
+6 QUIT
+7 ;
KILLS(YSDFN,YSTN,YSIEN) ;
+1 NEW YSNODE0,DA,DIK
+2 SET YSNODE0=$GET(^YTT(601.94,YSIEN,0))
+3 ;--> out wrong patient
if ($PIECE(YSNODE0,U,2)'=YSDFN)
QUIT
+4 ;--> out wrong user
if ($PIECE(YSNODE0,U,9)'=DUZ)
QUIT
+5 ;--> out wrong test
if ($PIECE(YSNODE0,U,4)'=YSTN)
QUIT
+6 LOCK +^YTT(601.94,0):DILOCKTM+10
+7 IF '$TEST
QUIT
+8 SET DA=YSIEN
+9 SET DIK="^YTT(601.94,"
+10 DO ^DIK
+11 LOCK -^YTT(601.94,0)
+12 QUIT
+13 ;
OLDKILL ;clean up scratch file
+1 NEW X1,X2,X,DA,DIK,YSWHEN,YSOUT
+2 SET X1=DT
SET X2=-2
DO C^%DTC
+3 SET YSOUT=X
+4 SET DIK="^YTT(601.94,"
+5 SET YSWHEN=0
FOR
SET YSWHEN=$ORDER(^YTT(601.94,"AD",YSWHEN))
if YSWHEN'>0!(YSWHEN>YSOUT)
QUIT
Begin DoDot:1
+6 SET DA=0
FOR
SET DA=$ORDER(^YTT(601.94,"AD",YSWHEN,DA))
if DA'>0
QUIT
DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
GETTSC(YSCRA,YS) ;patch 123, calculate Scale scores from Scratch Global
+1 ; input: DFN as Patient Ien
+2 ; input: CODE as Instrument name- 601.71
+3 ; input: HANDLE= identifer for cprs GIU
+4 ; output: Temp SCALE SCORES in format: '*' + Scale IEN + '~' + Scale Score
+5 NEW YSKEYI,YSQN,YSTN,YSDFN,YSIEN,YSTARG,YSVAL,YSRTN71,YSHANDLE,YSCODE,YSRAW,YSCH,YSCH1
+6 NEW ARR,FAIL,G,SCA,SCARR,STR,N,N1,N2,X1,X2,X,%
+7 SET YSDFN=$GET(YS("DFN"))
+8 SET YSCODE=$GET(YS("CODE"),0)
+9 SET YSHANDLE=$GET(YS("HANDLE"),0)
+10 SET YSTN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+11 SET FAIL=0
+12 KILL ^TMP($JOB,"YSSCR")
+13 SET YSCRA=$NAME(^TMP($JOB,"YSSCR"))
+14 SET ^TMP($JOB,"YSSCR",1)="[ERROR]"
+15 ;-->out
IF YSDFN'?1N.N
SET ^TMP($JOB,"YSSCR",2)="bad ad num getscr"
QUIT
+16 ;-->out
IF YSTN'?1N.N
SET ^TMP($JOB,"YSSCR",2)="bad test num getscr"
QUIT
+17 ;map scratch answers to questions, put in ARR
+18 DO MAPSCR
IF FAIL
QUIT
+19 ;get scales for instrument
+20 DO SCALEG^YTQAPI3(.YSDATA,.YS)
+21 ;determine if M scoring routine exists, if yes, score, quit
+22 SET YSRTN71=$$GET1^DIQ(601.71,YSTN_",",92)
+23 IF (YSRTN71'="")
IF (YSRTN71'="YTSCORE")
DO CMPLX
QUIT
+24 ;otherwise scoring keys used to score
+25 DO SETARR(.SCARR,"SIEN")
+26 SET SCA=""
+27 FOR
SET SCA=$ORDER(SCARR(SCA))
if 'SCA
QUIT
SET YSRAW="0"
Begin DoDot:1
+28 SET YSKEYI=0
FOR
SET YSKEYI=$ORDER(^YTT(601.91,"AC",SCA,YSKEYI))
if YSKEYI'>0
QUIT
Begin DoDot:2
+29 SET G=^YTT(601.91,YSKEYI,0)
+30 SET YSQN=$PIECE(G,U,3)
SET YSTARG=$PIECE(G,U,4)
SET YSVAL=$PIECE(G,U,5)
+31 SET YSCH=$GET(ARR(YSQN),0)
+32 if YSCH'>0
QUIT
+33 SET YSCH1=$GET(^YTT(601.75,YSCH,1))
+34 IF YSCH1=YSTARG
SET YSRAW=YSRAW+YSVAL
End DoDot:2
End DoDot:1
SET SCARR(SCA)=YSRAW
+35 IF ^TMP($JOB,"YSSCR",1)'="[DATA]"
SET ^TMP($JOB,"YSSCR",2)="Scratch data not found for Scoring Keys!"
QUIT
+36 SET STR=""
SET SCA=""
SET N=1
+37 FOR
SET SCA=$ORDER(SCARR(SCA))
if 'SCA
QUIT
Begin DoDot:1
+38 SET N=N+1
SET ^TMP($JOB,"YSSCR",N)="*"_SCA_"~"_SCARR(SCA)
End DoDot:1
+39 QUIT
+40 ;
MAPSCR ;
+1 NEW NX
+2 DO NOW^%DTC
SET X=%
+3 DO H^%DTC
SET X1=%H*86400+%T
+4 SET YSIEN=0
+5 FOR
SET YSIEN=$ORDER(^YTT(601.94,"AE",YSHANDLE,YSIEN))
if YSIEN'>0
QUIT
Begin DoDot:1
+6 SET G=$GET(^YTT(601.94,YSIEN,0))
+7 ;--> out wrong patient
if ($PIECE(G,U,2)'=YSDFN)
QUIT
+8 ;--> out wrong user
if ($PIECE(G,U,9)'=DUZ)
QUIT
+9 ;--> out wrong test
if ($PIECE(G,U,4)'=YSTN)
QUIT
+10 SET X=$PIECE(G,U,3)
+11 DO H^%DTC
SET X2=%H*86400+%T
+12 ;-->out too old
if ((X1-X2)>86400)
QUIT
+13 SET YSQN=$PIECE(G,U,5)
+14 if '$DATA(YSQN)
QUIT
+15 ;
+16 SET ARR(YSQN)=$PIECE(G,U,6)
+17 ;need to handle questions that are not multiple choice but have integer answeres
+18 IF ARR(YSQN)=""
Begin DoDot:2
+19 ; make sure Answer is integer value
if '$$ANSWER(YSQN)
QUIT
+20 SET NX=0
FOR
SET NX=$ORDER(^YTT(601.94,YSIEN,1,NX))
if NX'>0
QUIT
Begin DoDot:3
+21 SET ANS=^YTT(601.94,YSIEN,1,NX,0)
+22 IF ANS?1N.N
SET ARR(YSQN)=";"_NX_U_ANS
End DoDot:3
End DoDot:2
+23 ;
End DoDot:1
+24 IF '$DATA(ARR)
SET ^TMP($JOB,"YSSCR",2)="Scratch data not found!"
SET FAIL=1
QUIT
+25 SET ^TMP($JOB,"YSSCR",1)="[DATA]"
+26 QUIT
+27 ;
CMPLX ;
+1 NEW FAIL,I,QUE,N,SCA,SNM,YS76,YSDATA,YSRTN
+2 IF '$DATA(ARR)
SET ^TMP($JOB,"YSSCR",2)="In Get Temp Score, ARR not built"
SET FAIL=1
QUIT
+3 ;loop through ^TMP($J,"YSG" Set up a mapping array
+4 IF '$DATA(^TMP($JOB,"YSG"))
SET ^TMP($JOB,"YSSCR",2)="In Get Temp Score, No YSG global"
SET FAIL=1
QUIT
+5 ;
+6 DO SETARR(.SCARR,"NM")
+7 SET QUE=""
SET N=3
+8 FOR
SET QUE=$ORDER(ARR(QUE))
if 'QUE
QUIT
Begin DoDot:1
+9 SET YS76=$ORDER(^YTT(601.76,"AE",QUE,""))
IF '$GET(YS76)
QUIT
+10 IF '$DATA(YSDATA(2))
SET $PIECE(YSDATA(2),U,3)=YSCODE
+11 SET STR=$GET(^YTT(601.76,YS76,0))
+12 IF $GET(ARR(QUE))
SET ARR(QUE)=U_ARR(QUE)
+13 SET YSDATA(N)=QUE_U_$PIECE(STR,U,3)_ARR(QUE)
SET N=N+1
End DoDot:1
+14 SET YSRTN="DLLSTR^"_YSRTN71_"(.YSDATA,.YS,1)"
+15 DO @YSRTN
+16 IF '$DATA(^TMP($JOB,"YSCOR"))
SET ^TMP($JOB,"YSSCR",2)="Complex scoring failed!"
QUIT
+17 SET N=1
+18 FOR I=2:1
if '$DATA(^TMP($JOB,"YSCOR",I))
QUIT
Begin DoDot:1
+19 SET SCA=^TMP($JOB,"YSCOR",I)
+20 SET SNM=$PIECE(SCA,"=",1)
+21 IF $DATA(SCARR(SNM))
SET N=N+1
SET ^TMP($JOB,"YSSCR",N)="*"_SCARR(SNM)_"~"_$PIECE($PIECE(SCA,"=",2),U)
End DoDot:1
+22 KILL ^TMP($JOB,"YSG"),^TMP($JOB,"YSCOR")
+23 QUIT
SETARR(SCARR,NODE) ;
+1 ;set SCARR array to be used in calculating score
+2 NEW I,STR1,SCA,SNM,IX,VAL
+3 FOR I=2:1
if '$DATA(^TMP($JOB,"YSG",I))
QUIT
IF ^TMP($JOB,"YSG",I)?1"Scale".E
Begin DoDot:1
+4 SET STR1=$GET(^TMP($JOB,"YSG",I))
SET SCA=$PIECE($PIECE(STR1,"=",2),U)
SET SNM=$PIECE($PIECE(STR1,"=",2),U,4)
+5 SET IX=$SELECT(NODE="NM":SNM,NODE="SIEN":SCA,1:"ERR")
+6 SET VAL=$SELECT(NODE="NM":SCA,1:"")
+7 SET SCARR(IX)=VAL
End DoDot:1
+8 QUIT
ANSWER(YSQN) ;
+1 NEW NODE
+2 SET NODE=$$GET1^DIQ(601.72,YSQN_",",3,"I")
+3 IF (NODE=2)!(NODE=7)
QUIT 1
+4 QUIT 0
