Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQPXRM8

YTQPXRM8.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. Q
  1. SETSCR(YSDATA,YS) ;save scratch CR
  1. ;input: DFN = Patient ien
  1. ;input: CODE= Test NAME from 601.71
  1. ;input: HANDLE= identifer for cprs GIU
  1. ;input: YS(1) thru YS(N) WP entries as
  1. ; QuestionID^AnswerID^LegacyValue^IsMultipleChoice
  1. ;output: [DATA] vs [ERROR]
  1. N YSHANDLE,YSDFN,YSFLAG,YSTN,YSNOW,YSCODE,YSIEN,N,N2,N3,X,Y,%
  1. S YSDATA(1)="[ERROR]",YSDATA(2)=U_U_YS("CODE")
  1. S YSHANDLE=$G(YS("HANDLE"),0)
  1. S YSDFN=$G(YS("DFN"))
  1. S YSCODE=$G(YS("CODE"),0)
  1. S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
  1. I YSDFN'?1N.N S YSDATA(2)="bad DFN setscr" Q ;-->out
  1. I YSTN'?1N.N S YSDATA(2)="bad test num setcr" Q ;-->out
  1. D NOW^%DTC S YSNOW=%
  1. S YSFLAG=0
  1. S N=0
  1. F S N=N+1 Q:'$D(YS(N)) D
  1. .S YSIEN=$$NEW(601.94)
  1. .I YSIEN'?1N.N D QUIT
  1. ..S YSFLAG=1
  1. ..S YSDATA(1)="[ERROR]"
  1. ..S YSDATA(2)="bad cr scratch ien"
  1. . ;
  1. .L +^YTT(601.94,YSIEN):DILOCKTM+10
  1. .I '$T D QUIT
  1. ..S YSFLAG=1
  1. ..S YSDATA(1)="[ERROR]"
  1. ..S YSDATA(2)="time out"
  1. .S ^YTT(601.94,YSIEN,0)=YSIEN_U_YSDFN_U_YSNOW_U_YSTN_U_YS(N)_DUZ
  1. .S:YSHANDLE'=0 ^YTT(601.94,YSIEN,2)=YSHANDLE
  1. .S ^YTT(601.94,"B",YSIEN,YSIEN)=""
  1. .S ^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN)=""
  1. .S ^YTT(601.94,"AD",YSNOW,YSIEN)=""
  1. .S ^YTT(601.94,"AE",YSHANDLE,YSIEN)=""
  1. .;answer wp
  1. .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)
  1. .L -^YTT(601.94,YSIEN)
  1. I 'YSFLAG S YSDATA(1)="[DATA]",YSDATA(2)="OK"
  1. Q
  1. ;
  1. 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
  1. N MHQ2X,YS
  1. K YSPROG
  1. S:$D(^XUSEC("YSPROG",DUZ)) YSPROG=1
  1. S YS=$P($G(^YTT(YSFILEN,0)),U,3) S:YS<1 YS=1
  1. I $D(YSPROG) S YS=$S(YS<100000:YS,1:1)
  1. I '$D(YSPROG) S YS=$S(YS>100000:YS,1:100000)
  1. L +^YTT(YSFILEN,0):DILOCKTM+10
  1. I '$T QUIT ""
  1. F MHQ2X=YS:1 I '$D(^YTT(YSFILEN,MHQ2X)) D Q:MHQ2XFND
  1. . S MHQ2XFND=1
  1. . S ^YTT(YSFILEN,MHQ2X,0)=MHQ2X
  1. . S $P(^YTT(YSFILEN,0),U,3)=MHQ2X
  1. . S $P(^YTT(YSFILEN,0),U,4)=$P($G(^YTT(YSFILEN,0)),U,4)+1
  1. L -^YTT(YSFILEN,0)
  1. Q MHQ2X
  1. ;
  1. GETSCR(YSDATA,YS) ;get CR scratch -for a user,patient and instrument
  1. ; input: DFN as Patient Ien
  1. ; input: CODE as Instrument name- 601.71
  1. ; input: HANDLE= identifer for cprs GIU
  1. ; output: SCRATCH list in format
  1. ; QuestionID^AnswerValue^AnswerLegacyValue^IsMultipleChoice^Response Date
  1. N G,G2,YSQN,YSTN,YSDFN,N,N1,N2,X1,X2,X,YSIEN,YSRDATE,%,YSHANDLE,YSCODE
  1. K ^TMP($J,"YSSCR") S YSDATA=$NA(^TMP($J,"YSSCR"))
  1. S ^TMP($J,"YSSCR",1)="[ERROR]"
  1. S YSDFN=$G(YS("DFN"))
  1. S YSCODE=$G(YS("CODE"),0)
  1. S YSHANDLE=$G(YS("HANDLE"),0)
  1. S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
  1. I YSDFN'?1N.N S ^TMP($J,"YSSCR",2)="bad ad num getscr" Q ;-->out
  1. I YSTN'?1N.N S ^TMP($J,"YSSCR",2)="bad test num getscr" Q ;-->out
  1. D NOW^%DTC S X=%
  1. D H^%DTC S X1=%H*86400+%T
  1. S YSIEN=0,N1=1
  1. F S YSIEN=$O(^YTT(601.94,"AE",YSHANDLE,YSIEN)) Q:YSIEN'>0 D
  1. . S G=$G(^YTT(601.94,YSIEN,0))
  1. . Q:($P(G,U,2)'=YSDFN) ;--> out wrong patient
  1. . Q:($P(G,U,9)'=DUZ) ;--> out wrong user
  1. . Q:($P(G,U,4)'=YSTN) ;--> out wrong test
  1. . S X=$P(G,U,3)
  1. . D H^%DTC S X2=%H*86400+%T
  1. . Q:((X1-X2)>86400) ;-->out too old
  1. . S G2=$G(^YTT(601.94,YSIEN,2))
  1. . S YSQN=$P(G,U,5)
  1. . S N1=N1+1
  1. . S ^TMP($J,"YSSCR",N1)=$P(G,U,5,8)_U_$P(G,U,3)
  1. . S N2=0 F S N2=$O(^YTT(601.94,YSIEN,1,N2)) Q:N2'>0 D
  1. .. S N1=N1+1
  1. .. S ^TMP($J,"YSSCR",N1)=YSQN_U_$G(^YTT(601.94,YSIEN,1,N2,0))
  1. S ^TMP($J,"YSSCR",1)="[DATA]"
  1. S:'$D(^TMP($J,"YSSCR",2)) ^TMP($J,"YSSCR",2)="ok-none found!"
  1. Q
  1. KILLSCR(YSDATA,YS) ;delete scratch data
  1. ;input: DFN = Patient ien
  1. ;input: CODE= Test name from 601.71
  1. ;input: HANDLE= identifer for cprs GIU
  1. ;output: [DATA] vs [ERROR]
  1. N YSDFN,YSTN,YSIEN,DA,YSRDATE,N,DIK
  1. S YSDATA(1)="[ERROR]"
  1. S YSDFN=$G(YS("DFN"))
  1. I YSDFN'?1N.N S YSDATA(2)="bad DFN killscr" Q ;-->out
  1. S YSHANDLE=$G(YS("HANDLE"),0)
  1. S YSCODE=$G(YS("CODE"),0)
  1. I YSCODE=0 D MULTT Q ;-->out ASF 8/27/08
  1. S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
  1. I YSTN'?1N.N S YSDATA(2)="bad test num killscr" Q ;-->out
  1. S YSIEN=0
  1. F S YSIEN=$O(^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN)) Q:YSIEN'>0 D
  1. . D KILLS(YSDFN,YSTN,YSIEN)
  1. S YSDATA(1)="[DATA]"
  1. Q
  1. MULTT ;multiple test remover
  1. S YSTN=0 F S YSTN=$O(^YTT(601.94,"AF",DUZ,YSDFN,YSTN)) Q:YSTN'>0 D
  1. . S YSIEN=0
  1. . F S YSIEN=$O(^YTT(601.94,"AF",DUZ,YSDFN,YSTN,YSHANDLE,YSIEN)) Q:YSIEN'>0 D
  1. . . D KILLS(YSDFN,YSTN,YSIEN)
  1. S YSDATA(1)="[DATA]"
  1. Q
  1. ;
  1. KILLS(YSDFN,YSTN,YSIEN) ;
  1. N YSNODE0,DA,DIK
  1. S YSNODE0=$G(^YTT(601.94,YSIEN,0))
  1. Q:($P(YSNODE0,U,2)'=YSDFN) ;--> out wrong patient
  1. Q:($P(YSNODE0,U,9)'=DUZ) ;--> out wrong user
  1. Q:($P(YSNODE0,U,4)'=YSTN) ;--> out wrong test
  1. L +^YTT(601.94,0):DILOCKTM+10
  1. I '$T QUIT
  1. S DA=YSIEN
  1. S DIK="^YTT(601.94,"
  1. D ^DIK
  1. L -^YTT(601.94,0)
  1. Q
  1. ;
  1. OLDKILL ;clean up scratch file
  1. N X1,X2,X,DA,DIK,YSWHEN,YSOUT
  1. S X1=DT,X2=-2 D C^%DTC
  1. S YSOUT=X
  1. S DIK="^YTT(601.94,"
  1. S YSWHEN=0 F S YSWHEN=$O(^YTT(601.94,"AD",YSWHEN)) Q:YSWHEN'>0!(YSWHEN>YSOUT) D
  1. . S DA=0 F S DA=$O(^YTT(601.94,"AD",YSWHEN,DA)) Q:DA'>0 D ^DIK
  1. Q
  1. ;
  1. GETTSC(YSCRA,YS) ;patch 123, calculate Scale scores from Scratch Global
  1. ; input: DFN as Patient Ien
  1. ; input: CODE as Instrument name- 601.71
  1. ; input: HANDLE= identifer for cprs GIU
  1. ; output: Temp SCALE SCORES in format: '*' + Scale IEN + '~' + Scale Score
  1. N YSKEYI,YSQN,YSTN,YSDFN,YSIEN,YSTARG,YSVAL,YSRTN71,YSHANDLE,YSCODE,YSRAW,YSCH,YSCH1
  1. N ARR,FAIL,G,SCA,SCARR,STR,N,N1,N2,X1,X2,X,%
  1. S YSDFN=$G(YS("DFN"))
  1. S YSCODE=$G(YS("CODE"),0)
  1. S YSHANDLE=$G(YS("HANDLE"),0)
  1. S YSTN=$O(^YTT(601.71,"B",YSCODE,0))
  1. S FAIL=0
  1. K ^TMP($J,"YSSCR")
  1. S YSCRA=$NA(^TMP($J,"YSSCR"))
  1. S ^TMP($J,"YSSCR",1)="[ERROR]"
  1. I YSDFN'?1N.N S ^TMP($J,"YSSCR",2)="bad ad num getscr" Q ;-->out
  1. I YSTN'?1N.N S ^TMP($J,"YSSCR",2)="bad test num getscr" Q ;-->out
  1. ;map scratch answers to questions, put in ARR
  1. D MAPSCR I FAIL Q
  1. ;get scales for instrument
  1. D SCALEG^YTQAPI3(.YSDATA,.YS)
  1. ;determine if M scoring routine exists, if yes, score, quit
  1. S YSRTN71=$$GET1^DIQ(601.71,YSTN_",",92)
  1. I (YSRTN71'=""),(YSRTN71'="YTSCORE") D CMPLX Q
  1. ;otherwise scoring keys used to score
  1. D SETARR(.SCARR,"SIEN")
  1. S SCA=""
  1. F S SCA=$O(SCARR(SCA)) Q:'SCA S YSRAW="0" D S SCARR(SCA)=YSRAW
  1. .S YSKEYI=0 F S YSKEYI=$O(^YTT(601.91,"AC",SCA,YSKEYI)) Q:YSKEYI'>0 D
  1. ..S G=^YTT(601.91,YSKEYI,0)
  1. ..S YSQN=$P(G,U,3),YSTARG=$P(G,U,4),YSVAL=$P(G,U,5)
  1. ..S YSCH=$G(ARR(YSQN),0)
  1. ..Q:YSCH'>0
  1. ..S YSCH1=$G(^YTT(601.75,YSCH,1))
  1. ..I YSCH1=YSTARG S YSRAW=YSRAW+YSVAL
  1. I ^TMP($J,"YSSCR",1)'="[DATA]" S ^TMP($J,"YSSCR",2)="Scratch data not found for Scoring Keys!" Q
  1. S STR="",SCA="",N=1
  1. F S SCA=$O(SCARR(SCA)) Q:'SCA D
  1. .S N=N+1,^TMP($J,"YSSCR",N)="*"_SCA_"~"_SCARR(SCA)
  1. Q
  1. ;
  1. MAPSCR ;
  1. N NX
  1. D NOW^%DTC S X=%
  1. D H^%DTC S X1=%H*86400+%T
  1. S YSIEN=0
  1. F S YSIEN=$O(^YTT(601.94,"AE",YSHANDLE,YSIEN)) Q:YSIEN'>0 D
  1. .S G=$G(^YTT(601.94,YSIEN,0))
  1. .Q:($P(G,U,2)'=YSDFN) ;--> out wrong patient
  1. .Q:($P(G,U,9)'=DUZ) ;--> out wrong user
  1. .Q:($P(G,U,4)'=YSTN) ;--> out wrong test
  1. .S X=$P(G,U,3)
  1. .D H^%DTC S X2=%H*86400+%T
  1. .Q:((X1-X2)>86400) ;-->out too old
  1. .S YSQN=$P(G,U,5)
  1. .Q:'$D(YSQN)
  1. .;
  1. .S ARR(YSQN)=$P(G,U,6)
  1. .;need to handle questions that are not multiple choice but have integer answeres
  1. .I ARR(YSQN)="" D
  1. ..Q:'$$ANSWER(YSQN) ; make sure Answer is integer value
  1. ..S NX=0 F S NX=$O(^YTT(601.94,YSIEN,1,NX)) Q:NX'>0 D
  1. ...S ANS=^YTT(601.94,YSIEN,1,NX,0)
  1. ...I ANS?1N.N S ARR(YSQN)=";"_NX_U_ANS
  1. .;
  1. I '$D(ARR) S ^TMP($J,"YSSCR",2)="Scratch data not found!",FAIL=1 Q
  1. S ^TMP($J,"YSSCR",1)="[DATA]"
  1. Q
  1. ;
  1. CMPLX ;
  1. N FAIL,I,QUE,N,SCA,SNM,YS76,YSDATA,YSRTN
  1. I '$D(ARR) S ^TMP($J,"YSSCR",2)="In Get Temp Score, ARR not built",FAIL=1 Q
  1. ;loop through ^TMP($J,"YSG" Set up a mapping array
  1. I '$D(^TMP($J,"YSG")) S ^TMP($J,"YSSCR",2)="In Get Temp Score, No YSG global",FAIL=1 Q
  1. ;
  1. D SETARR(.SCARR,"NM")
  1. S QUE="",N=3
  1. F S QUE=$O(ARR(QUE)) Q:'QUE D
  1. .S YS76=$O(^YTT(601.76,"AE",QUE,"")) I '$G(YS76) Q
  1. .I '$D(YSDATA(2)) S $P(YSDATA(2),U,3)=YSCODE
  1. .S STR=$G(^YTT(601.76,YS76,0))
  1. .I $G(ARR(QUE)) S ARR(QUE)=U_ARR(QUE)
  1. .S YSDATA(N)=QUE_U_$P(STR,U,3)_ARR(QUE),N=N+1
  1. S YSRTN="DLLSTR^"_YSRTN71_"(.YSDATA,.YS,1)"
  1. D @YSRTN
  1. I '$D(^TMP($J,"YSCOR")) S ^TMP($J,"YSSCR",2)="Complex scoring failed!" Q
  1. S N=1
  1. F I=2:1 Q:'$D(^TMP($J,"YSCOR",I)) D
  1. .S SCA=^TMP($J,"YSCOR",I)
  1. .S SNM=$P(SCA,"=",1)
  1. .I $D(SCARR(SNM)) S N=N+1,^TMP($J,"YSSCR",N)="*"_SCARR(SNM)_"~"_$P($P(SCA,"=",2),U)
  1. K ^TMP($J,"YSG"),^TMP($J,"YSCOR")
  1. Q
  1. SETARR(SCARR,NODE) ;
  1. ;set SCARR array to be used in calculating score
  1. N I,STR1,SCA,SNM,IX,VAL
  1. F I=2:1 Q:'$D(^TMP($J,"YSG",I)) I ^TMP($J,"YSG",I)?1"Scale".E D
  1. .S STR1=$G(^TMP($J,"YSG",I)),SCA=$P($P(STR1,"=",2),U),SNM=$P($P(STR1,"=",2),U,4)
  1. .S IX=$S(NODE="NM":SNM,NODE="SIEN":SCA,1:"ERR")
  1. .S VAL=$S(NODE="NM":SCA,1:"")
  1. .S SCARR(IX)=VAL
  1. Q
  1. ANSWER(YSQN) ;
  1. N NODE
  1. S NODE=$$GET1^DIQ(601.72,YSQN_",",3,"I")
  1. I (NODE=2)!(NODE=7) Q 1
  1. Q 0