source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTQAPI10.m@ 1608

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

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1YTQAPI10 ;ASF/ALB MHQ COPY PROCEEDURES ;12/2/04 11:41am
2 ;;5.01;MENTAL HEALTH;**85**;Dec 30, 1994;Build 49
3 Q
4ZZ K YS,YSDATA R !,"OLD TEST: ",Z1:30 R !,"new test: ",Z2:30
5 S YS("ORIGINAL")=Z1,YS("NEW")=Z2 D COPY(.YSDATA,.YS)
6 Q
7COPY(YSDATA,YS) ;copy instrument
8 N %X,%Y,DA,DIK,G,G1,G2,N,N1,N3,X,Y,YSDISNEW,YSDISOLD,YSECNEW,YSERR
9 N YSFILE,YSI,YSISRNEW,YSKEYNEW,YSKEYOLD,YSKIPNEW,YSN,YSN1,YSNAT,YSNEWI,YSNEWNAM,YSNEWNUM,YSOLDI,YSOLDNAM
10 N YSOLDNUM,YSPROG,YSQUNEW,YSQX,YSRULNEW,YSRULOLD,YSSGNEW,YSSGOLD,YSSLNEW,YSSLOLD,Z1,Z2
11 S YSERR=0
12 K ^TMP($J,"YSM")
13 D PARSE Q:YSERR ; set/check inputs
14 D INS ;add new test entry
15 D QUES ;duplicate questions
16 D INTRO ;introductions
17 D DISPLAY ; q<i>c displays
18 D SKIP ;skipped questions
19 D RULES^YTQAPI11 ;instrument rules and rules
20 D SECTION
21 D SCALES^YTQAPI11 ;scale grps,scales,keys
22 S YSDATA(1)="[DATA]"
23 Q
24SECTION ;headings
25 S YSFILE=601.81,N=0
26 S N=$O(^YTT(601.81,"AC",YSOLDNUM,N)) Q:N'>0 D
27 . S G1=^YTT(601.81,N,0)
28 . S YSECNEW=$$NEW^YTQLIB(YSFILE)
29 . S ^YTT(601.81,YSECNEW,0)=G1
30 . S $P(^YTT(601.81,YSECNEW,0),U)=YSECNEW
31 . S $P(^YTT(601.81,YSECNEW,0),U,2)=YSNEWNUM
32 . S YSQX=$P(G1,U,3)
33 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.81,YSECNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
34 . S DA=YSECNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
35 . S YSDISOLD=$P(G1,U,6)
36 . Q:YSDISOLD'?1N.N
37 . S YSDISNEW=$$NEW^YTQLIB(YSFILE)
38 . S %X="^YTT(601.88,"_YSDISOLD_","
39 . S %Y="^YTT(601.88,"_YSDISNEW_","
40 . D %XY^%RCR
41 . S $P(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
42 . S DA=YSDISNEW,DIK="^YTT(601.88," D IX^DIK
43 . S $P(^YTT(601.81,YSECNEW,0),U,6)=YSDISNEW
44 Q
45SKIP ;skipped qs
46 S YSFILE=601.79,N=0
47 F S N=$O(^YTT(601.79,"AC",YSOLDNUM,N)) Q:N'>0 D
48 . S G1=^YTT(601.79,N,0)
49 . S YSKIPNEW=$$NEW^YTQLIB(YSFILE)
50 . S ^YTT(601.79,YSKIPNEW,0)=G1
51 . S $P(^YTT(601.79,YSKIPNEW,0),U)=YSKIPNEW
52 . S $P(^YTT(601.79,YSKIPNEW,0),U,2)=YSNEWNUM
53 . S YSQX=$P(G1,U,3)
54 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.79,YSKIPNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
55 S DA=YSKIPNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
56 Q
57DISPLAY ;display ques<intro<choice
58 S YSFILE=601.88
59 S YSN=0 F S YSN=$O(^YTT(601.76,"AC",YSNEWNUM,YSN)) Q:YSN'>0 D
60 . S G=^YTT(601.76,YSN,0)
61 . F YSI=7,8,9 S YSDISOLD=$P(G,U,YSI) D:YSDISOLD?1N.N
62 .. S YSDISNEW=$$NEW^YTQLIB(YSFILE)
63 .. S %X="^YTT("_YSFILE_","_YSDISOLD_","
64 .. S %Y="^YTT("_YSFILE_","_YSDISNEW_","
65 .. D %XY^%RCR
66 .. S $P(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
67 .. S DA=YSDISNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
68 .. S $P(^YTT(601.76,YSN,0),U,YSI)=YSDISNEW
69 Q
70INS ; new one
71 S YSFILE=601.71
72 S YSOLDNUM=$O(^YTT(601.71,"B",YSOLDNAM,-1))
73 S YSNEWNUM=$$NEW^YTQLIB(YSFILE)
74 S %X="^YTT("_YSFILE_","_YSOLDNUM_","
75 S %Y="^YTT("_YSFILE_","_YSNEWNUM_","
76 D %XY^%RCR
77 S $P(^YTT(YSFILE,YSNEWNUM,0),U)=YSNEWNAM
78 S $P(^YTT(YSFILE,YSNEWNUM,2),U,2)="U"
79 S $P(^YTT(YSFILE,YSNEWNUM,2),U,5)=""
80 S DA=YSNEWNUM,DIK="^YTT("_YSFILE_"," D IX^DIK
81 Q
82QUES ;questions, content and intros
83 S N=0 F S N=$O(^YTT(601.76,"AD",YSOLDNUM,N)) Q:N'>0 D
84 . S YSQUNEW=$$NEW^YTQLIB(601.72)
85 . S %X="^YTT(601.72,"_N_","
86 . S %Y="^YTT(601.72,"_YSQUNEW_","
87 . D %XY^%RCR
88 . S $P(^YTT(601.72,YSQUNEW,0),U)=YSQUNEW
89 . S ^TMP($J,"YSM","N",YSQUNEW)=N
90 . S ^TMP($J,"YSM","O",N)=YSQUNEW
91 . S DA=YSQUNEW,DIK="^YTT(601.72," D IX^DIK ;xref questions
92 . S N1=0 F S N1=$O(^YTT(601.76,"AD",YSOLDNUM,N,N1)) Q:N1'>0 D
93 ..S N3=$$NEW^YTQLIB(601.76)
94 .. S ^YTT(601.76,N3,0)=^YTT(601.76,N1,0)
95 .. S $P(^YTT(601.76,N3,0),U)=N3
96 .. S $P(^YTT(601.76,N3,0),U,2)=YSNEWNUM
97 .. S DA=N3,DIK="^YTT(601.76," D IX^DIK
98 Q
99INTRO ;set intros
100 S N=0 F S N=$O(^TMP($J,"YSM","N",N)) Q:N'>0 D
101 . S YSOLDI=$P($G(^YTT(601.72,N,2)),U)
102 . Q:YSOLDI'?1N.N
103 . S YSNEWI=$$NEW^YTQLIB(601.73)
104 . S %X="^YTT(601.73,"_YSOLDI_","
105 . S %Y="^YTT(601.72,"_YSNEWI_","
106 . D %XY^%RCR
107 . S $P(^YTT(601.73,YSNEWI,0),U)=YSNEWI
108 . S DA=YSNEWI,DIK="^YTT(601.73," D IX^DIK
109 . S $P(^YTT(601.72,N,2),U)=YSNEWI
110 Q
111PARSE ;get old name, new name and national
112 S YSOLDNAM=$G(YS("ORIGINAL"))
113 I YSOLDNAM="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad orig",YSERR=1 Q ;-->out
114 I '$D(^YTT(601.71,"B",YSOLDNAM)) S YSDATA(1)="[ERROR]",YSDATA(2)="orig not found",YSERR=1 Q ;-->out
115 S YSNEWNAM=$G(YS("NEW"))
116 I YSNEWNAM="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad new",YSERR=1 Q ;-->out
117 I $D(^YTT(601.71,"B",YSNEWNAM)) S YSDATA(1)="[ERROR]",YSDATA(2)="new already exits",YSERR=1 Q ;-->out
118 I $L(YSNEWNAM)>50!($L(YSNEWNAM)<3)!'(YSNEWNAM'?1P.E) S YSDATA(1)="[ERROR]",YSDATA(2)="new out out bounds",YSERR=1 Q ;-->out
119 S YSNAT=$G(YS("NATIONAL"),0)
120 K YSPROG S:YSNAT=1&($D(^XUSEC("YSPROG",DUZ))) YSPROG=1
121 Q
Note: See TracBrowser for help on using the repository browser.