source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTQAPI3.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1YTQAPI3 ;ASF/ALB MHQ REMOTE PROCEEDURES CONT ; 4/3/07 11:53am
2 ;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 48
3 Q
4SCALEG(YSDATA,YS) ;returns all scale groups for an instrument
5 ;input CODE
6 ; output:SCALE NAME^ABBREVIATION^SCALE IEN^SCALE SEQUENCE^SCALE GROUP NAME^SCALE GRUOP IEN^GROUP SEQUENCE^ORD TITLE^MIN^INCREASE^MAX^GRID1^GRID2^GRID3
7 ;
8 N N,N1,G1,S1,G6,G7,YSCALEN,YSCN,YSCODE,YSGIEN,YSGN
9 K ^TMP($J,"YSG") S YSDATA=$NA(^TMP($J,"YSG"))
10 S YSCODE=$G(YS("CODE"))
11 I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP($J,"YSG",1)="[ERROR]",^TMP($J,"YSG",2)="BAD CODE" Q ;-->out
12 S ^TMP($J,"YSG",1)="[DATA]",N=1,S1=0,G1=0
13 S YSCN=$O(^YTT(601.71,"B",YSCODE,0))
14 S YSGN=0 F S YSGN=$O(^YTT(601.86,"AC",YSCN,YSGN)) Q:YSGN'>0 D
15 . S YSGIEN=0 F S YSGIEN=$O(^YTT(601.86,"AC",YSCN,YSGN,YSGIEN)) Q:YSGIEN'>0 D
16 .. S N=N+1,G1=G1+1,^TMP($J,"YSG",N)="Group"_G1_"="_YSGIEN_U_$$GET1^DIQ(601.86,YSGIEN_",",1)_U_$P($G(^YTT(601.86,YSGIEN,0)),U,3,99)
17 .. S N1=0 F S N1=$O(^YTT(601.87,"AC",YSGIEN,N1)) Q:N1'>0 D
18 ... S YSCALEN=0 F S YSCALEN=$O(^YTT(601.87,"AC",YSGIEN,N1,YSCALEN)) Q:YSCALEN'>0 D
19 .... S N=N+1,S1=S1+1,^TMP($J,"YSG",N)="Scale"_S1_"="_$G(^YTT(601.87,YSCALEN,0))
20 Q
21BATTC(YSDATA,YS) ;battery content
22 ; OUTPUT: BATTERY NAME ^ INSTRUMENT list sorted by BATTERY & SEQUENCE
23 N N,N1,G7,YSBATS,YSBID,YSCONID,YSNAME,YSUB,YS1,YSBNAME
24 S N=1,YSDATA(1)="[DATA]"
25 S YSUB=0 F S YSUB=$O(^YTT(601.781,"AC",DUZ,YSUB)) Q:YSUB'>0 D
26 . S YSBID=$P(^YTT(601.781,YSUB,0),U,3)
27 . S YSBNAME=$P($G(^YTT(601.77,YSBID,0)),U,2)
28 . S:$L(YSBNAME) YS1(YSBNAME)=YSBID
29 S YSNAME="" F S YSNAME=$O(YS1(YSNAME)) Q:YSNAME="" S YSBID=YS1(YSNAME) D
30 . S YSBATS=0 F S YSBATS=$O(^YTT(601.78,"AC",YSBID,YSBATS)) Q:YSBATS'>0 D
31 .. S YSCONID=$O(^YTT(601.78,"AC",YSBID,YSBATS,0))
32 ..S G7=$G(^YTT(601.78,YSCONID,0))
33 .. S N=N+1,YSDATA(N)=$P(G7,U,2)_U_$P(^YTT(601.77,YSBID,0),U,2)_U_$P(G7,U,3,4)_U_$$GET1^DIQ(601.78,YSCONID_",",3)
34 Q
35FIRSTWP(YSDATA,YS) ;first line of all intros
36 ;returns the first line only of a WP field
37 ;Input: FILEN(file number), FIELD (WP filed #)
38 ;Ouput IEN^WP Text line 1
39 N N,YSN,YSFILEN,YSFIELD
40 S YSDATA=$NA(^TMP($J,"YSFWP")) K ^TMP($J,"YSFWP")
41 S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S ^TMP($J,"YSFWP",1)="[ERROR]",^TMP($J,"YSFWP",2)="BAD FILE N" Q ;--->out
42 S YSFIELD=$G(YS("FIELD"),0) S N=$$VFIELD^DILFD(YSFILEN,YSFIELD) I N<1 S ^TMP($J,"YSFWP",1)="[ERROR]",^TMP($J,"YSFWP",2)="BAD field" Q ;--> out
43 S YSN=0,N=1,^TMP($J,"YSFWP",1)="[DATA]"
44 F S YSN=$O(^YTT(YSFILEN,YSN)) Q:YSN'>0 D
45 . S N=N+1
46 . S ^TMP($J,"YSFWP",N)=YSN_U_$G(^YTT(YSFILEN,YSN,YSFIELD,1,0))
47 Q
48QUESTALL(YSDATA,YS) ;all questions for a test
49 ;input: CODE as test name
50 ;output: Field^Value
51 N YSTESTN,YSTEST,YSF,YSV,N,N2,N3,YSEQX,YSIC,YSQN,G
52 S YSDATA=$NA(^TMP($J,"YSQU")) K ^TMP($J,"YSQU")
53 S YSTEST=$G(YS("CODE"))
54 S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0))
55 I YSTESTN'>0 S ^TMP($J,"YSQU",1)="[ERROR]",^TMP($J,"YSQU",2)="bad code" Q ;-->out
56 S N=2,N3=0,^TMP($J,"YSQU",1)="[DATA]"
57 ;
58 S YSEQX=0
59 F S YSEQX=$O(^YTT(601.76,"AD",YSTESTN,YSEQX)) Q:YSEQX'>0 D
60 . 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
61 S ^TMP($J,"YSQU",2)="NUMBER OF QUESTIONS="_N3
62 Q
63QUEST2 ;
64 S N=N+1,N3=N3+1
65 S ^TMP($J,"YSQU",N)="QUESTION NUMBER"_N3_"="_YSQN_U_$P(^YTT(601.76,YSIC,0),U,3)_U_$P(^YTT(601.76,YSIC,0),U,5)_U_YSIC
66 S N2=0 F S N2=$O(^YTT(601.72,YSQN,1,N2)) Q:N2'>0 S N=N+1,^TMP($J,"YSQU",N)=$S(N2=1:"QUESTION TEXT"_N3_"=",1:"")_$G(^YTT(601.72,YSQN,1,N2,0))
67 S N=N+1,G=$G(^YTT(601.72,YSQN,2))
68 S ^TMP($J,"YSQU",N)="INTRO TEXT"_N3_"="_$S(+G>0:+G,1:"")_U D:+G
69 . S N2=0 F S N2=$O(^YTT(601.73,+G,1,N2)) Q:N2'>0 S:N2>1 N=N+1 S ^TMP($J,"YSQU",N)=$G(^TMP($J,"YSQU",N))_$G(^YTT(601.73,+G,1,N2,0))
70 S N=N+1
71 S ^TMP($J,"YSQU",N)="DESC"_N3_"="_$P($G(^YTT(601.74,+$P(G,U,2),0)),U,2)_U_$P(G,U,3)_U_$P(G,U,4)_U_$P(G,U,5)_U_$P(G,U,6)_U_$P(G,U,7)_U
72 S G=+$P(G,U,3),G=$O(^YTT(601.89,"B",G,0)) S:G>0 ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$P(^YTT(601.89,G,0),U,2)
73 S G=^YTT(601.76,YSIC,0)
74 S N=N+1
75 S ^TMP($J,"YSQU",N)="QDISPLAY"_N3_"=" S:$P(G,U,6)?1N.N ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$$DISPEXT^YTQAPI5($P(G,U,6))
76 S N=N+1
77 S ^TMP($J,"YSQU",N)="IDISPLAY"_N3_"=" S:$P(G,U,7)?1N.N ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$$DISPEXT^YTQAPI5($P(G,U,7))
78 S N=N+1
79 S ^TMP($J,"YSQU",N)="CDISPLAY"_N3_"=" S:$P(G,U,8)?1N.N ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$$DISPEXT^YTQAPI5($P(G,U,8))
80 Q
81PURGE(YSDATA,YS) ; delete a record
82 ;input: FILEN (FILE #)
83 ; IEN (internal record #)
84 ;Output :only conformation
85 N YSFILEN,YSROOT,YSNODE,DIK,DA
86 S DA=$G(YS("IEN"),0)
87 S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S YSDATA(1)="[ERROR]",YSDATA(2)="BAD FILE N" Q ;--->out
88 S YSROOT=$$ROOT^DILFD(YSFILEN)
89 S YSNODE=YSROOT_DA_",0)"
90 I $D(@YSNODE)'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="no such record" Q ;-->out
91 S DIK=YSROOT D ^DIK
92 S YSDATA(1)="[DATA]",YSDATA(2)="record "_DA_" of "_YSFILEN_" deleted"
93 Q
Note: See TracBrowser for help on using the repository browser.