- 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 Jan 18, 2025@03:19:47 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