YTMCMI2B ;ALB/ASF,HIOFO/FT - MCMI2 REPORT CONT ;9/15/11 11:43 am
;;5.01;MENTAL HEALTH;**60**;Dec 30, 1994;Build 47
;
;No external references
;
DC ;DISCLOSURE CORRECTION
S X=+R I X<145!(X>590)!((X>249)&(X<401)) G HDAA
I X>144,X<250 S YSCF=250-X\10 S:250-X/10#1 YSCF=YSCF+1 F I=4:1:25 S YSCF1=$S(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1),$P(S,U,I)=$P(S,U,I)+(YSCF*YSCF1\1) K YSCF1
I X>400,X<591 S YSCF=X-400\16 S:X-400/16#1 YSCF=YSCF+1 F I=4:1:25 S YSCF1=$S(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1),$P(S,U,I)=$P(S,U,I)-(YSCF1*YSCF\1)
HDAA ;DEPRESSION/ANXIETY ADJUSTMENT
D RD^YTMCMI2A S YSIO=$E(X,176),YSEP=$E(X,177) S:YSIO'="I" YSIO="O" S:YSEP'?1N YSEP=2
S YSAS=$P(S,U,17),YSDS=$P(S,U,20),Y=(YSAS-85)+(YSDS-85)
I YSEP=2,YSIO="I",YSAS>84,YSDS>84 S Y1=Y*.5\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=Y*.75\1 S:Y1>15 Y1=15 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP=1,YSAS>84,YSDS>84 S Y1=Y S:Y>25 Y1=25 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S:Y1>20 Y1=20 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP>2,YSAS>84,YSDS>84 S Y1=Y*.25\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=Y*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="O",YSAS>84,YSDS>84 S Y1=((YSAS-85)+(YSDS-85))\4 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=Y*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP=2,YSDS>84,YSAS<85 S Y1=YSDS-85*.5\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=YSDS-85*.75\1 S:Y1>15 Y1=15 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP=1,YSDS>84,YSAS<85 S Y1=YSDS-85 S:Y1>25 Y1=25 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S:Y1>20 Y1=20 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP>2,YSDS>84,YSAS<85 S Y1=YSDS-85*.25\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=YSDS-85*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="O",YSDS>84,YSAS<85 S Y1=YSDS-85*.25\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=YSDS-85*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
XYZ ;Y-Z CORRECTION
S Y1=$P(S,U,2)-$P(S,U,3)/10,Y1=$J(Y1,0,0) S:Y1>10 Y1=10 S:Y1<-10 Y1=-10 F I=14,15,17,18,20 S $P(S,U,I)=$P(S,U,I)+Y1
DCA ;DENIAL-COMPLAINT ADJUSTMENT
K YSS,YSS1,YSS2,^TMP("YT1",$J) F I=4:1:13 S ^TMP("YT1",$J,999-$P(S,U,I),I)=""
S Y1=$O(^TMP("YT1",$J,0)),Y2=0 F I=0:1 S Y2=$O(^TMP("YT1",$J,Y1,Y2)) Q:'Y2 S YSS1(Y2)=""
I I<2 S Y1=$O(^TMP("YT1",$J,Y1)),Y2=0 F I=0:1 S Y2=$O(^TMP("YT1",$J,Y1,Y2)) Q:'Y2 S YSS2(Y2)=""
TIES ;
S YSS1="",YSS2="" I YSSEX="M" F I=13,4,7,9,10,6,8,11,12,5 S:$D(YSS1(I)) YSS1=YSS1_I_U S:$D(YSS2(I)) YSS2=YSS2_I_U
I YSSEX="F" F I=9,4,10,8,5,12,13,11,7,6 S:$D(YSS1(I)) YSS1=YSS1_I_U S:$D(YSS2(I)) YSS2=YSS2_I_U
S YSS=YSS1_YSS2
I +YSS=7!(+YSS=8)!(+YSS=11)!($P(YSS,U,2)=11) F I=14,15,16,17,20,18 S Y1=$S(I<16:4,I=16:2,I=18:13,1:15) S $P(S,U,I)=$P(S,U,I)+Y1
I +YSS=13!(+YSS=5)!($P(YSS,U,2)=5) F I=15,16,14,17,18,20 S Y1=$S(I=14:2,I<17:6,I=17:7,1:5) S $P(S,U,I)=$P(S,U,I)-Y1
SCP ; LAST CORRECTION
I YSIO="I",YSEP=1 F I="23,8","24,10","25,4" S $P(S,U,+I)=$P(S,U,+I)+$P(I,",",2)
I YSIO="I",(YSEP=2!(YSEP=0)) F I="23,5","24,7","25,2" S $P(S,U,+I)=$P(S,U,+I)+$P(I,",",2)
K Y,Y1,^TMP("YT1",$J) G ^YTMCMI2C
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTMCMI2B 3253 printed Dec 13, 2024@02:17:32 Page 2
YTMCMI2B ;ALB/ASF,HIOFO/FT - MCMI2 REPORT CONT ;9/15/11 11:43 am
+1 ;;5.01;MENTAL HEALTH;**60**;Dec 30, 1994;Build 47
+2 ;
+3 ;No external references
+4 ;
DC ;DISCLOSURE CORRECTION
+1 SET X=+R
IF X<145!(X>590)!((X>249)&(X<401))
GOTO HDAA
+2 IF X>144
IF X<250
SET YSCF=250-X\10
if 250-X/10#1
SET YSCF=YSCF+1
FOR I=4:1:25
SET YSCF1=$SELECT(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1)
SET $PIECE(S,U,I)=$PIECE(S,U,I)+(YSCF*YSCF1\1)
KILL YSCF1
+3 IF X>400
IF X<591
SET YSCF=X-400\16
if X-400/16#1
SET YSCF=YSCF+1
FOR I=4:1:25
SET YSCF1=$SELECT(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1)
SET $PIECE(S,U,I)=$PIECE(S,U,I)-(YSCF1*YSCF\1)
HDAA ;DEPRESSION/ANXIETY ADJUSTMENT
+1 DO RD^YTMCMI2A
SET YSIO=$EXTRACT(X,176)
SET YSEP=$EXTRACT(X,177)
if YSIO'="I"
SET YSIO="O"
if YSEP'?1N
SET YSEP=2
+2 SET YSAS=$PIECE(S,U,17)
SET YSDS=$PIECE(S,U,20)
SET Y=(YSAS-85)+(YSDS-85)
+3 IF YSEP=2
IF YSIO="I"
IF YSAS>84
IF YSDS>84
SET Y1=Y*.5\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=Y*.75\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+4 IF YSIO="I"
IF YSEP=1
IF YSAS>84
IF YSDS>84
SET Y1=Y
if Y>25
SET Y1=25
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
if Y1>20
SET Y1=20
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+5 IF YSIO="I"
IF YSEP>2
IF YSAS>84
IF YSDS>84
SET Y1=Y*.25\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=Y*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+6 IF YSIO="O"
IF YSAS>84
IF YSDS>84
SET Y1=((YSAS-85)+(YSDS-85))\4
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=Y*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+7 IF YSIO="I"
IF YSEP=2
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85*.5\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=YSDS-85*.75\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+8 IF YSIO="I"
IF YSEP=1
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85
if Y1>25
SET Y1=25
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
if Y1>20
SET Y1=20
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+9 IF YSIO="I"
IF YSEP>2
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85*.25\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=YSDS-85*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+10 IF YSIO="O"
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85*.25\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=YSDS-85*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
XYZ ;Y-Z CORRECTION
+1 SET Y1=$PIECE(S,U,2)-$PIECE(S,U,3)/10
SET Y1=$JUSTIFY(Y1,0,0)
if Y1>10
SET Y1=10
if Y1<-10
SET Y1=-10
FOR I=14,15,17,18,20
SET $PIECE(S,U,I)=$PIECE(S,U,I)+Y1
DCA ;DENIAL-COMPLAINT ADJUSTMENT
+1 KILL YSS,YSS1,YSS2,^TMP("YT1",$JOB)
FOR I=4:1:13
SET ^TMP("YT1",$JOB,999-$PIECE(S,U,I),I)=""
+2 SET Y1=$ORDER(^TMP("YT1",$JOB,0))
SET Y2=0
FOR I=0:1
SET Y2=$ORDER(^TMP("YT1",$JOB,Y1,Y2))
if 'Y2
QUIT
SET YSS1(Y2)=""
+3 IF I<2
SET Y1=$ORDER(^TMP("YT1",$JOB,Y1))
SET Y2=0
FOR I=0:1
SET Y2=$ORDER(^TMP("YT1",$JOB,Y1,Y2))
if 'Y2
QUIT
SET YSS2(Y2)=""
TIES ;
+1 SET YSS1=""
SET YSS2=""
IF YSSEX="M"
FOR I=13,4,7,9,10,6,8,11,12,5
if $DATA(YSS1(I))
SET YSS1=YSS1_I_U
if $DATA(YSS2(I))
SET YSS2=YSS2_I_U
+2 IF YSSEX="F"
FOR I=9,4,10,8,5,12,13,11,7,6
if $DATA(YSS1(I))
SET YSS1=YSS1_I_U
if $DATA(YSS2(I))
SET YSS2=YSS2_I_U
+3 SET YSS=YSS1_YSS2
+4 IF +YSS=7!(+YSS=8)!(+YSS=11)!($PIECE(YSS,U,2)=11)
FOR I=14,15,16,17,20,18
SET Y1=$SELECT(I<16:4,I=16:2,I=18:13,1:15)
SET $PIECE(S,U,I)=$PIECE(S,U,I)+Y1
+5 IF +YSS=13!(+YSS=5)!($PIECE(YSS,U,2)=5)
FOR I=15,16,14,17,18,20
SET Y1=$SELECT(I=14:2,I<17:6,I=17:7,1:5)
SET $PIECE(S,U,I)=$PIECE(S,U,I)-Y1
SCP ; LAST CORRECTION
+1 IF YSIO="I"
IF YSEP=1
FOR I="23,8","24,10","25,4"
SET $PIECE(S,U,+I)=$PIECE(S,U,+I)+$PIECE(I,",",2)
+2 IF YSIO="I"
IF (YSEP=2!(YSEP=0))
FOR I="23,5","24,7","25,2"
SET $PIECE(S,U,+I)=$PIECE(S,U,+I)+$PIECE(I,",",2)
+3 KILL Y,Y1,^TMP("YT1",$JOB)
GOTO ^YTMCMI2C
