YTQPXRM3	;ASF/ALB MHQ REMOTE PROCEDURES CONT ; 5/7/07 10:44am
	;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 49
	;
	Q
QUESTALL(YSDATA,YS)	;all questions for a test
	;input: CODE as test name
	;output: Field^Value
	N YSTESTN,YSTEST,YSF,YSV,N,N2,N3,YSEQX,YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,YSQNUMB
	S YSDATA=$NA(^TMP($J,"YSQU")) K ^TMP($J,"YSQU")
	S YSCODE=$G(YS("CODE"),0)
	S YSTESTN=$O(^YTT(601.71,"B",YSCODE,0))
	I YSTESTN'>0 S ^TMP($J,"YSQU",1)="[ERROR]",^TMP($J,"YSQU",2)="bad code" Q  ;-->out
	S YSQNUMB=0
	S ^TMP($J,"YSQU",1)="[DATA]"
	;
	S YSEQX=0
	F  S YSEQX=$O(^YTT(601.76,"AD",YSTESTN,YSEQX)) Q:YSEQX'>0  D
	. S YSIC=0 F  S YSIC=$O(^YTT(601.76,"AD",YSTESTN,YSEQX,YSIC)) Q:YSIC'>0  S YSQN=$P(^YTT(601.76,YSIC,0),U,4) D QUEST2
	S ^TMP($J,"YSQU",2)=YSCODE_U_"NUMBER OF QUESTIONS="_YSQNUMB
	;now check Ok for clinical reminders
	D CHECKME
	Q
QUEST2	;
	S YSQNUMB=YSQNUMB+1
	S ^TMP($J,"YSQU","YSCROSS",YSQNUMB)=YSQN
	;text
	S N2=0 F  S N2=$O(^YTT(601.72,YSQN,1,N2)) Q:N2'>0  S ^TMP($J,"YSQU",YSQNUMB,"T",N2)=$P($G(^YTT(601.72,YSQN,1,N2,0)),U)
	;intro
	S G=+$G(^YTT(601.72,YSQN,2))
	S N2=0 F  S N2=$O(^YTT(601.73,G,1,N2)) Q:N2'>0  S ^TMP($J,"YSQU",YSQNUMB,"I",N2)=$P($G(^YTT(601.73,+G,1,N2,0)),U)
	;responses
	S YSLN=0
	;S ^TMP($J,"YSQU",YSQNUMB,"R",0)="X"
	S YSCHOT=$P($G(^YTT(601.72,YSQN,2)),U,3)
	Q:YSCHOT'>0
	S N2=0 F  S N2=$O(^YTT(601.751,"AC",YSCHOT,N2)) Q:N2'>0  D
	. S YSCHOICE=$O(^YTT(601.751,"AC",YSCHOT,N2,0))
	. Q:YSCHOICE'>0
	. Q:$P(^YTT(601.75,YSCHOICE,0),U,2)=""
	. ;Q:($P(^YTT(601.75,YSCHOICE,0),U,2)="")
	. S YSLN=YSLN+1
	. S ^TMP($J,"YSQU",YSQNUMB,"R",YSLN)=$P($G(^YTT(601.75,YSCHOICE,1)),U)
	. S ^TMP($J,"YSQU",YSQNUMB,"R",0)=$G(^TMP($J,"YSQU",YSQNUMB,"R",0))_$P($G(^YTT(601.75,YSCHOICE,0)),U,2)
	. S ^TMP($J,"YSQU","YSCA",YSQN,$P(^YTT(601.75,YSCHOICE,0),U,2))=YSCHOICE
	Q
CHECKME	;cr checker
	S YSERR=0
	I YSQNUMB>200 D CLEAN(YSQNUMB_" is too many questions") Q  ;-->out
	S N2=0 F  S N2=$O(^TMP($J,"YSQU",N2)) Q:N2'>0!YSERR  D
	. S YSLEGA=$G(^TMP($J,"YSQU",N2,"R",0))
	. D:YSLEGA="X" CLEAN(N2_" no legacy") Q  ;--out
	. S YSRR=$O(^TMP($J,"YSQU",YSQNUMB,"R",9999),-1)
	. D:YSRR'=($L(YSLEGA)-1) CLEAN(N2_" not all legacy")
	Q
CLEAN(X)	;
	K ^TMP($J,"YSQU")
	S ^TMP($J,"YSQU",1)="[ERROR]"
	S ^TMP($J,"YSQU",2)=X
	Q
OLDNEW(YSCODEN,YSOLDNUM)	;
	;input YSCODEN ien OF 601.71
	;      YSOLDNUM as ien of "S" MULT of 601 (1= DEFAULT)
	;output ien OF 601.87, 0=ERROR
	;
	N N2,YSQQ,YSNAME,YS601,YSOLDNAM,YSNEWN,YSCALE1,YSC1
	IF $G(YSOLDNUM)="" S YSOLDNUM=1
	S YSOUT=0
	I '$D(^YTT(601.71,YSCODEN,0)) Q YSOUT  ;->out
	S YSNAME=$P(^YTT(601.71,YSCODEN,0),U)
	S YS601=$O(^YTT(601,"B",YSNAME,0)) Q:YS601'>0 YSOUT  ;-->out
	I '$D(^YTT(601,YS601,"S",YSOLDNUM,0)) Q YSOUT  ;-->out
	S YSOLDNAM=$P(^YTT(601,YS601,"S",YSOLDNUM,0),U,2)
	D SCALES^YTQPXRM5(.YSQQ,YSCODEN)
	S N2=0 F  S N2=$O(YSQQ("S",N2)) Q:N2'>0  D
	. S YSCALE1=YSQQ("S",N2)
	. S YSC1($$UCASE^YTQPXRM6(YSCALE1),N2)=""
	S YSNEWN=$O(YSC1($$UCASE^YTQPXRM6(YSOLDNAM),0))
	S:YSNEWN>0 YSOUT=YSNEWN
	Q YSOUT
NEWOLD(YSCODEN,YSNEW)	;
	;input YSCODEN ien OF 601.71
	;      YSNEW   ien OF 601.87, 0=ERROR
	;output  YSOLD as ien of "S" MULT of 601 (1= DEFAULT)
	;
	N N2,YSX,YSQQ,YSNAME,YS601,YSOLDNAM,YSNEWN,YSON,YSOLDN,YSCNEW
	IF YSNEW="" S YSNEW=1
	S YSOUT=0
	I '$D(^YTT(601.71,YSCODEN,0)) Q YSOUT  ;->out
	S YSNAME=$P(^YTT(601.71,YSCODEN,0),U)
	S YS601=$O(^YTT(601,"B",YSNAME,0)) Q:YS601'>0 YSOUT  ;-->out
	I '$D(^YTT(601.87,YSNEW)) Q YSOUT  ;-->out
	S YSCNEW=$P(^YTT(601.87,YSNEW,0),U,4)
	S N=0 F  S N=$O(^YTT(601,YS601,"S",N)) Q:N'>0  D
	. S YSON=$P(^YTT(601,YS601,"S",N,0),U,2)
	. S YSX($$UCASE^YTQPXRM6(YSON),N)=""
	S YSOLDN=$O(YSX($$UCASE^YTQPXRM6(YSCNEW),0))
	S:YSOLDN>0 YSOUT=YSOLDN
	Q YSOUT
RL(YSCODEN)	;requires license
	;input YSCODEN ien OF 601.71
	;output  Y/N/0
	;
	N X
	S YSOUT=0
	I '$D(^YTT(601.71,YSCODEN,0)) Q YSOUT  ;->out
	S X=$$GET1^DIQ(601.71,YSCODEN_",",11,"I")
	S YSOUT=$S(X="Y":"Y",X="N":"N",1:0)
	Q YSOUT