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 Sep 23, 2025@19:54:29 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
