- YTQAPI8 ;ASF/ALB - MHA SCORING ; 11/15/07 11:14am
- ;;5.01;MENTAL HEALTH;**85,121,123,142**;Dec 30, 1994;Build 14
- ;
- Q
- OLDSCORE ;score answers fro 601.2
- D SCOREIT^YTQAPI14(.YSDATA,.YS)
- I YSDATA(1)="[ERROR]" S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="bad OLDSCORE" Q ;-->out
- I YSDATA(1)="[ERROR SCORE1+5]" S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="no administration found" Q ;-->out
- D MVSCORE
- Q
- LGSCORE ;score legacy test in 84
- N YSEE,YSLGRSP
- S YSEE=0
- S X1=^YTT(601.84,YSAD,0)
- S DFN=$P(X1,U,2),YSDATE=$P(X1,U,4)
- S YSOLDI=$O(^YTT(601,"B",YSCODE,0))
- S YSQN=0,N=1,X=""
- F S YSQN=$O(^YTT(601.85,"AC",YSAD,YSQN)) Q:YSQN'>0 D
- .S YSANSI=$O(^YTT(601.85,"AC",YSAD,YSQN,0))
- .S YSCI=$P($G(^YTT(601.85,YSANSI,0)),U,4)
- .I YSCI'?1N.N S YSEE=1 Q ;-->out ASF 3/7/07
- .I '$D(^YTT(601.75,YSCI)) S YSEE=1 Q ;-->out ASF 3/7/07
- .S YSLG=$P(^YTT(601.75,YSCI,0),U,2) S:YSLG="" YSLG=" "
- .S X=X_YSLG
- .I $L(X)=200 S YSLGRSP(N)=X,X="",N=N+1
- I YSEE K ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="bad LG CHOICE" Q ;-->out
- L +^YTD(601.2,DFN,1,YSOLDI,1,YSDATE):DILOCKTM E S ^TMP($J,"YSCOR",1)="[ERROR]",^(2)="lock failed" Q ;-->out
- I $D(YSLGRSP) M ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)=YSLGRSP
- S:$L(X) ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,N)=X
- S ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,0)=YSDATE_U_U_$P(X1,U,6)_U_$P(X1,U,7)
- S YS("DFN")=DFN,YS("CODE")=YSCODE,YS("ADATE")=YSDATE
- D SCOREIT^YTQAPI14(.YSDATA,.YS) ;ASF 7/12/07
- K ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- L -^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- I YSDATA(1)="[ERROR]" S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="bad LG SCORE" Q ;-->out
- I YSDATA(1)="[ERROR SCORE1+5]" S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="no administration found" Q ;-->out
- D MVSCORE
- Q
- MVSCORE ;move results
- K ^TMP($J,"YSCOR")
- S ^TMP($J,"YSCOR",1)="[DATA]"
- S N1=1,N2=5
- F S N2=$O(YSDATA(N2)) Q:N2'>0 S N1=N1+1,^TMP($J,"YSCOR",N1)=$P(YSDATA(N2),U,2)_"="_$P(YSDATA(N2),U,3)_U_$P(YSDATA(N2),U,4)
- K YSDATA S YSDATA=$NA(^TMP($J,"YSCOR"))
- Q
- GETSCORE(YSDATA,YS) ;get scales and scale grps for a test
- ; input: AD as administration ID
- ; output: Scale name=Raw Score
- N YSCODE,YSCODEN,N,N2,X,X1,I,YSAD,YSAI,YSTARG,YSAN,YSCALEI,YSKEYI,YSQN,YSRAW,YSVAL,YSDA,YSLG,N1,YSADATE,YSANSI,YSCI
- N YSDATE,YSDFN,YSOLDI,YSLIMIT,YSXT,DFN,YSSPEC,YSSCRD
- N REVSCR71,REVSCR84
- K ^TMP($J,"YSCOR") S YSDATA=$NA(^TMP($J,"YSCOR"))
- S YSAD=$G(YS("AD"))
- S YSADATE=$G(YS("ADATE")),YSCODE=$G(YS("CODE")),DFN=$G(YS("DFN"))
- I (YSADATE?7N.E)&(YSAD'?1N.N) D OLDSCORE Q ;-->out Score answers from 601.2
- I YSAD'?1N.N S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="bad ad num in GETSCORE" Q ;-->out
- I '$D(^YTT(601.85,"AC",YSAD)) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="no such reference" Q ;-->out ;
- S YSCODE=$$GET1^DIQ(601.84,YSAD_",",2)
- S YSCODEN=$$GET1^DIQ(601.84,YSAD_",",2,"I")
- I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="no ins" Q ;-->out
- S YSDA=$O(^YTT(601.71,"B",YSCODE,0))
- S YSLG=$$GET1^DIQ(601.71,YSDA_",",23)
- I YSLG="Yes" D LGSCORE Q ;-->out Score legacy answers in 601.85
- ;
- ; patch 123, check for scoring discrepancy, if so, rescore and load scores
- I 'YSDA S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Getscore err, No Instrument IEN" Q ;-->out
- D LDSCORES^YTSCORE(.YSDATA,.YS)
- Q
- ;
- OLDGSCRE(YSDATA,YS) ;get scales and scale grps for a test
- ; input: AD as administration ID
- ; output: Scale name=Raw Score
- N YSCODE,YSCODEN,N,N2,X,X1,I,YSAD,YSAI,YSTARG,YSAN,YSCALEI,YSKEYI,YSQN,YSRAW,YSVAL,YSDA,YSLG,N1,YSADATE,YSANSI,YSCI,YSDATE,YSDFN,YSOLDI,YSLIMIT,YSXT,DFN
- K ^TMP($J,"YSCOR") S YSDATA=$NA(^TMP($J,"YSCOR"))
- S YSAD=$G(YS("AD"))
- S YSADATE=$G(YS("ADATE")),YSCODE=$G(YS("CODE")),DFN=$G(YS("DFN"))
- I (YSADATE?7N.E)&(YSAD'?1N.N) D OLDSCORE Q ;-->out Score answers from 601.2
- I YSAD'?1N.N S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="bad ad num" Q ;-->out
- I '$D(^YTT(601.85,"AC",YSAD)) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="no such reference" Q ;-->out
- S YSCODE=$$GET1^DIQ(601.84,YSAD_",",2)
- S YSCODEN=$$GET1^DIQ(601.84,YSAD_",",2,"I")
- I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="no ins" Q ;-->out
- S YSDA=$O(^YTT(601.71,"B",YSCODE,0))
- S YSLG=$$GET1^DIQ(601.71,YSDA_",",23)
- I YSLG="Yes" D LGSCORE Q ;-->out Score legacy answers in 601.85
- I '$D(^YTT(601.86,"AC",YSCODEN)) S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="no scale grps found" Q ;-->out
- S YS("CODE")=YSCODE
- D SCALEG^YTQAPI3(.YSDATA,.YS)
- S YSDATA=$NA(^TMP($J,"YSCOR"))
- S ^TMP($J,"YSCOR",1)="[DATA]",N=1
- 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
- ;
- DELSG(YSDATA,YS) ; DELETE SCALES AND SCALEGROUP-careful!!!
- ;input: ID as ien of 601.86 scalegroup
- ;output DATAvsERROR
- N YSIEN,YSID,I,N,DA,DIK
- S YSID=$G(YS("ID"),-1)
- I '$D(^YTT(601.86,YSID,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad id" Q ;-->out
- S N=0,YSDATA(1)="[DATA]"
- S YSEQ=0 F S YSEQ=$O(^YTT(601.87,"AC",YSID,YSEQ)) Q:YSEQ'>0 D
- .S DA=$O(^YTT(601.87,"AC",YSID,YSEQ,0))
- .S DIK="^YTT(601.87,"
- .S N=N+1
- .D ^DIK
- S DA=YSID,DIK="^YTT(601.86," D ^DIK
- S YSDATA(2)=N_" scales deleted"
- Q
- SCALEGRP(YSDATA,YS) ;return scalegroup info
- ; input: CODE as instrument name
- ; output: SCALEGROUP ID^INSTRUMENT ID^SCALEGROUP NAME^GROUP SEQUENCE^ORDINATE TITLE^ORDINATEMIN^ORDINATEINCREMENT^ORDINATEMAX^GRID1^GRID2^GRID3
- N YSCODE,YSCODEN,YSEQ,G,YSIEN,N
- K ^TMP($J,"YSSG")
- S YSDATA=$NA(^TMP($J,"YSSG"))
- S YSCODE=$G(YS("CODE"),0)
- I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP($J,"YSSG",1)="[ERROR]",^TMP($J,"YSSG",2)="no ins" Q ;-->out
- S YSCODEN=$O(^YTT(601.71,"B",YSCODE,0))
- I '$D(^YTT(601.86,"AC",YSCODEN)) S ^TMP($J,"YSSG",1)="[ERROR]",^TMP($J,"YSSG",2)="no scale grps here" Q ;-->out
- S N=1,^TMP($J,"YSSG",1)="[DATA]"
- S YSEQ=0 F S YSEQ=$O(^YTT(601.86,"AC",YSCODEN,YSEQ)) Q:YSEQ="" D
- . S YSIEN=$O(^YTT(601.86,"AC",YSCODEN,YSEQ,0))
- . S G=^YTT(601.86,YSIEN,0)
- . S N=N+1,^TMP($J,"YSSG",N)=G
- Q
- LEGACY(YSDATA,YS) ; RPC: YTQ LEGACY REPORT
- N YSLGRSP
- K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
- S YSAD=$G(YS("AD"))
- I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad ad num" Q ;-->out
- I '$D(^YTT(601.85,"AC",YSAD)) S YSDATA(1)="[ERROR]",YSDATA(2)="no such reference" Q ;-->out
- S YSDATA(1)="[DATA]"
- S X1=^YTT(601.84,YSAD,0)
- S DFN=$P(X1,U,2),YSDATE=$P(X1,U,4)
- S YSCODE=$$GET1^DIQ(601.84,YSAD_",",2)
- S YSOLDI=$O(^YTT(601,"B",YSCODE,0))
- S YSQN=0,N=1,X=""
- F S YSQN=$O(^YTT(601.85,"AC",YSAD,YSQN)) Q:YSQN'>0 D
- . S YSANSI=$O(^YTT(601.85,"AC",YSAD,YSQN,0))
- . S YSCI=$P(^YTT(601.85,YSANSI,0),U,4)
- . Q:YSCI'?1N.N
- . S YSLG=$P(^YTT(601.75,YSCI,0),U,2) S:YSLG="" YSLG=" "
- . S X=X_YSLG
- . I $L(X)=200 S YSLGRSP(N)=X,X="",N=N+1
- L +^YTD(601.2,DFN,1,YSOLDI,1,YSDATE):DILOCKTM E S YSDATA(1)="[ERROR]",YSDATA(2)="lock failed" Q ;-->out
- I $D(YSLGRSP) M ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)=YSLGRSP
- S:$L(X) ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,N)=X
- S ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,0)=YSDATE_U_U_$P(X1,U,6)_U_$P(X1,U,7)
- S YSDFN=DFN,YSXT=YSDATE_","_YSOLDI D INTRMNT^YTRPWRP(.YSDATA,YSDFN,YSXT)
- K ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- L -^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI8 7954 printed Jan 18, 2025@03:19:31 Page 2
- YTQAPI8 ;ASF/ALB - MHA SCORING ; 11/15/07 11:14am
- +1 ;;5.01;MENTAL HEALTH;**85,121,123,142**;Dec 30, 1994;Build 14
- +2 ;
- +3 QUIT
- OLDSCORE ;score answers fro 601.2
- +1 DO SCOREIT^YTQAPI14(.YSDATA,.YS)
- +2 ;-->out
- IF YSDATA(1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="bad OLDSCORE"
- QUIT
- +3 ;-->out
- IF YSDATA(1)="[ERROR SCORE1+5]"
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="no administration found"
- QUIT
- +4 DO MVSCORE
- +5 QUIT
- LGSCORE ;score legacy test in 84
- +1 NEW YSEE,YSLGRSP
- +2 SET YSEE=0
- +3 SET X1=^YTT(601.84,YSAD,0)
- +4 SET DFN=$PIECE(X1,U,2)
- SET YSDATE=$PIECE(X1,U,4)
- +5 SET YSOLDI=$ORDER(^YTT(601,"B",YSCODE,0))
- +6 SET YSQN=0
- SET N=1
- SET X=""
- +7 FOR
- SET YSQN=$ORDER(^YTT(601.85,"AC",YSAD,YSQN))
- if YSQN'>0
- QUIT
- Begin DoDot:1
- +8 SET YSANSI=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,0))
- +9 SET YSCI=$PIECE($GET(^YTT(601.85,YSANSI,0)),U,4)
- +10 ;-->out ASF 3/7/07
- IF YSCI'?1N.N
- SET YSEE=1
- QUIT
- +11 ;-->out ASF 3/7/07
- IF '$DATA(^YTT(601.75,YSCI))
- SET YSEE=1
- QUIT
- +12 SET YSLG=$PIECE(^YTT(601.75,YSCI,0),U,2)
- if YSLG=""
- SET YSLG=" "
- +13 SET X=X_YSLG
- +14 IF $LENGTH(X)=200
- SET YSLGRSP(N)=X
- SET X=""
- SET N=N+1
- End DoDot:1
- +15 ;-->out
- IF YSEE
- KILL ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="bad LG CHOICE"
- QUIT
- +16 ;-->out
- LOCK +^YTD(601.2,DFN,1,YSOLDI,1,YSDATE):DILOCKTM
- IF '$TEST
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^(2)="lock failed"
- QUIT
- +17 IF $DATA(YSLGRSP)
- MERGE ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)=YSLGRSP
- +18 if $LENGTH(X)
- SET ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,N)=X
- +19 SET ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,0)=YSDATE_U_U_$PIECE(X1,U,6)_U_$PIECE(X1,U,7)
- +20 SET YS("DFN")=DFN
- SET YS("CODE")=YSCODE
- SET YS("ADATE")=YSDATE
- +21 ;ASF 7/12/07
- DO SCOREIT^YTQAPI14(.YSDATA,.YS)
- +22 KILL ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- +23 LOCK -^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- +24 ;-->out
- IF YSDATA(1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="bad LG SCORE"
- QUIT
- +25 ;-->out
- IF YSDATA(1)="[ERROR SCORE1+5]"
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="no administration found"
- QUIT
- +26 DO MVSCORE
- +27 QUIT
- MVSCORE ;move results
- +1 KILL ^TMP($JOB,"YSCOR")
- +2 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
- +3 SET N1=1
- SET N2=5
- +4 FOR
- SET N2=$ORDER(YSDATA(N2))
- if N2'>0
- QUIT
- SET N1=N1+1
- SET ^TMP($JOB,"YSCOR",N1)=$PIECE(YSDATA(N2),U,2)_"="_$PIECE(YSDATA(N2),U,3)_U_$PIECE(YSDATA(N2),U,4)
- +5 KILL YSDATA
- SET YSDATA=$NAME(^TMP($JOB,"YSCOR"))
- +6 QUIT
- GETSCORE(YSDATA,YS) ;get scales and scale grps for a test
- +1 ; input: AD as administration ID
- +2 ; output: Scale name=Raw Score
- +3 NEW YSCODE,YSCODEN,N,N2,X,X1,I,YSAD,YSAI,YSTARG,YSAN,YSCALEI,YSKEYI,YSQN,YSRAW,YSVAL,YSDA,YSLG,N1,YSADATE,YSANSI,YSCI
- +4 NEW YSDATE,YSDFN,YSOLDI,YSLIMIT,YSXT,DFN,YSSPEC,YSSCRD
- +5 NEW REVSCR71,REVSCR84
- +6 KILL ^TMP($JOB,"YSCOR")
- SET YSDATA=$NAME(^TMP($JOB,"YSCOR"))
- +7 SET YSAD=$GET(YS("AD"))
- +8 SET YSADATE=$GET(YS("ADATE"))
- SET YSCODE=$GET(YS("CODE"))
- SET DFN=$GET(YS("DFN"))
- +9 ;-->out Score answers from 601.2
- IF (YSADATE?7N.E)&(YSAD'?1N.N)
- DO OLDSCORE
- QUIT
- +10 ;-->out
- IF YSAD'?1N.N
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="bad ad num in GETSCORE"
- QUIT
- +11 ;-->out ;
- IF '$DATA(^YTT(601.85,"AC",YSAD))
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="no such reference"
- QUIT
- +12 SET YSCODE=$$GET1^DIQ(601.84,YSAD_",",2)
- +13 SET YSCODEN=$$GET1^DIQ(601.84,YSAD_",",2,"I")
- +14 ;-->out
- IF '$DATA(^YTT(601.71,"B",YSCODE))
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="no ins"
- QUIT
- +15 SET YSDA=$ORDER(^YTT(601.71,"B",YSCODE,0))
- +16 SET YSLG=$$GET1^DIQ(601.71,YSDA_",",23)
- +17 ;-->out Score legacy answers in 601.85
- IF YSLG="Yes"
- DO LGSCORE
- QUIT
- +18 ;
- +19 ; patch 123, check for scoring discrepancy, if so, rescore and load scores
- +20 ;-->out
- IF 'YSDA
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="Getscore err, No Instrument IEN"
- QUIT
- +21 DO LDSCORES^YTSCORE(.YSDATA,.YS)
- +22 QUIT
- +23 ;
- OLDGSCRE(YSDATA,YS) ;get scales and scale grps for a test
- +1 ; input: AD as administration ID
- +2 ; output: Scale name=Raw Score
- +3 NEW YSCODE,YSCODEN,N,N2,X,X1,I,YSAD,YSAI,YSTARG,YSAN,YSCALEI,YSKEYI,YSQN,YSRAW,YSVAL,YSDA,YSLG,N1,YSADATE,YSANSI,YSCI,YSDATE,YSDFN,YSOLDI,YSLIMIT,YSXT,DFN
- +4 KILL ^TMP($JOB,"YSCOR")
- SET YSDATA=$NAME(^TMP($JOB,"YSCOR"))
- +5 SET YSAD=$GET(YS("AD"))
- +6 SET YSADATE=$GET(YS("ADATE"))
- SET YSCODE=$GET(YS("CODE"))
- SET DFN=$GET(YS("DFN"))
- +7 ;-->out Score answers from 601.2
- IF (YSADATE?7N.E)&(YSAD'?1N.N)
- DO OLDSCORE
- QUIT
- +8 ;-->out
- IF YSAD'?1N.N
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="bad ad num"
- QUIT
- +9 ;-->out
- IF '$DATA(^YTT(601.85,"AC",YSAD))
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="no such reference"
- QUIT
- +10 SET YSCODE=$$GET1^DIQ(601.84,YSAD_",",2)
- +11 SET YSCODEN=$$GET1^DIQ(601.84,YSAD_",",2,"I")
- +12 ;-->out
- IF '$DATA(^YTT(601.71,"B",YSCODE))
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="no ins"
- QUIT
- +13 SET YSDA=$ORDER(^YTT(601.71,"B",YSCODE,0))
- +14 SET YSLG=$$GET1^DIQ(601.71,YSDA_",",23)
- +15 ;-->out Score legacy answers in 601.85
- IF YSLG="Yes"
- DO LGSCORE
- QUIT
- +16 ;-->out
- IF '$DATA(^YTT(601.86,"AC",YSCODEN))
- SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- SET ^TMP($JOB,"YSCOR",2)="no scale grps found"
- QUIT
- +17 SET YS("CODE")=YSCODE
- +18 DO SCALEG^YTQAPI3(.YSDATA,.YS)
- +19 SET YSDATA=$NAME(^TMP($JOB,"YSCOR"))
- +20 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
- SET N=1
- +21 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
- +22 SET YSCALEI=$PIECE(^TMP($JOB,"YSG",I),U)
- SET YSCALEI=$PIECE(YSCALEI,"=",2)
- +23 SET YSKEYI=0
- FOR
- SET YSKEYI=$ORDER(^YTT(601.91,"AC",YSCALEI,YSKEYI))
- if YSKEYI'>0
- QUIT
- Begin DoDot:2
- +24 SET G=^YTT(601.91,YSKEYI,0)
- +25 SET YSQN=$PIECE(G,U,3)
- SET YSTARG=$PIECE(G,U,4)
- SET YSVAL=$PIECE(G,U,5)
- +26 SET YSAI=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,0))
- +27 if YSAI'>0
- QUIT
- +28 ;ASF 11/15/07
- if '$DATA(^YTT(601.85,YSAI,0))
- QUIT
- +29 SET YSAN=""
- +30 IF $DATA(^YTT(601.85,YSAI,1,1,0))
- SET YSAN=^YTT(601.85,YSAI,1,1,0)
- +31 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))
- +32 IF YSAN=YSTARG
- SET YSRAW=YSRAW+YSVAL
- End DoDot:2
- End DoDot:1
- SET ^TMP($JOB,"YSCOR",N)=^TMP($JOB,"YSCOR",N)_YSRAW
- +33 QUIT
- +34 ;
- DELSG(YSDATA,YS) ; DELETE SCALES AND SCALEGROUP-careful!!!
- +1 ;input: ID as ien of 601.86 scalegroup
- +2 ;output DATAvsERROR
- +3 NEW YSIEN,YSID,I,N,DA,DIK
- +4 SET YSID=$GET(YS("ID"),-1)
- +5 ;-->out
- IF '$DATA(^YTT(601.86,YSID,0))
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="bad id"
- QUIT
- +6 SET N=0
- SET YSDATA(1)="[DATA]"
- +7 SET YSEQ=0
- FOR
- SET YSEQ=$ORDER(^YTT(601.87,"AC",YSID,YSEQ))
- if YSEQ'>0
- QUIT
- Begin DoDot:1
- +8 SET DA=$ORDER(^YTT(601.87,"AC",YSID,YSEQ,0))
- +9 SET DIK="^YTT(601.87,"
- +10 SET N=N+1
- +11 DO ^DIK
- End DoDot:1
- +12 SET DA=YSID
- SET DIK="^YTT(601.86,"
- DO ^DIK
- +13 SET YSDATA(2)=N_" scales deleted"
- +14 QUIT
- SCALEGRP(YSDATA,YS) ;return scalegroup info
- +1 ; input: CODE as instrument name
- +2 ; output: SCALEGROUP ID^INSTRUMENT ID^SCALEGROUP NAME^GROUP SEQUENCE^ORDINATE TITLE^ORDINATEMIN^ORDINATEINCREMENT^ORDINATEMAX^GRID1^GRID2^GRID3
- +3 NEW YSCODE,YSCODEN,YSEQ,G,YSIEN,N
- +4 KILL ^TMP($JOB,"YSSG")
- +5 SET YSDATA=$NAME(^TMP($JOB,"YSSG"))
- +6 SET YSCODE=$GET(YS("CODE"),0)
- +7 ;-->out
- IF '$DATA(^YTT(601.71,"B",YSCODE))
- SET ^TMP($JOB,"YSSG",1)="[ERROR]"
- SET ^TMP($JOB,"YSSG",2)="no ins"
- QUIT
- +8 SET YSCODEN=$ORDER(^YTT(601.71,"B",YSCODE,0))
- +9 ;-->out
- IF '$DATA(^YTT(601.86,"AC",YSCODEN))
- SET ^TMP($JOB,"YSSG",1)="[ERROR]"
- SET ^TMP($JOB,"YSSG",2)="no scale grps here"
- QUIT
- +10 SET N=1
- SET ^TMP($JOB,"YSSG",1)="[DATA]"
- +11 SET YSEQ=0
- FOR
- SET YSEQ=$ORDER(^YTT(601.86,"AC",YSCODEN,YSEQ))
- if YSEQ=""
- QUIT
- Begin DoDot:1
- +12 SET YSIEN=$ORDER(^YTT(601.86,"AC",YSCODEN,YSEQ,0))
- +13 SET G=^YTT(601.86,YSIEN,0)
- +14 SET N=N+1
- SET ^TMP($JOB,"YSSG",N)=G
- End DoDot:1
- +15 QUIT
- LEGACY(YSDATA,YS) ; RPC: YTQ LEGACY REPORT
- +1 NEW YSLGRSP
- +2 KILL ^TMP("YSDATA",$JOB)
- SET YSDATA=$NAME(^TMP("YSDATA",$JOB))
- +3 SET YSAD=$GET(YS("AD"))
- +4 ;-->out
- IF YSAD'?1N.N
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="bad ad num"
- QUIT
- +5 ;-->out
- IF '$DATA(^YTT(601.85,"AC",YSAD))
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="no such reference"
- QUIT
- +6 SET YSDATA(1)="[DATA]"
- +7 SET X1=^YTT(601.84,YSAD,0)
- +8 SET DFN=$PIECE(X1,U,2)
- SET YSDATE=$PIECE(X1,U,4)
- +9 SET YSCODE=$$GET1^DIQ(601.84,YSAD_",",2)
- +10 SET YSOLDI=$ORDER(^YTT(601,"B",YSCODE,0))
- +11 SET YSQN=0
- SET N=1
- SET X=""
- +12 FOR
- SET YSQN=$ORDER(^YTT(601.85,"AC",YSAD,YSQN))
- if YSQN'>0
- QUIT
- Begin DoDot:1
- +13 SET YSANSI=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,0))
- +14 SET YSCI=$PIECE(^YTT(601.85,YSANSI,0),U,4)
- +15 if YSCI'?1N.N
- QUIT
- +16 SET YSLG=$PIECE(^YTT(601.75,YSCI,0),U,2)
- if YSLG=""
- SET YSLG=" "
- +17 SET X=X_YSLG
- +18 IF $LENGTH(X)=200
- SET YSLGRSP(N)=X
- SET X=""
- SET N=N+1
- End DoDot:1
- +19 ;-->out
- LOCK +^YTD(601.2,DFN,1,YSOLDI,1,YSDATE):DILOCKTM
- IF '$TEST
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="lock failed"
- QUIT
- +20 IF $DATA(YSLGRSP)
- MERGE ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)=YSLGRSP
- +21 if $LENGTH(X)
- SET ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,N)=X
- +22 SET ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE,0)=YSDATE_U_U_$PIECE(X1,U,6)_U_$PIECE(X1,U,7)
- +23 SET YSDFN=DFN
- SET YSXT=YSDATE_","_YSOLDI
- DO INTRMNT^YTRPWRP(.YSDATA,YSDFN,YSXT)
- +24 KILL ^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- +25 LOCK -^YTD(601.2,DFN,1,YSOLDI,1,YSDATE)
- +26 QUIT