YTQPXRM3 ;ASF/ALB - MHQ REMOTE PROCEDURES CONT ; 5/7/07 10:44am
;;5.01;MENTAL HEALTH;**85,240**;DEC 30,1994;Build 10
;
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
; changed so VDIF can call this without limiting # of questions or skipping legacy
S YSERR=0
I '$G(YS("VDIF")),(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
N YSOUT
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
N YSOUT
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
N YSOUT
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPXRM3 4157 printed Dec 13, 2024@02:18:35 Page 2
YTQPXRM3 ;ASF/ALB - MHQ REMOTE PROCEDURES CONT ; 5/7/07 10:44am
+1 ;;5.01;MENTAL HEALTH;**85,240**;DEC 30,1994;Build 10
+2 ;
+3 QUIT
QUESTALL(YSDATA,YS) ;all questions for a test
+1 ;input: CODE as test name
+2 ;output: Field^Value
+3 NEW YSTESTN,YSTEST,YSF,YSV,N,N2,N3,YSEQX,YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,YSQNUMB
+4 SET YSDATA=$NAME(^TMP($JOB,"YSQU"))
KILL ^TMP($JOB,"YSQU")
+5 SET YSCODE=$GET(YS("CODE"),0)
+6 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+7 ;-->out
IF YSTESTN'>0
SET ^TMP($JOB,"YSQU",1)="[ERROR]"
SET ^TMP($JOB,"YSQU",2)="bad code"
QUIT
+8 SET YSQNUMB=0
+9 SET ^TMP($JOB,"YSQU",1)="[DATA]"
+10 ;
+11 SET YSEQX=0
+12 FOR
SET YSEQX=$ORDER(^YTT(601.76,"AD",YSTESTN,YSEQX))
if YSEQX'>0
QUIT
Begin DoDot:1
+13 SET YSIC=0
FOR
SET YSIC=$ORDER(^YTT(601.76,"AD",YSTESTN,YSEQX,YSIC))
if YSIC'>0
QUIT
SET YSQN=$PIECE(^YTT(601.76,YSIC,0),U,4)
DO QUEST2
End DoDot:1
+14 SET ^TMP($JOB,"YSQU",2)=YSCODE_U_"NUMBER OF QUESTIONS="_YSQNUMB
+15 ;now check Ok for clinical reminders
+16 DO CHECKME
+17 QUIT
QUEST2 ;
+1 SET YSQNUMB=YSQNUMB+1
+2 SET ^TMP($JOB,"YSQU","YSCROSS",YSQNUMB)=YSQN
+3 ;text
+4 SET N2=0
FOR
SET N2=$ORDER(^YTT(601.72,YSQN,1,N2))
if N2'>0
QUIT
SET ^TMP($JOB,"YSQU",YSQNUMB,"T",N2)=$PIECE($GET(^YTT(601.72,YSQN,1,N2,0)),U)
+5 ;intro
+6 SET G=+$GET(^YTT(601.72,YSQN,2))
+7 SET N2=0
FOR
SET N2=$ORDER(^YTT(601.73,G,1,N2))
if N2'>0
QUIT
SET ^TMP($JOB,"YSQU",YSQNUMB,"I",N2)=$PIECE($GET(^YTT(601.73,+G,1,N2,0)),U)
+8 ;responses
+9 SET YSLN=0
+10 ;S ^TMP($J,"YSQU",YSQNUMB,"R",0)="X"
+11 SET YSCHOT=$PIECE($GET(^YTT(601.72,YSQN,2)),U,3)
+12 if YSCHOT'>0
QUIT
+13 SET N2=0
FOR
SET N2=$ORDER(^YTT(601.751,"AC",YSCHOT,N2))
if N2'>0
QUIT
Begin DoDot:1
+14 SET YSCHOICE=$ORDER(^YTT(601.751,"AC",YSCHOT,N2,0))
+15 if YSCHOICE'>0
QUIT
+16 if $PIECE(^YTT(601.75,YSCHOICE,0),U,2)=""
QUIT
+17 ;Q:($P(^YTT(601.75,YSCHOICE,0),U,2)="")
+18 SET YSLN=YSLN+1
+19 SET ^TMP($JOB,"YSQU",YSQNUMB,"R",YSLN)=$PIECE($GET(^YTT(601.75,YSCHOICE,1)),U)
+20 SET ^TMP($JOB,"YSQU",YSQNUMB,"R",0)=$GET(^TMP($JOB,"YSQU",YSQNUMB,"R",0))_$PIECE($GET(^YTT(601.75,YSCHOICE,0)),U,2)
+21 SET ^TMP($JOB,"YSQU","YSCA",YSQN,$PIECE(^YTT(601.75,YSCHOICE,0),U,2))=YSCHOICE
End DoDot:1
+22 QUIT
CHECKME ;cr checker
+1 ; changed so VDIF can call this without limiting # of questions or skipping legacy
+2 SET YSERR=0
+3 ;-->out
IF '$GET(YS("VDIF"))
IF (YSQNUMB>200)
DO CLEAN(YSQNUMB_" is too many questions")
QUIT
+4 SET N2=0
FOR
SET N2=$ORDER(^TMP($JOB,"YSQU",N2))
if N2'>0!YSERR
QUIT
Begin DoDot:1
+5 SET YSLEGA=$GET(^TMP($JOB,"YSQU",N2,"R",0))
+6 ;--out
if YSLEGA="X"
DO CLEAN(N2_" no legacy")
QUIT
+7 SET YSRR=$ORDER(^TMP($JOB,"YSQU",YSQNUMB,"R",9999),-1)
+8 if YSRR'=($LENGTH(YSLEGA)-1)
DO CLEAN(N2_" not all legacy")
End DoDot:1
+9 QUIT
CLEAN(X) ;
+1 KILL ^TMP($JOB,"YSQU")
+2 SET ^TMP($JOB,"YSQU",1)="[ERROR]"
+3 SET ^TMP($JOB,"YSQU",2)=X
+4 QUIT
OLDNEW(YSCODEN,YSOLDNUM) ;
+1 ;input YSCODEN ien OF 601.71
+2 ; YSOLDNUM as ien of "S" MULT of 601 (1= DEFAULT)
+3 ;output ien OF 601.87, 0=ERROR
+4 ;
+5 NEW N2,YSQQ,YSNAME,YS601,YSOLDNAM,YSNEWN,YSCALE1,YSC1
+6 NEW YSOUT
+7 IF $GET(YSOLDNUM)=""
SET YSOLDNUM=1
+8 SET YSOUT=0
+9 ;->out
IF '$DATA(^YTT(601.71,YSCODEN,0))
QUIT YSOUT
+10 SET YSNAME=$PIECE(^YTT(601.71,YSCODEN,0),U)
+11 ;-->out
SET YS601=$ORDER(^YTT(601,"B",YSNAME,0))
if YS601'>0
QUIT YSOUT
+12 ;-->out
IF '$DATA(^YTT(601,YS601,"S",YSOLDNUM,0))
QUIT YSOUT
+13 SET YSOLDNAM=$PIECE(^YTT(601,YS601,"S",YSOLDNUM,0),U,2)
+14 DO SCALES^YTQPXRM5(.YSQQ,YSCODEN)
+15 SET N2=0
FOR
SET N2=$ORDER(YSQQ("S",N2))
if N2'>0
QUIT
Begin DoDot:1
+16 SET YSCALE1=YSQQ("S",N2)
+17 SET YSC1($$UCASE^YTQPXRM6(YSCALE1),N2)=""
End DoDot:1
+18 SET YSNEWN=$ORDER(YSC1($$UCASE^YTQPXRM6(YSOLDNAM),0))
+19 if YSNEWN>0
SET YSOUT=YSNEWN
+20 QUIT YSOUT
NEWOLD(YSCODEN,YSNEW) ;
+1 ;input YSCODEN ien OF 601.71
+2 ; YSNEW ien OF 601.87, 0=ERROR
+3 ;output YSOLD as ien of "S" MULT of 601 (1= DEFAULT)
+4 ;
+5 NEW N2,YSX,YSQQ,YSNAME,YS601,YSOLDNAM,YSNEWN,YSON,YSOLDN,YSCNEW
+6 NEW YSOUT
+7 IF YSNEW=""
SET YSNEW=1
+8 SET YSOUT=0
+9 ;->out
IF '$DATA(^YTT(601.71,YSCODEN,0))
QUIT YSOUT
+10 SET YSNAME=$PIECE(^YTT(601.71,YSCODEN,0),U)
+11 ;-->out
SET YS601=$ORDER(^YTT(601,"B",YSNAME,0))
if YS601'>0
QUIT YSOUT
+12 ;-->out
IF '$DATA(^YTT(601.87,YSNEW))
QUIT YSOUT
+13 SET YSCNEW=$PIECE(^YTT(601.87,YSNEW,0),U,4)
+14 SET N=0
FOR
SET N=$ORDER(^YTT(601,YS601,"S",N))
if N'>0
QUIT
Begin DoDot:1
+15 SET YSON=$PIECE(^YTT(601,YS601,"S",N,0),U,2)
+16 SET YSX($$UCASE^YTQPXRM6(YSON),N)=""
End DoDot:1
+17 SET YSOLDN=$ORDER(YSX($$UCASE^YTQPXRM6(YSCNEW),0))
+18 if YSOLDN>0
SET YSOUT=YSOLDN
+19 QUIT YSOUT
RL(YSCODEN) ;requires license
+1 ;input YSCODEN ien OF 601.71
+2 ;output Y/N/0
+3 ;
+4 NEW X
+5 NEW YSOUT
+6 SET YSOUT=0
+7 ;->out
IF '$DATA(^YTT(601.71,YSCODEN,0))
QUIT YSOUT
+8 SET X=$$GET1^DIQ(601.71,YSCODEN_",",11,"I")
+9 SET YSOUT=$SELECT(X="Y":"Y",X="N":"N",1:0)
+10 QUIT YSOUT
