YTQPRT ;ASF/ALB MHA3 PRINT TEST; 2/24/10 1:27pm
;;5.01;MENTAL HEALTH;**85,97,119**;DEC 30,1994;Build 40
;
Q
FORM ;print for clinicians
N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN,YSLFT
N DA,G,J,N,N1,Y,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP
N YTTLKUP S YTTLKUP=1 ; suppress filter
K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
S YSCODEN=+Y,YSCODE=$P(Y,U,2)
;S DA=YSCODEN D EN^DIQ
D ^%ZIS Q:POP
FA W @IOF,!?7,YSCODE
W !,$$GET1^DIQ(601.71,YSCODEN_",","PRINT TITLE")
S YSNUMB=0,YSLFT=""
;Loop thru test for all items
S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSCODEN,YSEQ)) Q:YSEQ'>0!(YSLFT) S YSIEN=$O(^YTT(601.76,"AD",YSCODEN,YSEQ,0)) Q:YSIEN'>0!(YSLFT) S YSNUMB=YSNUMB+1,YSR=0 D
. D:(($Y+5)>IOSL) WAIT
. S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2)),YSRTYPE=$P(YSQG2,U,2)
. S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
. D QOUT
. W:YSRTYPE'=1 !,$$GET1^DIQ(601.74,YSRTYPE_",",1)_":__________"
. S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;-->out
. S YSIDENT=$O(^YTT(601.89,"B",YSCTYPE,0)) S:YSIDENT'="" YSIDENT=$P($G(^YTT(601.89,YSIDENT,0)),U,2)
. S YSI=0 S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 S YSI=YSI+1 D
.. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
... W !,"_____ ",$S(YSIDENT=0:YSI-1_".",YSIDENT="N":"",1:YSI_".")," ",YSCTEXT
K ^TMP($J,"YSG")
D ^%ZISC
Q
QOUT ;pull text and intros
W !! ;,YSEQ,">> Question#"_YSQN
S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
I YSINTRO?1N.N S N1=0 F S N1=$O(^YTT(601.73,YSINTRO,1,N1)) Q:N1'>0 W !,^YTT(601.73,YSINTRO,1,N1,0)
W !,YSNUMB,". " S N1=0 F S N1=$O(^YTT(601.72,YSQN,1,N1)) Q:N1'>0 W:N1>1 ! W ^YTT(601.72,YSQN,1,N1,0)
Q
PRTTEST ;print for developers
N YTTLKUP S YTTLKUP=1 ; suppress filter
K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN
N DA,G,J,N,N1,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP,YSLFT,YSRPT
EN1 ;
I '$G(YTTLKUP) N YTTLKUP S YTTLKUP=1 ; suppress filter
K IOP S %ZIS="Q" D ^%ZIS Q:POP ;-->out
S YSCODEN=+Y,YSCODE=$P(^YTT(601.71,YSCODEN,0),U)
W @IOF,!?10,"*** ",YSCODE," ***",!
S DA=YSCODEN,DIC="^YTT(601.71," D EN^DIQ
S YSNUMB=0,YSLFT=""
D:(($Y+9)>IOSL) WAIT
Q:YSLFT
;Loop thru test for all items
S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSCODEN,YSEQ)) Q:YSEQ'>0!(YSLFT) S YSIEN=$O(^YTT(601.76,"AD",YSCODEN,YSEQ,0)) Q:YSIEN'>0!(YSLFT) S YSNUMB=YSNUMB+1,YSR=0 D
. D:(($Y+5)>IOSL) WAIT
. S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2))
. S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
. D GETTEXT
. S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;->out
. W !,"Choicetype: ",YSCTYPE
. W " identifier: " I $D(^YTT(601.89,"B",YSCTYPE)) S YSIDENT=$O(^YTT(601.89,"B",YSCTYPE,0)) Q:YSIDENT="" W $P($G(^YTT(601.89,YSIDENT,0)),U,2)
. D IENCK(YSCTYPE)
. S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 D
.. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
... S YSLEG=$P($G(^YTT(601.75,YSCHOICE,0)),U,2)
... W !,"# "_YSCHOICE_" Leg: "_YSLEG_" "_YSCTEXT
Q:YSLFT ;-->out
D SCALES
Q:YSLFT ;-->out
D SKIP
Q:YSLFT ;-->out
D RULESKIP
Q:YSLFT ;-->out
D REPORT
K ^TMP($J,"YSG")
D ^%ZISC
Q
GETTEXT ;pull text and intros
W !!,"<<",YSEQ,">> Question#"_YSQN," Display Q: ",YSQDISP," I: ",YSIDISP," C: ",YSCDISP
S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
I YSINTRO?1N.N W !,"Intro #"_YSINTRO S N1=0 F S N1=$O(^YTT(601.73,YSINTRO,1,N1)) Q:N1'>0 W !,^YTT(601.73,YSINTRO,1,N1,0)
S N1=0 F S N1=$O(^YTT(601.72,YSQN,1,N1)) Q:N1'>0 W !,^YTT(601.72,YSQN,1,N1,0)
Q
SCALES ;scales
W !!!?5,"*** Scales ***",!
S YS1("CODE")=YSCODE D SCALEG^YTQAPI3(.YSZ,.YS1)
S N=1 F S N=$O(^TMP($J,"YSG",N)) Q:N'>0!(YSLFT) D
. D:(($Y+9)>IOSL) WAIT
. S G=^TMP($J,"YSG",N)
. I G'?1"Scale".E W !,"scale group: ",+$P(G,"=",2)," ",$P(G,U,3) Q
. S YSSCALE=$P(G,U,4),YSSCIEN=$P($P(G,U,1),"=",2)
. W !,YSSCIEN,?10,YSSCALE
. Q:'$D(^YTT(601.91,"AC",YSSCIEN))
. W !?5,"# Question target ADD"
. S J=0 F S J=$O(^YTT(601.91,"AC",YSSCIEN,J)) Q:J'>0 S G=^YTT(601.91,J,0) W !?5,+G,?12,$P(G,U,3)," ",$P(G,U,4)," ",$P(G,U,5)
K ^TMP($J,"YSG")
Q
SKIP ;skip questions
W !!!?5,"*** Skips ***",!
S N=0 F S N=$O(^YTT(601.79,"AC",YSCODEN,N)) Q:N'>0!(YSLFT) D
. D:(($Y+9)>IOSL) WAIT
.S G=^YTT(601.79,N,0)
. W !,"SkipID: "+$P(G,U)_" RuleId: "_$P(G,U,3)_" QuestionID: "_$P(G,U,4)
.S ^TMP($J,"YSG",$P(G,U,3))=""
Q
RULESKIP ;rules that skip questions
S N=0 F S N=$O(^TMP($J,"YSG",N)) Q:N'>1!(YSLFT) D
. D:(($Y+9)>IOSL) WAIT
. W !
. S DA=N,DIC="^YTT(601.82," D EN^DIQ
Q
REPORT ;display report setup
S YSRPT=$O(^YTT(601.93,"C",YSCODEN,0))
I YSRPT'>0 W !!,"REPORT: not defined",!! Q ;-->out
W !!
S DA=YSRPT,DIC="^YTT(601.93," D EN^DIQ
Q
IENCK(NN) ;check ien< 100,000
Q:YSCODEN>99999 ;-->out
; No national numbers left for 601.751, also not a DINUM'd file -- KCM
; S J=0 F S J=$O(^YTT(601.751,"B",NN,J)) Q:J'>0 I J>99999 W !,"###### not national ######## ",^YTT(601.751,J,0) S ^TMP($J,"YSNATERR",NN,YSCODE)=""
Q
WAIT ;
F I0=1:1:IOSL-$Y-4 W !
N DTOUT,DUOUT,DIRUT
I IOST?1"C".E S DIR(0)="E" D ^DIR K DIR S YSLFT=$D(DIRUT)
W @IOF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPRT 5682 printed Apr 09, 2024@21:19:59 Page 2
YTQPRT ;ASF/ALB MHA3 PRINT TEST; 2/24/10 1:27pm
+1 ;;5.01;MENTAL HEALTH;**85,97,119**;DEC 30,1994;Build 40
+2 ;
+3 QUIT
FORM ;print for clinicians
+1 NEW YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN,YSLFT
+2 NEW DA,G,J,N,N1,Y,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP
+3 ; suppress filter
NEW YTTLKUP
SET YTTLKUP=1
+4 KILL DIC
SET DIC(0)="MAE"
SET DIC="^YTT(601.71,"
DO ^DIC
if Y'>0
QUIT
+5 SET YSCODEN=+Y
SET YSCODE=$PIECE(Y,U,2)
+6 ;S DA=YSCODEN D EN^DIQ
+7 DO ^%ZIS
if POP
QUIT
FA WRITE @IOF,!?7,YSCODE
+1 WRITE !,$$GET1^DIQ(601.71,YSCODEN_",","PRINT TITLE")
+2 SET YSNUMB=0
SET YSLFT=""
+3 ;Loop thru test for all items
+4 SET YSEQ=0
FOR
SET YSEQ=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ))
if YSEQ'>0!(YSLFT)
QUIT
SET YSIEN=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ,0))
if YSIEN'>0!(YSLFT)
QUIT
SET YSNUMB=YSNUMB+1
SET YSR=0
Begin DoDot:1
+5 if (($Y+5)>IOSL)
DO WAIT
+6 SET YSG=^YTT(601.76,YSIEN,0)
SET YSQN=$PIECE(YSG,U,4)
SET YSQG2=$GET(^YTT(601.72,YSQN,2))
SET YSRTYPE=$PIECE(YSQG2,U,2)
+7 SET YSQDISP=$PIECE(YSG,U,6)
SET YSIDISP=$PIECE(YSG,U,7)
SET YSCDISP=$PIECE(YSG,U,8)
+8 DO QOUT
+9 if YSRTYPE'=1
WRITE !,$$GET1^DIQ(601.74,YSRTYPE_",",1)_":__________"
+10 ;-->out
SET YSCTYPE=$PIECE(YSQG2,U,3)
if YSCTYPE=""
QUIT
+11 SET YSIDENT=$ORDER(^YTT(601.89,"B",YSCTYPE,0))
if YSIDENT'=""
SET YSIDENT=$PIECE($GET(^YTT(601.89,YSIDENT,0)),U,2)
+12 SET YSI=0
SET YSCHTSEQ=0
FOR
SET YSCHTSEQ=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ))
if YSCHTSEQ'>0
QUIT
SET YSI=YSI+1
Begin DoDot:2
+13 SET YSCHOICE=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0))
if YSCHOICE'>0
QUIT
Begin DoDot:3
+14 SET YSCTEXT=$GET(^YTT(601.75,YSCHOICE,1))
+15 WRITE !,"_____ ",$SELECT(YSIDENT=0:YSI-1_".",YSIDENT="N":"",1:YSI_".")," ",YSCTEXT
End DoDot:3
End DoDot:2
End DoDot:1
+16 KILL ^TMP($JOB,"YSG")
+17 DO ^%ZISC
+18 QUIT
QOUT ;pull text and intros
+1 ;,YSEQ,">> Question#"_YSQN
WRITE !!
+2 SET YSINTRO=$PIECE($GET(^YTT(601.72,YSQN,2)),U)
+3 IF YSINTRO?1N.N
SET N1=0
FOR
SET N1=$ORDER(^YTT(601.73,YSINTRO,1,N1))
if N1'>0
QUIT
WRITE !,^YTT(601.73,YSINTRO,1,N1,0)
+4 WRITE !,YSNUMB,". "
SET N1=0
FOR
SET N1=$ORDER(^YTT(601.72,YSQN,1,N1))
if N1'>0
QUIT
if N1>1
WRITE !
WRITE ^YTT(601.72,YSQN,1,N1,0)
+5 QUIT
PRTTEST ;print for developers
+1 ; suppress filter
NEW YTTLKUP
SET YTTLKUP=1
+2 KILL DIC
SET DIC(0)="MAE"
SET DIC="^YTT(601.71,"
DO ^DIC
if Y'>0
QUIT
+3 NEW YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN
+4 NEW DA,G,J,N,N1,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP,YSLFT,YSRPT
EN1 ;
+1 ; suppress filter
IF '$GET(YTTLKUP)
NEW YTTLKUP
SET YTTLKUP=1
+2 ;-->out
KILL IOP
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+3 SET YSCODEN=+Y
SET YSCODE=$PIECE(^YTT(601.71,YSCODEN,0),U)
+4 WRITE @IOF,!?10,"*** ",YSCODE," ***",!
+5 SET DA=YSCODEN
SET DIC="^YTT(601.71,"
DO EN^DIQ
+6 SET YSNUMB=0
SET YSLFT=""
+7 if (($Y+9)>IOSL)
DO WAIT
+8 if YSLFT
QUIT
+9 ;Loop thru test for all items
+10 SET YSEQ=0
FOR
SET YSEQ=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ))
if YSEQ'>0!(YSLFT)
QUIT
SET YSIEN=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ,0))
if YSIEN'>0!(YSLFT)
QUIT
SET YSNUMB=YSNUMB+1
SET YSR=0
Begin DoDot:1
+11 if (($Y+5)>IOSL)
DO WAIT
+12 SET YSG=^YTT(601.76,YSIEN,0)
SET YSQN=$PIECE(YSG,U,4)
SET YSQG2=$GET(^YTT(601.72,YSQN,2))
+13 SET YSQDISP=$PIECE(YSG,U,6)
SET YSIDISP=$PIECE(YSG,U,7)
SET YSCDISP=$PIECE(YSG,U,8)
+14 DO GETTEXT
+15 ;->out
SET YSCTYPE=$PIECE(YSQG2,U,3)
if YSCTYPE=""
QUIT
+16 WRITE !,"Choicetype: ",YSCTYPE
+17 WRITE " identifier: "
IF $DATA(^YTT(601.89,"B",YSCTYPE))
SET YSIDENT=$ORDER(^YTT(601.89,"B",YSCTYPE,0))
if YSIDENT=""
QUIT
WRITE $PIECE($GET(^YTT(601.89,YSIDENT,0)),U,2)
+18 DO IENCK(YSCTYPE)
+19 SET YSCHTSEQ=0
FOR
SET YSCHTSEQ=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ))
if YSCHTSEQ'>0
QUIT
Begin DoDot:2
+20 SET YSCHOICE=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0))
if YSCHOICE'>0
QUIT
Begin DoDot:3
+21 SET YSCTEXT=$GET(^YTT(601.75,YSCHOICE,1))
+22 SET YSLEG=$PIECE($GET(^YTT(601.75,YSCHOICE,0)),U,2)
+23 WRITE !,"# "_YSCHOICE_" Leg: "_YSLEG_" "_YSCTEXT
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;-->out
if YSLFT
QUIT
+25 DO SCALES
+26 ;-->out
if YSLFT
QUIT
+27 DO SKIP
+28 ;-->out
if YSLFT
QUIT
+29 DO RULESKIP
+30 ;-->out
if YSLFT
QUIT
+31 DO REPORT
+32 KILL ^TMP($JOB,"YSG")
+33 DO ^%ZISC
+34 QUIT
GETTEXT ;pull text and intros
+1 WRITE !!,"<<",YSEQ,">> Question#"_YSQN," Display Q: ",YSQDISP," I: ",YSIDISP," C: ",YSCDISP
+2 SET YSINTRO=$PIECE($GET(^YTT(601.72,YSQN,2)),U)
+3 IF YSINTRO?1N.N
WRITE !,"Intro #"_YSINTRO
SET N1=0
FOR
SET N1=$ORDER(^YTT(601.73,YSINTRO,1,N1))
if N1'>0
QUIT
WRITE !,^YTT(601.73,YSINTRO,1,N1,0)
+4 SET N1=0
FOR
SET N1=$ORDER(^YTT(601.72,YSQN,1,N1))
if N1'>0
QUIT
WRITE !,^YTT(601.72,YSQN,1,N1,0)
+5 QUIT
SCALES ;scales
+1 WRITE !!!?5,"*** Scales ***",!
+2 SET YS1("CODE")=YSCODE
DO SCALEG^YTQAPI3(.YSZ,.YS1)
+3 SET N=1
FOR
SET N=$ORDER(^TMP($JOB,"YSG",N))
if N'>0!(YSLFT)
QUIT
Begin DoDot:1
+4 if (($Y+9)>IOSL)
DO WAIT
+5 SET G=^TMP($JOB,"YSG",N)
+6 IF G'?1"Scale".E
WRITE !,"scale group: ",+$PIECE(G,"=",2)," ",$PIECE(G,U,3)
QUIT
+7 SET YSSCALE=$PIECE(G,U,4)
SET YSSCIEN=$PIECE($PIECE(G,U,1),"=",2)
+8 WRITE !,YSSCIEN,?10,YSSCALE
+9 if '$DATA(^YTT(601.91,"AC",YSSCIEN))
QUIT
+10 WRITE !?5,"# Question target ADD"
+11 SET J=0
FOR
SET J=$ORDER(^YTT(601.91,"AC",YSSCIEN,J))
if J'>0
QUIT
SET G=^YTT(601.91,J,0)
WRITE !?5,+G,?12,$PIECE(G,U,3)," ",$PIECE(G,U,4)," ",$PIECE(G,U,5)
End DoDot:1
+12 KILL ^TMP($JOB,"YSG")
+13 QUIT
SKIP ;skip questions
+1 WRITE !!!?5,"*** Skips ***",!
+2 SET N=0
FOR
SET N=$ORDER(^YTT(601.79,"AC",YSCODEN,N))
if N'>0!(YSLFT)
QUIT
Begin DoDot:1
+3 if (($Y+9)>IOSL)
DO WAIT
+4 SET G=^YTT(601.79,N,0)
+5 WRITE !,"SkipID: "+$PIECE(G,U)_" RuleId: "_$PIECE(G,U,3)_" QuestionID: "_$PIECE(G,U,4)
+6 SET ^TMP($JOB,"YSG",$PIECE(G,U,3))=""
End DoDot:1
+7 QUIT
RULESKIP ;rules that skip questions
+1 SET N=0
FOR
SET N=$ORDER(^TMP($JOB,"YSG",N))
if N'>1!(YSLFT)
QUIT
Begin DoDot:1
+2 if (($Y+9)>IOSL)
DO WAIT
+3 WRITE !
+4 SET DA=N
SET DIC="^YTT(601.82,"
DO EN^DIQ
End DoDot:1
+5 QUIT
REPORT ;display report setup
+1 SET YSRPT=$ORDER(^YTT(601.93,"C",YSCODEN,0))
+2 ;-->out
IF YSRPT'>0
WRITE !!,"REPORT: not defined",!!
QUIT
+3 WRITE !!
+4 SET DA=YSRPT
SET DIC="^YTT(601.93,"
DO EN^DIQ
+5 QUIT
IENCK(NN) ;check ien< 100,000
+1 ;-->out
if YSCODEN>99999
QUIT
+2 ; No national numbers left for 601.751, also not a DINUM'd file -- KCM
+3 ; S J=0 F S J=$O(^YTT(601.751,"B",NN,J)) Q:J'>0 I J>99999 W !,"###### not national ######## ",^YTT(601.751,J,0) S ^TMP($J,"YSNATERR",NN,YSCODE)=""
+4 QUIT
WAIT ;
+1 FOR I0=1:1:IOSL-$Y-4
WRITE !
+2 NEW DTOUT,DUOUT,DIRUT
+3 IF IOST?1"C".E
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET YSLFT=$DATA(DIRUT)
+4 WRITE @IOF
QUIT
