source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTQAPI9.m@ 1582

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

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1YTQAPI9 ;ALB/ASF- MHA ENTRIES ; 7/23/07 12:47pm
2 ;;5.01;MENTAL HEALTH;**85**;Dec 30, 1994;Build 49
3 Q
4LEGCR(YSDATA,YS) ;score/report for cr dll
5 ;input: YS("ADATE")=date of admin
6 ; YS("DFN") as pt ien
7 ; YS("CODE") as test name
8 ; YS("R1") as first 200 legacy codes in a string
9 ; YS("R2") as 201-400
10 N DA,DIK,DFN,YSNCODE,YSCODE,YSADATE,YSJ,YSDFN,VA,VADM,YSDT,YSE,YSEND,YSLIMIT,YSN,YSS,YSSCALE,VAERR,Y,R1,R2,R3,N,J,YSAGE,YSDOB,YSG,YSHDR,YSNM,YSSEX,YSSSN,VADM,YSQQ,YSC1
11 K ^TMP($J,"YTAPI4")
12 D PARSE^YTAPI(.YS)
13 I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="no such pt" Q
14 I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="INCORRECT TEST CODE" Q ;---> bad code
15 S YSNCODE=$O(^YTT(601,"B",YSCODE,-1))
16 I YSADATE'=DT S YSDATA(1)="[ERROR]",YSDATA(2)="bad date needs DT" Q ;---> bad date
17 L +^YTD(601.2,DFN,1,YSNCODE,1,YSADATE):1 I '$T S YSDATA(1)="[ERROR]",YSDATA(2)="no lock" Q ;--->
18 D:$D(^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)) INTMP ;save old testing for a day
19 ;
20 D SAVEIT^YTAPI1(.YSDATA,.YS) ; save responses
21 ;I YSDATA(1)?1"[ERROR".E L -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE) Q ;---> bad save
22 ;
23 S YSCODEN=$O(^YTT(601.71,"B",YSCODE,0))
24 D SCALES^YTQPXRM5(.YSQQ,YSCODEN)
25 S N2=0 F S N2=$O(YSQQ("S",N2)) Q:N2'>0 D
26 . S YSCALE1=YSQQ("S",N2)
27 . S YSC1($$UCASE^YTQPXRM6(YSCALE1),N2)=""
28 K YSQQ
29 ;D SCOREIT^YTAPI2(.YSDATA,.YS)
30 D SCOREIT^YTQAPI14(.YSDATA,.YS)
31 ;scale listing
32 S N2=5 F S N2=$O(YSDATA(N2)) Q:N2'>0 D
33 . S YSG1=YSDATA(N2),YSCALE1=$P(YSG1,U,2),YSRT=$P(YSG1,U,3,4)
34 . S YSRTI=$O(YSC1($$UCASE^YTQPXRM6(YSCALE1),0))
35 . S:YSRTI'="" YSDATA(N2)=$P(YSG1,U)_U_YSCALE1_U_YSRTI_U_YSRT
36 D INTRMNT^YTRPWRP(.YSDATA,DFN,YSADATE_","_YSNCODE)
37 D DEM^VADPT,PID^VADPT S YSNM=VADM(1),YSSEX=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN=VA("PID")
38 S $P(YSHDR," ",60)="",YSHDR=YSSSN_" "_YSNM_YSHDR,YSHDR=$E(YSHDR,1,44)_YSSEX_" AGE "_YSAGE
39AA S YSJ=$O(YSDATA(999),-1)
40 S YSDATA(YSJ+1)="^^PROGRESS NOTE^^"
41 S N=3,J=1 F S N=$O(^TMP("YSDATA",$J,1,N)) Q:N'>0 D
42 . S YSG=^TMP("YSDATA",$J,1,N)
43 . Q:YSG]YSHDR
44 . Q:YSG?1"Not valid unless signed: Reviewed by".E
45 . Q:YSG?1"Printed by: ".E
46 . Q:YSG?." "1"PRINTED ENTERED"." "
47 . Q:YSG?1"Ordered by: ".E
48 . S J=J+1,YSDATA(YSJ+J)=YSG
49DROP ;kill preview data
50 S DIK="^YTD(601.2,DFN,1,YSNCODE,1,",DA=YSADATE,DA(1)=YSNCODE,DA(2)=DFN D ^DIK
51 ;
52 D:$D(^TMP($J,"YTAPI4")) OUTTMP ;place back old testing
53 S DIK="^YTD(601.2,",DA=DFN D IX^DIK ; reindex
54 L -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
55 K YSQQ Q
56INTMP ; SAVE OLD
57 M ^TMP($J,"YTAPI4")=^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
58 Q
59OUTTMP ;replace old testing
60 M ^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)=^TMP($J,"YTAPI4")
61 Q
62NATSET(YSDATA,YS) ; set design evironment to save fm entries <100,000
63 ;input: NATIONAL as Yes or No
64 ;output: YSPROG=1
65 N Y1
66 I '$D(^XUSEC("YSPROG",DUZ)) S YSDATA(1)="[ERROR]",YSDATA(2)="no prog key" Q ;-->out
67 S Y1=$G(YS("NATIONAL"))
68 S Y1=$E(Y1,1)
69 I (Y1'="Y")&(Y1'="N") S YSDATA(1)="[ERROR]",YSDATA(2)="no/BAD setting"
70 S YSDATA(1)="[DATA]"
71 I Y1="N" K YSPROG S YSDATA(2)="local editing set"
72 I Y1="Y" S YSPROG=1,YSDATA(2)="national editing set"
73 Q
74PATSEL(YSDATA,YS) ;patient component
75 ;input DFN as ien of file 2
76 ;output
77 ; YSDATA(2)= name
78 ; YSDATA(3)=ssn
79 ; YSDATA(4)=dob
80 ; YSDATA(5)=age
81 ; YSDATA(6)=sex
82 ; YSDATA(7)=date of death (or 0)
83 ; YSDATA(8)=0 NCS/ 1 SC^%^service connected
84 N DFN,VADM,VAEL,VAERR
85 S DFN=$G(YS("DFN"),-1)
86 I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad dfn" Q ;-->out
87 D 2^VADPT
88 I VAERR=1 S YSDATA(1)="[ERROR]",YSDATA(2)="vadpt err" Q ;-->out
89 S YSDATA(1)="[DATA]"
90 S YSDATA(2)=VADM(1)_U_"name"
91 S YSDATA(3)=VADM(2)_U_"ssn"
92 S YSDATA(4)=VADM(3)_U_"dob"
93 S YSDATA(5)=VADM(4)_U_"age"
94 S YSDATA(6)=VADM(5)_U_"sex"
95 S YSDATA(7)=+VADM(6)_U_$P(VADM(6),U,2)_U_"date of death"
96 S YSDATA(8)=VAEL(3)_U_"service connected"
97 Q
98USERQ(YSDATA,YS) ;user info
99 ;input DUZ as internal ien file 200 for user to check [optional default is current user]
100 ; KEY as name of security key to check [optional]
101 ;output YSDATA(2)= name of user
102 ; YSDATA(3) if key sent 1^holds VS 0^lacks KEY
103 N YSKEY,YSDUZ,K
104 S YSDUZ=$G(YS("DUZ"),DUZ)
105 S YSKEY=$G(YS("KEY"),-1)
106 S YSDATA(1)="[DATA]"
107 D OWNSKEY^XUSRB(.K,YSKEY,YSDUZ)
108 S YSDATA(2)=$P($G(^VA(200,YSDUZ,0)),U)_U_YSDUZ
109 I YSKEY=-1 S YSDATA(3)=""
110 E S YSDATA(3)=$S(K(0):"1^holds ",1:"0^lacks ")_YSKEY
111 S YSDATA(4)=$$SITE^VASITE_U_$$NAME^VASITE(DT)
112 Q
113MHREPORT(YSDATA,YS) ;gets a report format from 601.93
114 ;Input: CODE as instrument name
115 ;Output: LINE# ^ line text
116 N N,N1,YSIENS,YSCODE,YSCODEN,YSIENS
117 K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
118 S ^TMP("YSDATA",$J,1)="[ERROR]"
119 S YSCODE=$G(YS("CODE"),0)
120 I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP("YSDATA",$J,2)="bad code" Q ;-->out
121 S YSCODEN=$O(^YTT(601.71,"B",YSCODE,-1))
122 S YSIENS=$O(^YTT(601.93,"C",YSCODEN,-1))
123 I YSIENS'>0 S ^TMP("YSDATA",$J,1)="[DATA]^0" Q ;--> out
124 S N=1,N1=0 F S N1=$O(^YTT(601.93,YSIENS,1,N1)) Q:N1'>0 D
125 . S N=N+1,^TMP("YSDATA",$J,N)=$G(^YTT(601.93,YSIENS,1,N1,0))
126 S ^TMP("YSDATA",$J,1)="[DATA]"_U_YSIENS
127 Q
Note: See TracBrowser for help on using the repository browser.