YTMCMI3 ;ALB/ASF,HIOFO/FT - MCMI3 ;5/1/13 10:28am
;;5.01;MENTAL HEALTH;**76,119**;Dec 30, 1994;Build 40
;Reference to VADPT APIs supported by DBIA #10061
;Reference to XLFDT APIs supported by DBIA #10103
;
;called from ^YTT(601,246,"R") and ^YTT(601.6,246,1)
MAIN ;displays the MCMI3 report text
N A,B,G,I,L1,L2,N,X,YSANS,YSDAS,YSDAS1,YSIN,YSSID,YSTOUT,YSUOUT,YSVFLAG
D PTVAR^YSLRP
D RD
D RAW
D VALIDITY
D BR
D DCA,LIMIT
D ADA,LIMIT
D INPTAD,LIMIT
D DENIAL,LIMIT
D:YSTY["*" REPT^YTMCMI3R
Q
RD ;retrieve answer codes
N YS176177
S X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
S YSINPT=$E(X,176),YSDUR=$E(X,177)
I (YSINPT="")&(YSDUR="") D
.S YS176177=$$INP(YSDFN,YSED)
.S:$P(YS176177,U,1)]"" YSINPT=$P(YS176177,U,1)
.S:$P(YS176177,U,2)]"" YSDUR=$P(YS176177,U,2)
.;S YSINPT="I",YSDUR=0 ;for testing purposes only
Q
VALIDITY ;check if ok to score
S YSVFLAG=0
I $L(X,"X")>11 S YSVFLAG="too many missing" Q
I $P(R,U)>1 S YSVFLAG="V scale" Q
I ($P(R,U,2)>178)!($P(R,U,2)<34) S YSVFLAG="X scale" Q
I (YSAGE<18) S YSVFLAG="too young" Q
I $P(R,U,29)>9 S YSVFLAG="W scale"
Q
RAW ; raw scores
S R="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
F N=1,3:1:28 D
. S G=^YTT(601,YSTEST,"S",N,"K",1,0),I=1
. F S YSIN=$P(G,U,I),YSANS=$E($P(G,U,I+1),1),YSWT=$P($P(G,U,I+1),";",2),I=I+2 Q:YSIN="" S:$E(X,YSIN)=YSANS $P(R,U,N)=$P(R,U,N)+YSWT
F I=5:1:15 S:I'=10 $P(R,U,2)=$P(R,U,2)+$P(R,U,I) S:I=10 $P(R,U,2)=$P(R,U,2)+($P(R,U,I)*.666666)
S G=$P(R,U,2) S $P(R,U,2)=$S(G#1>.49999999:G\1+1,1:G\1)
D WSCALE
Q
BR ;base rate scores
S S="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
F I=3:1:28 S $P(S,U,I)=$P(^YTT(601,YSTEST,"S",I,YSSEX),U,$P(R,U,I)+1)
I $P(R,U,2)<39 S $P(S,U,2)=0 Q
I $P(R,U,2)>174 S $P(S,U,2)=100 Q
I $P(R,U,2)<105 S $P(S,U,2)=$P(^YTT(601,YSTEST,"S",2,"M"),U,$P(R,U,2)-37)
I $P(R,U,2)>104 S $P(S,U,2)=$P(^YTT(601,YSTEST,"S",2,"MS"),U,$P(R,U,2)-104)
Q
DCA ;disclosure adjustment
;1-8B
S G=^YTT(601,YSTEST,"S",2,"MK")
S X=$P(R,U,2)
I X<37 S YSDVA=20
I (X>36)&(X<61) S YSDVA=$P(G,U,X-36)
I (X>60)&(X<124) S YSDVA=0
I (X>123)&(X<172) S YSDVA=$P(G,U,X-98)*-1
S:X>171 YSDVA=-20
F I=5:1:15 S $P(S,U,I)=$P(S,U,I)+YSDVA S:$P(S,U,I)<0 $P(S,U,I)=0 S:$P(S,U,I)>115 $P(S,U,I)=115
;S-PP
S G=^YTT(601,YSTEST,"S",2,"FK")
I X<39 S YSDVA1=10
I (X>38)&(X<61) S YSDVA1=$P(G,U,X-38)
I (X>60)&(X<124) S YSDVA1=0
I (X>123)&(X<172) S YSDVA1=$P(G,U,X-100)*-1
S:X>171 YSDVA1=-11
F I=16:1:28 S $P(S,U,I)=$P(S,U,I)+YSDVA1
Q
ADA ;anxiety/depression adjust
S YSAX=$P(S,U,19),YSDD=$P(S,U,22)
I (YSAX<75)&(YSDD<75) Q ;-->out
I (YSAX>74)&(YSDD<75) S YSADA=YSAX-75
I (YSDD>74)&(YSAX<75) S YSADA=YSDD-75
I (YSAX>74)&(YSDD>74) S YSADA=(YSAX-75)+(YSDD-75)
I (YSINPT'="I")!(YSDUR>2) D T2
I (YSINPT="I")&(YSDUR=1) D T3
I (YSINPT="I")&(YSDUR=2) D T4
I (YSINPT="I")&(YSDUR=0) D T2
Q
T2 ;non inpt/long axis1
S X=YSADA
S X1=$S(X<10:1,X<15:2,X<20:3,X<25:4,X<30:5,X<35:6,X<40:7,X<45:8,X<50:9,X<55:10,X<60:11,X<65:12,X<70:13,X<75:14,X<81:15,1:0)
F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
S X1=$S(X<16:1,X<24:2,X<32:3,X<40:4,X<48:5,X<56:6,X<64:7,X<72:8,X<80:9,X=80:10,1:0)
F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
Q
T3 ;inpt dur<1 week
S X=YSADA
S X1=$S(X<5:1,X<8:2,X<10:3,X<13:4,X<15:5,X<18:6,X<20:7,X<23:8,X<25:9,X<28:10,X<30:11,X<33:12,X<35:13,X<38:14,X<81:15,1:0)
F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
S X1=$S(X<8:1,X<12:2,X<16:3,X<20:4,X<24:5,X<28:6,X<32:7,X<36:8,X<40:9,X<44:10,X<48:11,X<53:12,X<56:13,X<60:14,X<81:15,1:0)
F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
Q
T4 ;inpt dur1-4
S X=YSADA
S X1=$S(X<7:1,X<10:2,X<14:3,X<17:4,X<20:5,X<24:6,X<27:7,X<30:8,X<34:9,X<37:10,X<40:11,X<44:12,X<47:13,X<50:14,X<81:15,1:0)
F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
S X1=$S(X<11:1,X<16:2,X<22:3,X<27:4,X<32:5,X<38:6,X<43:7,X<48:8,X<54:9,X<59:10,X<64:11,X<70:12,X<75:13,X<80:14,X=80:15,1:0)
F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
Q
LIMIT ;set 0-115 range
F I=1:1:28 S:$P(S,U,I)<0 $P(S,U,I)=0 S:$P(S,U,I)>115 $P(S,U,I)=115
Q
INPTAD ;inpatient adjustment
I (YSINPT="I")&(YSDUR=1) S $P(S,U,26)=$P(S,U,26)+6,$P(S,U,27)=$P(S,U,27)+10,$P(S,U,28)=$P(S,U,28)+4
I (YSINPT="I")&(YSDUR=2) S $P(S,U,26)=$P(S,U,26)+4,$P(S,U,27)=$P(S,U,27)+8,$P(S,U,28)=$P(S,U,28)+2
Q
DENIAL ;denial/complaint
S YSBR="",YSHI="" F I=7,11,15,12,6,14,13,9,10,8,5 S:$P(S,U,I)>YSBR YSBR=$P(S,U,I),YSHI=I
Q:(YSHI'=9)&(YSHI'=10)&(YSHI'=13)
S YSBR="",YSHI="" F I=13,9,10 S:$P(S,U,I)>YSBR YSBR=$P(S,U,I),YSHI=I
S $P(S,U,YSHI)=$P(S,U,YSHI)+8
Q
INP(YSDFN,YSDOT) ;Determine if inpatient and duration
; Input: YSDFN = dfn
; YSDOT = date of test
; Output: piece1^piece2
; where piece 1 = I for Inpatient or O for Outpatient
; piece 2 = duration of stay before test given
; 0 = more than 4 weeks
; 1 = less than 1 week
; 2 = 1- 4 weeks
N DFN,VAINDT,YSADMDT,YSDAYS,YSFLAG,X,Y
S YSDFN=$G(YSDFN),YSDOT=$G(YSDOT),YSFLAG="O^"
I YSDFN="" Q YSFLAG
I YSDOT="" Q YSFLAG
S DFN=YSDFN,VAINDT=YSDOT
D IN5^VADPT
S YSADMDT=$P(VAIP(3),U,1) ;admission date/time
D KVAR^VADPT
I YSADMDT="" Q YSFLAG
S YSDAYS=+$$FMDIFF($P(YSDOT,".",1),$P(YSADMDT,".",1),1)
I YSDAYS="" Q YSFLAG
I YSDAYS<7 Q "I^1"
I YSDAYS>27 Q "I^0"
I (YSDAYS>6)&(YSDAYS<28) Q "I^2"
Q YSFLAG
;
FMDIFF(YSX1,YSX2,YSX3) ;Calculate number of days between admission and
;date test was given
; Input: YSX1 = date/time patient was admitted
; YSX2 = date/time patient was given test
; YSX3 = flag for count of days
; Output: number of days between YSX1 and YSX2
S YSX1=$G(YSX1),YSX2=$G(YSX2),YSX3=$G(YSX3,1)
I YSX1="" Q ""
I YSX2="" Q ""
Q $$FMDIFF^XLFDT($P(YSX1,".",1),$P(YSX2,".",1),YSX3)
;
WSCALE ;calculate Inconsistent responses
N YSWA1,YSWA2,YSWI,YSWNODE,YSWP,YSWPAIR,YSWQ1,YSWQ2,YSWQA1,YSWQA2
F YSWI=1:1:5 D
.S YSWNODE=$G(^YTT(601,YSTEST,"S",29,"K",YSWI,0))
.F YSWP=1:1:$L(YSWNODE,U) D
..S YSWPAIR=$P(YSWNODE,U,YSWP)
..S YSWQA1=$P(YSWPAIR,"-",1),YSWQA2=$P(YSWPAIR,"-",2)
..S YSWQ1=$P(YSWQA1,";",1),YSWA1=$P(YSWQA1,";",2)
..S YSWQ2=$P(YSWQA2,";",1),YSWA2=$P(YSWQA2,";",2)
..I ($E(X,YSWQ1)=YSWA1)&($E(X,YSWQ2)=YSWA2) S $P(R,U,29)=$P(R,U,29)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTMCMI3 6305 printed Sep 23, 2025@19:53:40 Page 2
YTMCMI3 ;ALB/ASF,HIOFO/FT - MCMI3 ;5/1/13 10:28am
+1 ;;5.01;MENTAL HEALTH;**76,119**;Dec 30, 1994;Build 40
+2 ;Reference to VADPT APIs supported by DBIA #10061
+3 ;Reference to XLFDT APIs supported by DBIA #10103
+4 ;
+5 ;called from ^YTT(601,246,"R") and ^YTT(601.6,246,1)
MAIN ;displays the MCMI3 report text
+1 NEW A,B,G,I,L1,L2,N,X,YSANS,YSDAS,YSDAS1,YSIN,YSSID,YSTOUT,YSUOUT,YSVFLAG
+2 DO PTVAR^YSLRP
+3 DO RD
+4 DO RAW
+5 DO VALIDITY
+6 DO BR
+7 DO DCA
DO LIMIT
+8 DO ADA
DO LIMIT
+9 DO INPTAD
DO LIMIT
+10 DO DENIAL
DO LIMIT
+11 if YSTY["*"
DO REPT^YTMCMI3R
+12 QUIT
RD ;retrieve answer codes
+1 NEW YS176177
+2 SET X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
+3 SET YSINPT=$EXTRACT(X,176)
SET YSDUR=$EXTRACT(X,177)
+4 IF (YSINPT="")&(YSDUR="")
Begin DoDot:1
+5 SET YS176177=$$INP(YSDFN,YSED)
+6 if $PIECE(YS176177,U,1)]""
SET YSINPT=$PIECE(YS176177,U,1)
+7 if $PIECE(YS176177,U,2)]""
SET YSDUR=$PIECE(YS176177,U,2)
+8 ;S YSINPT="I",YSDUR=0 ;for testing purposes only
End DoDot:1
+9 QUIT
VALIDITY ;check if ok to score
+1 SET YSVFLAG=0
+2 IF $LENGTH(X,"X")>11
SET YSVFLAG="too many missing"
QUIT
+3 IF $PIECE(R,U)>1
SET YSVFLAG="V scale"
QUIT
+4 IF ($PIECE(R,U,2)>178)!($PIECE(R,U,2)<34)
SET YSVFLAG="X scale"
QUIT
+5 IF (YSAGE<18)
SET YSVFLAG="too young"
QUIT
+6 IF $PIECE(R,U,29)>9
SET YSVFLAG="W scale"
+7 QUIT
RAW ; raw scores
+1 SET R="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+2 FOR N=1,3:1:28
Begin DoDot:1
+3 SET G=^YTT(601,YSTEST,"S",N,"K",1,0)
SET I=1
+4 FOR
SET YSIN=$PIECE(G,U,I)
SET YSANS=$EXTRACT($PIECE(G,U,I+1),1)
SET YSWT=$PIECE($PIECE(G,U,I+1),";",2)
SET I=I+2
if YSIN=""
QUIT
if $EXTRACT(X,YSIN)=YSANS
SET $PIECE(R,U,N)=$PIECE(R,U,N)+YSWT
End DoDot:1
+5 FOR I=5:1:15
if I'=10
SET $PIECE(R,U,2)=$PIECE(R,U,2)+$PIECE(R,U,I)
if I=10
SET $PIECE(R,U,2)=$PIECE(R,U,2)+($PIECE(R,U,I)*.666666)
+6 SET G=$PIECE(R,U,2)
SET $PIECE(R,U,2)=$SELECT(G#1>.49999999:G\1+1,1:G\1)
+7 DO WSCALE
+8 QUIT
BR ;base rate scores
+1 SET S="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+2 FOR I=3:1:28
SET $PIECE(S,U,I)=$PIECE(^YTT(601,YSTEST,"S",I,YSSEX),U,$PIECE(R,U,I)+1)
+3 IF $PIECE(R,U,2)<39
SET $PIECE(S,U,2)=0
QUIT
+4 IF $PIECE(R,U,2)>174
SET $PIECE(S,U,2)=100
QUIT
+5 IF $PIECE(R,U,2)<105
SET $PIECE(S,U,2)=$PIECE(^YTT(601,YSTEST,"S",2,"M"),U,$PIECE(R,U,2)-37)
+6 IF $PIECE(R,U,2)>104
SET $PIECE(S,U,2)=$PIECE(^YTT(601,YSTEST,"S",2,"MS"),U,$PIECE(R,U,2)-104)
+7 QUIT
DCA ;disclosure adjustment
+1 ;1-8B
+2 SET G=^YTT(601,YSTEST,"S",2,"MK")
+3 SET X=$PIECE(R,U,2)
+4 IF X<37
SET YSDVA=20
+5 IF (X>36)&(X<61)
SET YSDVA=$PIECE(G,U,X-36)
+6 IF (X>60)&(X<124)
SET YSDVA=0
+7 IF (X>123)&(X<172)
SET YSDVA=$PIECE(G,U,X-98)*-1
+8 if X>171
SET YSDVA=-20
+9 FOR I=5:1:15
SET $PIECE(S,U,I)=$PIECE(S,U,I)+YSDVA
if $PIECE(S,U,I)<0
SET $PIECE(S,U,I)=0
if $PIECE(S,U,I)>115
SET $PIECE(S,U,I)=115
+10 ;S-PP
+11 SET G=^YTT(601,YSTEST,"S",2,"FK")
+12 IF X<39
SET YSDVA1=10
+13 IF (X>38)&(X<61)
SET YSDVA1=$PIECE(G,U,X-38)
+14 IF (X>60)&(X<124)
SET YSDVA1=0
+15 IF (X>123)&(X<172)
SET YSDVA1=$PIECE(G,U,X-100)*-1
+16 if X>171
SET YSDVA1=-11
+17 FOR I=16:1:28
SET $PIECE(S,U,I)=$PIECE(S,U,I)+YSDVA1
+18 QUIT
ADA ;anxiety/depression adjust
+1 SET YSAX=$PIECE(S,U,19)
SET YSDD=$PIECE(S,U,22)
+2 ;-->out
IF (YSAX<75)&(YSDD<75)
QUIT
+3 IF (YSAX>74)&(YSDD<75)
SET YSADA=YSAX-75
+4 IF (YSDD>74)&(YSAX<75)
SET YSADA=YSDD-75
+5 IF (YSAX>74)&(YSDD>74)
SET YSADA=(YSAX-75)+(YSDD-75)
+6 IF (YSINPT'="I")!(YSDUR>2)
DO T2
+7 IF (YSINPT="I")&(YSDUR=1)
DO T3
+8 IF (YSINPT="I")&(YSDUR=2)
DO T4
+9 IF (YSINPT="I")&(YSDUR=0)
DO T2
+10 QUIT
T2 ;non inpt/long axis1
+1 SET X=YSADA
+2 SET X1=$SELECT(X<10:1,X<15:2,X<20:3,X<25:4,X<30:5,X<35:6,X<40:7,X<45:8,X<50:9,X<55:10,X<60:11,X<65:12,X<70:13,X<75:14,X<81:15,1:0)
+3 FOR I=7,15,17
SET $PIECE(S,U,I)=$PIECE(S,U,I)-X1
+4 SET X1=$SELECT(X<16:1,X<24:2,X<32:3,X<40:4,X<48:5,X<56:6,X<64:7,X<72:8,X<80:9,X=80:10,1:0)
+5 FOR I=6,16
SET $PIECE(S,U,I)=$PIECE(S,U,I)-X1
+6 QUIT
T3 ;inpt dur<1 week
+1 SET X=YSADA
+2 SET X1=$SELECT(X<5:1,X<8:2,X<10:3,X<13:4,X<15:5,X<18:6,X<20:7,X<23:8,X<25:9,X<28:10,X<30:11,X<33:12,X<35:13,X<38:14,X<81:15,1:0)
+3 FOR I=7,15,17
SET $PIECE(S,U,I)=$PIECE(S,U,I)-X1
+4 SET X1=$SELECT(X<8:1,X<12:2,X<16:3,X<20:4,X<24:5,X<28:6,X<32:7,X<36:8,X<40:9,X<44:10,X<48:11,X<53:12,X<56:13,X<60:14,X<81:15,1:0)
+5 FOR I=6,16
SET $PIECE(S,U,I)=$PIECE(S,U,I)-X1
+6 QUIT
T4 ;inpt dur1-4
+1 SET X=YSADA
+2 SET X1=$SELECT(X<7:1,X<10:2,X<14:3,X<17:4,X<20:5,X<24:6,X<27:7,X<30:8,X<34:9,X<37:10,X<40:11,X<44:12,X<47:13,X<50:14,X<81:15,1:0)
+3 FOR I=7,15,17
SET $PIECE(S,U,I)=$PIECE(S,U,I)-X1
+4 SET X1=$SELECT(X<11:1,X<16:2,X<22:3,X<27:4,X<32:5,X<38:6,X<43:7,X<48:8,X<54:9,X<59:10,X<64:11,X<70:12,X<75:13,X<80:14,X=80:15,1:0)
+5 FOR I=6,16
SET $PIECE(S,U,I)=$PIECE(S,U,I)-X1
+6 QUIT
LIMIT ;set 0-115 range
+1 FOR I=1:1:28
if $PIECE(S,U,I)<0
SET $PIECE(S,U,I)=0
if $PIECE(S,U,I)>115
SET $PIECE(S,U,I)=115
+2 QUIT
INPTAD ;inpatient adjustment
+1 IF (YSINPT="I")&(YSDUR=1)
SET $PIECE(S,U,26)=$PIECE(S,U,26)+6
SET $PIECE(S,U,27)=$PIECE(S,U,27)+10
SET $PIECE(S,U,28)=$PIECE(S,U,28)+4
+2 IF (YSINPT="I")&(YSDUR=2)
SET $PIECE(S,U,26)=$PIECE(S,U,26)+4
SET $PIECE(S,U,27)=$PIECE(S,U,27)+8
SET $PIECE(S,U,28)=$PIECE(S,U,28)+2
+3 QUIT
DENIAL ;denial/complaint
+1 SET YSBR=""
SET YSHI=""
FOR I=7,11,15,12,6,14,13,9,10,8,5
if $PIECE(S,U,I)>YSBR
SET YSBR=$PIECE(S,U,I)
SET YSHI=I
+2 if (YSHI'=9)&(YSHI'=10)&(YSHI'=13)
QUIT
+3 SET YSBR=""
SET YSHI=""
FOR I=13,9,10
if $PIECE(S,U,I)>YSBR
SET YSBR=$PIECE(S,U,I)
SET YSHI=I
+4 SET $PIECE(S,U,YSHI)=$PIECE(S,U,YSHI)+8
+5 QUIT
INP(YSDFN,YSDOT) ;Determine if inpatient and duration
+1 ; Input: YSDFN = dfn
+2 ; YSDOT = date of test
+3 ; Output: piece1^piece2
+4 ; where piece 1 = I for Inpatient or O for Outpatient
+5 ; piece 2 = duration of stay before test given
+6 ; 0 = more than 4 weeks
+7 ; 1 = less than 1 week
+8 ; 2 = 1- 4 weeks
+9 NEW DFN,VAINDT,YSADMDT,YSDAYS,YSFLAG,X,Y
+10 SET YSDFN=$GET(YSDFN)
SET YSDOT=$GET(YSDOT)
SET YSFLAG="O^"
+11 IF YSDFN=""
QUIT YSFLAG
+12 IF YSDOT=""
QUIT YSFLAG
+13 SET DFN=YSDFN
SET VAINDT=YSDOT
+14 DO IN5^VADPT
+15 ;admission date/time
SET YSADMDT=$PIECE(VAIP(3),U,1)
+16 DO KVAR^VADPT
+17 IF YSADMDT=""
QUIT YSFLAG
+18 SET YSDAYS=+$$FMDIFF($PIECE(YSDOT,".",1),$PIECE(YSADMDT,".",1),1)
+19 IF YSDAYS=""
QUIT YSFLAG
+20 IF YSDAYS<7
QUIT "I^1"
+21 IF YSDAYS>27
QUIT "I^0"
+22 IF (YSDAYS>6)&(YSDAYS<28)
QUIT "I^2"
+23 QUIT YSFLAG
+24 ;
FMDIFF(YSX1,YSX2,YSX3) ;Calculate number of days between admission and
+1 ;date test was given
+2 ; Input: YSX1 = date/time patient was admitted
+3 ; YSX2 = date/time patient was given test
+4 ; YSX3 = flag for count of days
+5 ; Output: number of days between YSX1 and YSX2
+6 SET YSX1=$GET(YSX1)
SET YSX2=$GET(YSX2)
SET YSX3=$GET(YSX3,1)
+7 IF YSX1=""
QUIT ""
+8 IF YSX2=""
QUIT ""
+9 QUIT $$FMDIFF^XLFDT($PIECE(YSX1,".",1),$PIECE(YSX2,".",1),YSX3)
+10 ;
WSCALE ;calculate Inconsistent responses
+1 NEW YSWA1,YSWA2,YSWI,YSWNODE,YSWP,YSWPAIR,YSWQ1,YSWQ2,YSWQA1,YSWQA2
+2 FOR YSWI=1:1:5
Begin DoDot:1
+3 SET YSWNODE=$GET(^YTT(601,YSTEST,"S",29,"K",YSWI,0))
+4 FOR YSWP=1:1:$LENGTH(YSWNODE,U)
Begin DoDot:2
+5 SET YSWPAIR=$PIECE(YSWNODE,U,YSWP)
+6 SET YSWQA1=$PIECE(YSWPAIR,"-",1)
SET YSWQA2=$PIECE(YSWPAIR,"-",2)
+7 SET YSWQ1=$PIECE(YSWQA1,";",1)
SET YSWA1=$PIECE(YSWQA1,";",2)
+8 SET YSWQ2=$PIECE(YSWQA2,";",1)
SET YSWA2=$PIECE(YSWQA2,";",2)
+9 IF ($EXTRACT(X,YSWQ1)=YSWA1)&($EXTRACT(X,YSWQ2)=YSWA2)
SET $PIECE(R,U,29)=$PIECE(R,U,29)+1
End DoDot:2
End DoDot:1
+10 QUIT
