source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTQPXRM3.m@ 1800

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

initial load of WorldVistAEHR
File size: 3.8 KB
Line 
1YTQPXRM3 ;ASF/ALB MHQ REMOTE PROCEDURES CONT ; 5/7/07 10:44am
2 ;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 49
3 ;
4 Q
5QUESTALL(YSDATA,YS) ;all questions for a test
6 ;input: CODE as test name
7 ;output: Field^Value
8 N YSTESTN,YSTEST,YSF,YSV,N,N2,N3,YSEQX,YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,YSQNUMB
9 S YSDATA=$NA(^TMP($J,"YSQU")) K ^TMP($J,"YSQU")
10 S YSCODE=$G(YS("CODE"),0)
11 S YSTESTN=$O(^YTT(601.71,"B",YSCODE,0))
12 I YSTESTN'>0 S ^TMP($J,"YSQU",1)="[ERROR]",^TMP($J,"YSQU",2)="bad code" Q ;-->out
13 S YSQNUMB=0
14 S ^TMP($J,"YSQU",1)="[DATA]"
15 ;
16 S YSEQX=0
17 F S YSEQX=$O(^YTT(601.76,"AD",YSTESTN,YSEQX)) Q:YSEQX'>0 D
18 . 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
19 S ^TMP($J,"YSQU",2)=YSCODE_U_"NUMBER OF QUESTIONS="_YSQNUMB
20 ;now check Ok for clinical reminders
21 D CHECKME
22 Q
23QUEST2 ;
24 S YSQNUMB=YSQNUMB+1
25 S ^TMP($J,"YSQU","YSCROSS",YSQNUMB)=YSQN
26 ;text
27 S N2=0 F S N2=$O(^YTT(601.72,YSQN,1,N2)) Q:N2'>0 S ^TMP($J,"YSQU",YSQNUMB,"T",N2)=$P($G(^YTT(601.72,YSQN,1,N2,0)),U)
28 ;intro
29 S G=+$G(^YTT(601.72,YSQN,2))
30 S N2=0 F S N2=$O(^YTT(601.73,G,1,N2)) Q:N2'>0 S ^TMP($J,"YSQU",YSQNUMB,"I",N2)=$P($G(^YTT(601.73,+G,1,N2,0)),U)
31 ;responses
32 S YSLN=0
33 ;S ^TMP($J,"YSQU",YSQNUMB,"R",0)="X"
34 S YSCHOT=$P($G(^YTT(601.72,YSQN,2)),U,3)
35 Q:YSCHOT'>0
36 S N2=0 F S N2=$O(^YTT(601.751,"AC",YSCHOT,N2)) Q:N2'>0 D
37 . S YSCHOICE=$O(^YTT(601.751,"AC",YSCHOT,N2,0))
38 . Q:YSCHOICE'>0
39 . Q:$P(^YTT(601.75,YSCHOICE,0),U,2)=""
40 . ;Q:($P(^YTT(601.75,YSCHOICE,0),U,2)="")
41 . S YSLN=YSLN+1
42 . S ^TMP($J,"YSQU",YSQNUMB,"R",YSLN)=$P($G(^YTT(601.75,YSCHOICE,1)),U)
43 . S ^TMP($J,"YSQU",YSQNUMB,"R",0)=$G(^TMP($J,"YSQU",YSQNUMB,"R",0))_$P($G(^YTT(601.75,YSCHOICE,0)),U,2)
44 . S ^TMP($J,"YSQU","YSCA",YSQN,$P(^YTT(601.75,YSCHOICE,0),U,2))=YSCHOICE
45 Q
46CHECKME ;cr checker
47 S YSERR=0
48 I YSQNUMB>200 D CLEAN(YSQNUMB_" is too many questions") Q ;-->out
49 S N2=0 F S N2=$O(^TMP($J,"YSQU",N2)) Q:N2'>0!YSERR D
50 . S YSLEGA=$G(^TMP($J,"YSQU",N2,"R",0))
51 . D:YSLEGA="X" CLEAN(N2_" no legacy") Q ;--out
52 . S YSRR=$O(^TMP($J,"YSQU",YSQNUMB,"R",9999),-1)
53 . D:YSRR'=($L(YSLEGA)-1) CLEAN(N2_" not all legacy")
54 Q
55CLEAN(X) ;
56 K ^TMP($J,"YSQU")
57 S ^TMP($J,"YSQU",1)="[ERROR]"
58 S ^TMP($J,"YSQU",2)=X
59 Q
60OLDNEW(YSCODEN,YSOLDNUM) ;
61 ;input YSCODEN ien OF 601.71
62 ; YSOLDNUM as ien of "S" MULT of 601 (1= DEFAULT)
63 ;output ien OF 601.87, 0=ERROR
64 ;
65 N N2,YSQQ,YSNAME,YS601,YSOLDNAM,YSNEWN,YSCALE1,YSC1
66 IF $G(YSOLDNUM)="" S YSOLDNUM=1
67 S YSOUT=0
68 I '$D(^YTT(601.71,YSCODEN,0)) Q YSOUT ;->out
69 S YSNAME=$P(^YTT(601.71,YSCODEN,0),U)
70 S YS601=$O(^YTT(601,"B",YSNAME,0)) Q:YS601'>0 YSOUT ;-->out
71 I '$D(^YTT(601,YS601,"S",YSOLDNUM,0)) Q YSOUT ;-->out
72 S YSOLDNAM=$P(^YTT(601,YS601,"S",YSOLDNUM,0),U,2)
73 D SCALES^YTQPXRM5(.YSQQ,YSCODEN)
74 S N2=0 F S N2=$O(YSQQ("S",N2)) Q:N2'>0 D
75 . S YSCALE1=YSQQ("S",N2)
76 . S YSC1($$UCASE^YTQPXRM6(YSCALE1),N2)=""
77 S YSNEWN=$O(YSC1($$UCASE^YTQPXRM6(YSOLDNAM),0))
78 S:YSNEWN>0 YSOUT=YSNEWN
79 Q YSOUT
80NEWOLD(YSCODEN,YSNEW) ;
81 ;input YSCODEN ien OF 601.71
82 ; YSNEW ien OF 601.87, 0=ERROR
83 ;output YSOLD as ien of "S" MULT of 601 (1= DEFAULT)
84 ;
85 N N2,YSX,YSQQ,YSNAME,YS601,YSOLDNAM,YSNEWN,YSON,YSOLDN,YSCNEW
86 IF YSNEW="" S YSNEW=1
87 S YSOUT=0
88 I '$D(^YTT(601.71,YSCODEN,0)) Q YSOUT ;->out
89 S YSNAME=$P(^YTT(601.71,YSCODEN,0),U)
90 S YS601=$O(^YTT(601,"B",YSNAME,0)) Q:YS601'>0 YSOUT ;-->out
91 I '$D(^YTT(601.87,YSNEW)) Q YSOUT ;-->out
92 S YSCNEW=$P(^YTT(601.87,YSNEW,0),U,4)
93 S N=0 F S N=$O(^YTT(601,YS601,"S",N)) Q:N'>0 D
94 . S YSON=$P(^YTT(601,YS601,"S",N,0),U,2)
95 . S YSX($$UCASE^YTQPXRM6(YSON),N)=""
96 S YSOLDN=$O(YSX($$UCASE^YTQPXRM6(YSCNEW),0))
97 S:YSOLDN>0 YSOUT=YSOLDN
98 Q YSOUT
99RL(YSCODEN) ;requires license
100 ;input YSCODEN ien OF 601.71
101 ;output Y/N/0
102 ;
103 N X
104 S YSOUT=0
105 I '$D(^YTT(601.71,YSCODEN,0)) Q YSOUT ;->out
106 S X=$$GET1^DIQ(601.71,YSCODEN_",",11,"I")
107 S YSOUT=$S(X="Y":"Y",X="N":"N",1:0)
108 Q YSOUT
Note: See TracBrowser for help on using the repository browser.