YTAPI1 ;ALB/ASF PSYCH TEST API ;10/3/02 15:27
;;5.01;MENTAL HEALTH;**53,71,76,77**;Dec 30, 1994
SAVEIT(YSDATA,YS) ;
N N,N2,N4,YSAA,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND
D PARSE^YTAPI(.YS)
IF YSSTAFF'?1N.N!('$D(^VA(200,YSSTAFF))) S YSDATA(1)="[ERROR]",YSDATA(2)="no appro staff" Q
I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="INCORRECT TEST CODE" Q
S (YSTEST,YSET)=$O(^YTT(601,"B",YSCODE,0))
S YSTYPE=$P(^YTT(601,YSTEST,0),U,9),YSINUM=$P(^YTT(601,YSTEST,0),U,11) ;ASF 11/5/01
I YSTYPE'="T"&(YSTYPE'="I") S YSDATA(1)="ERROR",YSDATA(2)="not a test or int" Q
D CK:YSCODE'="MCMI2",CKMCMI:YSCODE="MCMI2" Q:YSCK
;;
S ^YTD(601.2,DFN,0)=DFN
S ^YTD(601.2,DFN,1,0)="^601.21PA^"
S ^YTD(601.2,DFN,1,YSET,0)=YSET
S ^YTD(601.2,DFN,1,YSET,1,0)="^601.22DA^"
S ^YTD(601.2,DFN,1,YSET,1,DT,0)=DT_U_IO_U_YSSTAFF_U_DUZ_U_U_2_U_DUZ(2)_U_YSADATE
S ^YTD(601.2,DFN,1,YSET,1,DT,1)=R1
S:$L(R2) ^YTD(601.2,DFN,1,YSET,1,DT,2)=R2
S:$L(R3) ^YTD(601.2,DFN,1,YSET,1,DT,3)=R3
S DIK="^YTD(601.2,",DA=DFN,DA(1)=YSET,DA(2)=DT D IX^DIK K DIK ;ASF 10/02/02
S YSDATA(1)="[DATA]",YSDATA(2)="saved ok"
S YSENT=YSET,YSDFN=DFN D ENKIL^YTFILE K YSENT,YSDFN ;ASF 6/29/01
Q
CKMCMI ;check mcmi2
S YSCK=0
I $L(R1)'=177 S YSDATA(1)="[ERROR]",YSDATA(2)="MCMI2 BAD #",YSCK=1 Q
I $L(R1,"T")+$L(R1,"F")+$L(R1,"X")'=178 S YSCK=1 Q
Q
CK ;
S YSCK=0
S X=YSINUM\200+1
I $E(@("R"_X),YSINUM#200)=""!($E(@("R"_X),YSINUM#200+1)'="") S YSDATA(1)="[ERROR]",YSDATA(2)="wrong # of respon",YSCK=1 Q
F I=1:1:$L(R1) S X=$E(R1,I) D CK1 Q:YSCK
Q:'$L(R2)
F I=201:1:$L(R2) S X=$E(R2,I) D CK1 Q:YSCK
Q:'$L(R3)
F I=401:1:$L(R3) S X=$E(R1,3) D CK1 Q:YSCK
Q
CK1 ;
I YSTYPE="TEST" D
. I $P($G(^YTT(601,YSTEST,"Q",I,0)),U,2)'="" S C=$P(^YTT(601,YSTEST,"Q",I,0),U,2)
. I C'[X S YSCK=1,YSDATA(1)="[ERROR]",YSDATA(2)="test responses dont check"
I YSTYPE="INTERVIEW" D
. Q:X=" "
. S YSQT=$P($G(^YTT(601,YSTEST,"Q",1)),U,1)
. I +YSQT=3 S YSQT=$E("123456789",1,$P(YSQT,",",2))
. E S YSQT="YN"
. S:YSQT'[X YSCK=1,YSDATA(1)="[ERROR]",YSDATA(2)="interview resp dont check"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTAPI1 2104 printed Apr 09, 2024@21:18:44 Page 2
YTAPI1 ;ALB/ASF PSYCH TEST API ;10/3/02 15:27
+1 ;;5.01;MENTAL HEALTH;**53,71,76,77**;Dec 30, 1994
SAVEIT(YSDATA,YS) ;
+1 NEW N,N2,N4,YSAA,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND
+2 DO PARSE^YTAPI(.YS)
+3 IF YSSTAFF'?1N.N!('$DATA(^VA(200,YSSTAFF)))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no appro staff"
QUIT
+4 IF '$DATA(^YTT(601,"B",YSCODE))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="INCORRECT TEST CODE"
QUIT
+5 SET (YSTEST,YSET)=$ORDER(^YTT(601,"B",YSCODE,0))
+6 ;ASF 11/5/01
SET YSTYPE=$PIECE(^YTT(601,YSTEST,0),U,9)
SET YSINUM=$PIECE(^YTT(601,YSTEST,0),U,11)
+7 IF YSTYPE'="T"&(YSTYPE'="I")
SET YSDATA(1)="ERROR"
SET YSDATA(2)="not a test or int"
QUIT
+8 if YSCODE'="MCMI2"
DO CK
if YSCODE="MCMI2"
DO CKMCMI
if YSCK
QUIT
+9 ;;
+10 SET ^YTD(601.2,DFN,0)=DFN
+11 SET ^YTD(601.2,DFN,1,0)="^601.21PA^"
+12 SET ^YTD(601.2,DFN,1,YSET,0)=YSET
+13 SET ^YTD(601.2,DFN,1,YSET,1,0)="^601.22DA^"
+14 SET ^YTD(601.2,DFN,1,YSET,1,DT,0)=DT_U_IO_U_YSSTAFF_U_DUZ_U_U_2_U_DUZ(2)_U_YSADATE
+15 SET ^YTD(601.2,DFN,1,YSET,1,DT,1)=R1
+16 if $LENGTH(R2)
SET ^YTD(601.2,DFN,1,YSET,1,DT,2)=R2
+17 if $LENGTH(R3)
SET ^YTD(601.2,DFN,1,YSET,1,DT,3)=R3
+18 ;ASF 10/02/02
SET DIK="^YTD(601.2,"
SET DA=DFN
SET DA(1)=YSET
SET DA(2)=DT
DO IX^DIK
KILL DIK
+19 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="saved ok"
+20 ;ASF 6/29/01
SET YSENT=YSET
SET YSDFN=DFN
DO ENKIL^YTFILE
KILL YSENT,YSDFN
+21 QUIT
CKMCMI ;check mcmi2
+1 SET YSCK=0
+2 IF $LENGTH(R1)'=177
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="MCMI2 BAD #"
SET YSCK=1
QUIT
+3 IF $LENGTH(R1,"T")+$LENGTH(R1,"F")+$LENGTH(R1,"X")'=178
SET YSCK=1
QUIT
+4 QUIT
CK ;
+1 SET YSCK=0
+2 SET X=YSINUM\200+1
+3 IF $EXTRACT(@("R"_X),YSINUM#200)=""!($EXTRACT(@("R"_X),YSINUM#200+1)'="")
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="wrong # of respon"
SET YSCK=1
QUIT
+4 FOR I=1:1:$LENGTH(R1)
SET X=$EXTRACT(R1,I)
DO CK1
if YSCK
QUIT
+5 if '$LENGTH(R2)
QUIT
+6 FOR I=201:1:$LENGTH(R2)
SET X=$EXTRACT(R2,I)
DO CK1
if YSCK
QUIT
+7 if '$LENGTH(R3)
QUIT
+8 FOR I=401:1:$LENGTH(R3)
SET X=$EXTRACT(R1,3)
DO CK1
if YSCK
QUIT
+9 QUIT
CK1 ;
+1 IF YSTYPE="TEST"
Begin DoDot:1
+2 IF $PIECE($GET(^YTT(601,YSTEST,"Q",I,0)),U,2)'=""
SET C=$PIECE(^YTT(601,YSTEST,"Q",I,0),U,2)
+3 IF C'[X
SET YSCK=1
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="test responses dont check"
End DoDot:1
+4 IF YSTYPE="INTERVIEW"
Begin DoDot:1
+5 if X=" "
QUIT
+6 SET YSQT=$PIECE($GET(^YTT(601,YSTEST,"Q",1)),U,1)
+7 IF +YSQT=3
SET YSQT=$EXTRACT("123456789",1,$PIECE(YSQT,",",2))
+8 IF '$TEST
SET YSQT="YN"
+9 if YSQT'[X
SET YSCK=1
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="interview resp dont check"
End DoDot:1
+10 QUIT
