source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTQPRT.m@ 1804

Last change on this file since 1804 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1YTQPRT ;ASF/ALB MHA3 PRINT TEST; 3/15/06 11:37am ; 4/26/07 9:37am
2 ;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 49
3 ;
4 Q
5ALLFORM ;all tests
6 S YSCODEN=0 F S YSCODEN=$O(^YTT(601.71,YSCODEN)) Q:YSCODEN>9999 S YSCODE=$P(^(YSCODEN,0),U) W !!,"#############" D FA W !!!,"################"
7 Q
8FORM ;print for clinicians
9 N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN
10 N DA,G,J,N,N1,Y,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP
11 K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
12 S YSCODEN=+Y,YSCODE=$P(Y,U,2)
13 S DA=YSCODEN D EN^DIQ
14FA W !?7,YSCODE
15 W !,$$GET1^DIQ(601.71,YSCODEN_",","PRINT TITLE")
16 S YSNUMB=0
17 ;Loop thru test for all items
18 S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSCODEN,YSEQ)) Q:YSEQ'>0 S YSIEN=$O(^YTT(601.76,"AD",YSCODEN,YSEQ,0)) Q:YSIEN'>0 S YSNUMB=YSNUMB+1,YSR=0 D
19 . S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2)),YSRTYPE=$P(YSQG2,U,2)
20 . S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
21 . D QOUT
22 . W:YSRTYPE'=1 !,$$GET1^DIQ(601.74,YSRTYPE_",",1)_":__________"
23 . S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;-->out
24 . S YSIDENT=$O(^YTT(601.89,"B",YSCTYPE,0)) S:YSIDENT'="" YSIDENT=$P($G(^YTT(601.89,YSIDENT,0)),U,2)
25 . S YSI=0 S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 S YSI=YSI+1 D
26 .. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
27 ... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
28 ... W !,"_____ ",$S(YSIDENT=0:YSI-1_".",YSIDENT="N":"",1:YSI_".")," ",YSCTEXT
29 K ^TMP($J,"YSG")
30 Q
31QOUT ;pull text and intros
32 W !! ;,YSEQ,">> Question#"_YSQN
33 S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
34 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)
35 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)
36 Q
37PRTTEST ;print for developers
38 K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
39 N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN
40 N DA,G,J,N,N1,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP
41EN1 ;
42 S YSCODEN=+Y,YSCODE=$P(^YTT(601.71,YSCODEN,0),U)
43 S DA=YSCODEN,DIC="^YTT(601.71," D EN^DIQ
44 S YSNUMB=0
45 ;Loop thru test for all items
46 S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSCODEN,YSEQ)) Q:YSEQ'>0 S YSIEN=$O(^YTT(601.76,"AD",YSCODEN,YSEQ,0)) Q:YSIEN'>0 S YSNUMB=YSNUMB+1,YSR=0 D
47 . S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2))
48 . S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
49 . D GETTEXT
50 . S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;->out
51 . W !,"Choicetype: ",YSCTYPE
52 . 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)
53 . D IENCK(YSCTYPE)
54 . S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 D
55 .. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
56 ... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
57 ... S YSLEG=$P($G(^YTT(601.75,YSCHOICE,0)),U,2)
58 ... W !,"# "_YSCHOICE_" Leg: "_YSLEG_" "_YSCTEXT
59 D SCALES
60 D SKIP
61 D RULESKIP
62 K ^TMP($J,"YSG")
63 Q
64GETTEXT ;pull text and intros
65 W !!,"<<",YSEQ,">> Question#"_YSQN," Display Q: ",YSQDISP," I: ",YSIDISP," C: ",YSCDISP
66 S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
67 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)
68 S N1=0 F S N1=$O(^YTT(601.72,YSQN,1,N1)) Q:N1'>0 W !,^YTT(601.72,YSQN,1,N1,0)
69 Q
70SCALES ;scales
71 W !!!?5,"*** Scales ***",!
72 S YS1("CODE")=YSCODE D SCALEG^YTQAPI3(.YSZ,.YS1)
73 S N=1 F S N=$O(^TMP($J,"YSG",N)) Q:N'>0 D
74 . S G=^TMP($J,"YSG",N)
75 . I G'?1"Scale".E W !,"scale group: ",+$P(G,"=",2)," ",$P(G,U,3) Q
76 . S YSSCALE=$P(G,U,4),YSSCIEN=$P($P(G,U,1),"=",2)
77 . W !,YSSCIEN,?10,YSSCALE
78 . Q:'$D(^YTT(601.91,"AC",YSSCIEN))
79 . W !?5,"# Question target ADD"
80 . 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)
81 K ^TMP($J,"YSG")
82 Q
83SKIP ;skip questions
84 W !!!?5,"*** Skips ***",!
85 S N=0 F S N=$O(^YTT(601.79,"AC",YSCODEN,N)) Q:N'>0 D
86 .S G=^YTT(601.79,N,0)
87 . W !,"SkipID: "+$P(G,U)_" RuleId: "_$P(G,U,3)_" QuestionID: "_$P(G,U,4)
88 .S ^TMP($J,"YSG",$P(G,U,3))=""
89 Q
90RULESKIP ;rules that skip questions
91 S N=0 F S N=$O(^TMP($J,"YSG",N)) Q:N'>1 D
92 . W !
93 . S DA=N,DIC="^YTT(601.82," D EN^DIQ
94 Q
95IENCK(NN) ;check ien< 100,000
96 Q:YSCODEN>99999 ;-->out
97 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)=""
98 Q
99ALLPRT ;print all tests
100 D ^%ZIS
101 S YSALL=0 F S YSALL=$O(^YTT(601.71,YSALL)) Q:(YSALL>99999)!(YSALL'>0) S Y=YSALL W @IOF D EN1
102 Q
Note: See TracBrowser for help on using the repository browser.