YTQPXRM3.m

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 ---YTQPXRM3   4157     printed  Apr 23, 2025@18:33                                                                                                                                                                                                       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