Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQPRT

YTQPRT.m

Go to the documentation of this file.
  1. YTQPRT ;ASF/ALB MHA3 PRINT TEST; 2/24/10 1:27pm
  1. ;;5.01;MENTAL HEALTH;**85,97,119**;DEC 30,1994;Build 40
  1. ;
  1. Q
  1. FORM ;print for clinicians
  1. N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN,YSLFT
  1. N DA,G,J,N,N1,Y,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP
  1. N YTTLKUP S YTTLKUP=1 ; suppress filter
  1. K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
  1. S YSCODEN=+Y,YSCODE=$P(Y,U,2)
  1. ;S DA=YSCODEN D EN^DIQ
  1. D ^%ZIS Q:POP
  1. FA W @IOF,!?7,YSCODE
  1. W !,$$GET1^DIQ(601.71,YSCODEN_",","PRINT TITLE")
  1. S YSNUMB=0,YSLFT=""
  1. ;Loop thru test for all items
  1. 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
  1. . D:(($Y+5)>IOSL) WAIT
  1. . S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2)),YSRTYPE=$P(YSQG2,U,2)
  1. . S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
  1. . D QOUT
  1. . W:YSRTYPE'=1 !,$$GET1^DIQ(601.74,YSRTYPE_",",1)_":__________"
  1. . S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;-->out
  1. . S YSIDENT=$O(^YTT(601.89,"B",YSCTYPE,0)) S:YSIDENT'="" YSIDENT=$P($G(^YTT(601.89,YSIDENT,0)),U,2)
  1. . S YSI=0 S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 S YSI=YSI+1 D
  1. .. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
  1. ... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
  1. ... W !,"_____ ",$S(YSIDENT=0:YSI-1_".",YSIDENT="N":"",1:YSI_".")," ",YSCTEXT
  1. K ^TMP($J,"YSG")
  1. D ^%ZISC
  1. Q
  1. QOUT ;pull text and intros
  1. W !! ;,YSEQ,">> Question#"_YSQN
  1. S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
  1. 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)
  1. 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)
  1. Q
  1. PRTTEST ;print for developers
  1. N YTTLKUP S YTTLKUP=1 ; suppress filter
  1. K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
  1. N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN
  1. N DA,G,J,N,N1,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP,YSLFT,YSRPT
  1. EN1 ;
  1. I '$G(YTTLKUP) N YTTLKUP S YTTLKUP=1 ; suppress filter
  1. K IOP S %ZIS="Q" D ^%ZIS Q:POP ;-->out
  1. S YSCODEN=+Y,YSCODE=$P(^YTT(601.71,YSCODEN,0),U)
  1. W @IOF,!?10,"*** ",YSCODE," ***",!
  1. S DA=YSCODEN,DIC="^YTT(601.71," D EN^DIQ
  1. S YSNUMB=0,YSLFT=""
  1. D:(($Y+9)>IOSL) WAIT
  1. Q:YSLFT
  1. ;Loop thru test for all items
  1. 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
  1. . D:(($Y+5)>IOSL) WAIT
  1. . S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2))
  1. . S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
  1. . D GETTEXT
  1. . S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;->out
  1. . W !,"Choicetype: ",YSCTYPE
  1. . 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)
  1. . D IENCK(YSCTYPE)
  1. . S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 D
  1. .. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
  1. ... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
  1. ... S YSLEG=$P($G(^YTT(601.75,YSCHOICE,0)),U,2)
  1. ... W !,"# "_YSCHOICE_" Leg: "_YSLEG_" "_YSCTEXT
  1. Q:YSLFT ;-->out
  1. D SCALES
  1. Q:YSLFT ;-->out
  1. D SKIP
  1. Q:YSLFT ;-->out
  1. D RULESKIP
  1. Q:YSLFT ;-->out
  1. D REPORT
  1. K ^TMP($J,"YSG")
  1. D ^%ZISC
  1. Q
  1. GETTEXT ;pull text and intros
  1. W !!,"<<",YSEQ,">> Question#"_YSQN," Display Q: ",YSQDISP," I: ",YSIDISP," C: ",YSCDISP
  1. S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
  1. 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)
  1. S N1=0 F S N1=$O(^YTT(601.72,YSQN,1,N1)) Q:N1'>0 W !,^YTT(601.72,YSQN,1,N1,0)
  1. Q
  1. SCALES ;scales
  1. W !!!?5,"*** Scales ***",!
  1. S YS1("CODE")=YSCODE D SCALEG^YTQAPI3(.YSZ,.YS1)
  1. S N=1 F S N=$O(^TMP($J,"YSG",N)) Q:N'>0!(YSLFT) D
  1. . D:(($Y+9)>IOSL) WAIT
  1. . S G=^TMP($J,"YSG",N)
  1. . I G'?1"Scale".E W !,"scale group: ",+$P(G,"=",2)," ",$P(G,U,3) Q
  1. . S YSSCALE=$P(G,U,4),YSSCIEN=$P($P(G,U,1),"=",2)
  1. . W !,YSSCIEN,?10,YSSCALE
  1. . Q:'$D(^YTT(601.91,"AC",YSSCIEN))
  1. . W !?5,"# Question target ADD"
  1. . 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)
  1. K ^TMP($J,"YSG")
  1. Q
  1. SKIP ;skip questions
  1. W !!!?5,"*** Skips ***",!
  1. S N=0 F S N=$O(^YTT(601.79,"AC",YSCODEN,N)) Q:N'>0!(YSLFT) D
  1. . D:(($Y+9)>IOSL) WAIT
  1. .S G=^YTT(601.79,N,0)
  1. . W !,"SkipID: "+$P(G,U)_" RuleId: "_$P(G,U,3)_" QuestionID: "_$P(G,U,4)
  1. .S ^TMP($J,"YSG",$P(G,U,3))=""
  1. Q
  1. RULESKIP ;rules that skip questions
  1. S N=0 F S N=$O(^TMP($J,"YSG",N)) Q:N'>1!(YSLFT) D
  1. . D:(($Y+9)>IOSL) WAIT
  1. . W !
  1. . S DA=N,DIC="^YTT(601.82," D EN^DIQ
  1. Q
  1. REPORT ;display report setup
  1. S YSRPT=$O(^YTT(601.93,"C",YSCODEN,0))
  1. I YSRPT'>0 W !!,"REPORT: not defined",!! Q ;-->out
  1. W !!
  1. S DA=YSRPT,DIC="^YTT(601.93," D EN^DIQ
  1. Q
  1. IENCK(NN) ;check ien< 100,000
  1. Q:YSCODEN>99999 ;-->out
  1. ; No national numbers left for 601.751, also not a DINUM'd file -- KCM
  1. ; 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)=""
  1. Q
  1. WAIT ;
  1. F I0=1:1:IOSL-$Y-4 W !
  1. N DTOUT,DUOUT,DIRUT
  1. I IOST?1"C".E S DIR(0)="E" D ^DIR K DIR S YSLFT=$D(DIRUT)
  1. W @IOF Q