YSMTI5 ;ALBANY/ASF PSYCH TEST DOWNLOAD SF36 ;7/16/99 10:09
;;5.01;MENTAL HEALTH;**53**;Dec 30, 1994
N YSX
SCOR ;GET RESPONSES
S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
;ARRAY SET
F I=1:1:36 S YSX(I)=$E(X,I)
RV ;REVERSE SCORE 10 ITEMS
F I=21,22,1,34,36,23,27,20,26,30 I YSX(I)'="X" S YSMX=$P(^YTT(601,YSTEST,"Q",I,0),U,2),YSMX=$E(YSMX,$L(YSMX)-1)+1,YSX(I)=YSMX-YSX(I)
;RECODE 3 ITEMS
S YSX(1)=YSX(1)+$S($E(X,1)=2:.4,$E(X,1)=3:.4,1:0)
S:YSX(21)'="X" YSX(21)=YSX(21)+$S($E(X,21)=2:.4,$E(X,21)=3:.2,$E(X,21)=4:.1,$E(X,21)=5:.2,1:0)
I ($E(X,22)=1)&($E(X,21)=1) S YSX(22)=6
I $E(X,21)="X"&(YSX(22)'="X") S YSX(22)=YSX(22)+$S($E(X,22)=1:1,$E(X,22)=2:.75,$E(X,22)=3:.5,$E(X,22)=4:.25,1:0)
RAWER ;RAW CALCULATIONS
K S S R="" F J=1:1:9 S YSN=0,YSXN=0 D RAW1 D:YSXN>0 MISS
G STND Q
RAW1 S YSKK=^YTT(601,YSTEST,"S",J,"K",1,0)
F I=1:2 S A=$P(YSKK,U,I) Q:A="" D RAW2
Q
RAW2 S $P(R,U,J)=$P(R,U,J)+YSX(A)
I YSX(A)="X" S YSXN=YSXN+1
S YSN=YSN+1
Q
MISS ;MISSING ITEM RECODE BY MEANS
S B=$P("10^4^2^5^4^2^3^5^1",U,J)
I YSXN/B>.5 S $P(R,U,J)="*" Q
S Y=$P(R,U,J)/(YSN-YSXN)
S $P(R,U,J)=$P(R,U,J)+(Y*YSXN)
Q
STND ;
S S="",J=1,P="M"
ST ;
S A=$P(R,U,J) G:A=""!(J=9) END
S X=^YTT(601,YSTEST,"S",J,P),S=S_$J((A-$P(X,U)/$P(X,U,2)*100),0,2)_"^",J=J+1 G ST
END Q ;
CLEAN ;
K A,B,C,G,H,I,I1,J,K,L,L1,L2,M,N,N1,N2,P,P3,P4,P5,T,T1,V,W,X,X1,X2,X3,X4,Y,Y1,Y2,YS10,YS25,YS50,YS75,YS90,YSAD,YSAGE,YSANLL,YSAS,YSAST,YSAU,YSB1,YSB2,YSBOX,YSBR
K YSBV,YSCALEN,YSCALET,YSCF,YSCF1,YSCNT,YSDAT,YSDATES,YSDOB,YSDS,YSED,YSED1,YSEP,YSET,YSF,YSFC,YSFR,YSHP1,YSHP2,YSHS,YSII,YSIN2,YSINC,YSIO,YSIT,YSIT1,YSIT2,YSIX,YSJJ,YSKC,YSKK,YSKY,YSLB,YSLE,YSLL
K YSLM,YSLN,YSLNE,YSLV,YSMA,YSMF,YSMMPI,YSMMPR,YSMX,YSN,YSNAM,YSND,YSNM,YSNS,YSNS26,YSNS39,YSNS9,YSNSCALE,YSNSS,YSOCAT,YSOCNM,YSOCP,YSOCSX,YSOFF,YSPD,YSPS,YSPT,YSQ,YSQR,YSRAW,YSRH,YSRM,YSRP,YSRR,YSRS,YSRT,YSS,YSS1,YSS2
K YSSC,YSSCALE,YSSCALEB,YSSEX,YSSH,YSSI,YSSK,YSSNM,YSSNM1,YSSNUMB,YSSP,YSSP4,YSSR,YSSS,YSSSN,YSSX,YSTAR,YSTEST,YSTESTA,YSTL,YSTN,YSTR,YSTTL,YSTV,YSTVL,YSTY,YSULOF,YSULON,YSVS,YSWF,YSX,YSXN,YSXR,YSXX,YSZ,Z,Z1,Z2
K IFN,N4,R3,SFN1,SFN2,YSAA,YSADATE,YSBED,YSBEG,YSCK,YSCODE,YSED,YSEND,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSONE,YSSTAFF,YSTYPE
Q
EOR ;YSMTI5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI5 2263 printed Oct 16, 2024@18:15:32 Page 2
YSMTI5 ;ALBANY/ASF PSYCH TEST DOWNLOAD SF36 ;7/16/99 10:09
+1 ;;5.01;MENTAL HEALTH;**53**;Dec 30, 1994
+2 NEW YSX
SCOR ;GET RESPONSES
+1 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
+2 ;ARRAY SET
+3 FOR I=1:1:36
SET YSX(I)=$EXTRACT(X,I)
RV ;REVERSE SCORE 10 ITEMS
+1 FOR I=21,22,1,34,36,23,27,20,26,30
IF YSX(I)'="X"
SET YSMX=$PIECE(^YTT(601,YSTEST,"Q",I,0),U,2)
SET YSMX=$EXTRACT(YSMX,$LENGTH(YSMX)-1)+1
SET YSX(I)=YSMX-YSX(I)
+2 ;RECODE 3 ITEMS
+3 SET YSX(1)=YSX(1)+$SELECT($EXTRACT(X,1)=2:.4,$EXTRACT(X,1)=3:.4,1:0)
+4 if YSX(21)'="X"
SET YSX(21)=YSX(21)+$SELECT($EXTRACT(X,21)=2:.4,$EXTRACT(X,21)=3:.2,$EXTRACT(X,21)=4:.1,$EXTRACT(X,21)=5:.2,1:0)
+5 IF ($EXTRACT(X,22)=1)&($EXTRACT(X,21)=1)
SET YSX(22)=6
+6 IF $EXTRACT(X,21)="X"&(YSX(22)'="X")
SET YSX(22)=YSX(22)+$SELECT($EXTRACT(X,22)=1:1,$EXTRACT(X,22)=2:.75,$EXTRACT(X,22)=3:.5,$EXTRACT(X,22)=4:.25,1:0)
RAWER ;RAW CALCULATIONS
+1 KILL S
SET R=""
FOR J=1:1:9
SET YSN=0
SET YSXN=0
DO RAW1
if YSXN>0
DO MISS
+2 GOTO STND
QUIT
RAW1 SET YSKK=^YTT(601,YSTEST,"S",J,"K",1,0)
+1 FOR I=1:2
SET A=$PIECE(YSKK,U,I)
if A=""
QUIT
DO RAW2
+2 QUIT
RAW2 SET $PIECE(R,U,J)=$PIECE(R,U,J)+YSX(A)
+1 IF YSX(A)="X"
SET YSXN=YSXN+1
+2 SET YSN=YSN+1
+3 QUIT
MISS ;MISSING ITEM RECODE BY MEANS
+1 SET B=$PIECE("10^4^2^5^4^2^3^5^1",U,J)
+2 IF YSXN/B>.5
SET $PIECE(R,U,J)="*"
QUIT
+3 SET Y=$PIECE(R,U,J)/(YSN-YSXN)
+4 SET $PIECE(R,U,J)=$PIECE(R,U,J)+(Y*YSXN)
+5 QUIT
STND ;
+1 SET S=""
SET J=1
SET P="M"
ST ;
+1 SET A=$PIECE(R,U,J)
if A=""!(J=9)
GOTO END
+2 SET X=^YTT(601,YSTEST,"S",J,P)
SET S=S_$JUSTIFY((A-$PIECE(X,U)/$PIECE(X,U,2)*100),0,2)_"^"
SET J=J+1
GOTO ST
END ;
QUIT
CLEAN ;
+1 KILL A,B,C,G,H,I,I1,J,K,L,L1,L2,M,N,N1,N2,P,P3,P4,P5,T,T1,V,W,X,X1,X2,X3,X4,Y,Y1,Y2,YS10,YS25,YS50,YS75,YS90,YSAD,YSAGE,YSANLL,YSAS,YSAST,YSAU,YSB1,YSB2,YSBOX,YSBR
+2 KILL YSBV,YSCALEN,YSCALET,YSCF,YSCF1,YSCNT,YSDAT,YSDATES,YSDOB,YSDS,YSED,YSED1,YSEP,YSET,YSF,YSFC,YSFR,YSHP1,YSHP2,YSHS,YSII,YSIN2,YSINC,YSIO,YSIT,YSIT1,YSIT2,YSIX,YSJJ,YSKC,YSKK,YSKY,YSLB,YSLE,YSLL
+3 KILL YSLM,YSLN,YSLNE,YSLV,YSMA,YSMF,YSMMPI,YSMMPR,YSMX,YSN,YSNAM,YSND,YSNM,YSNS,YSNS26,YSNS39,YSNS9,YSNSCALE,YSNSS,YSOCAT,YSOCNM,YSOCP,YSOCSX,YSOFF,YSPD,YSPS,YSPT,YSQ,YSQR,YSRAW,YSRH,YSRM,YSRP,YSRR,YSRS,YSRT,YSS,YSS1,YSS2
+4 KILL YSSC,YSSCALE,YSSCALEB,YSSEX,YSSH,YSSI,YSSK,YSSNM,YSSNM1,YSSNUMB,YSSP,YSSP4,YSSR,YSSS,YSSSN,YSSX,YSTAR,YSTEST,YSTESTA,YSTL,YSTN,YSTR,YSTTL,YSTV,YSTVL,YSTY,YSULOF,YSULON,YSVS,YSWF,YSX,YSXN,YSXR,YSXX,YSZ,Z,Z1,Z2
+5 KILL IFN,N4,R3,SFN1,SFN2,YSAA,YSADATE,YSBED,YSBEG,YSCK,YSCODE,YSED,YSEND,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSONE,YSSTAFF,YSTYPE
+6 QUIT
EOR ;YSMTI5
