source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSPHY.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1YSPHY ;SLC/RWF,SLC/DKG-PHYSICAL EXAM / MENTAL HEALTH ;11/19/90 16:43 ;
2 ;;5.01;MENTAL HEALTH;**12,14**;Dec 30, 1994
3 ;
4 ;If YSEDIT=1, new exam. If YSEDIT=0, editing previous exam.
5 ;
6 ; Called from the top by MENU option YSPHYEXAM
7 ;
81 ;
9 D ^YSLRP G:YSDFN<1 END^YSPHY1 S YSPE="PE",P=",",YSTIME=0
10 S YSYDT=DT W !!?3,"Physical Exam for ",YSNM," ",YSSEX," Age ",YSAGE,!!
11 D DTS Q:YSUOUT I YSTOUT G END^YSPHY1
12EL ;
13 W !!?3 W:YSNEW=1 "(E)nter" W:YSNEW=0 "(E)dit, (P)rint" R " OR (Q)uit: E// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" S:A="" A="E" S A=$TR($E(A),"epq","EPQ") I YSTOUT G END^YSPHY1
14 Q:YSUOUT!(A="Q")
15 G IN:"E"[A,LIST:"P"[A W:A'["?" $C(7)," ?" D:A["?" HLP1^YSPHY1 G EL
16IN ;
17 D CHK1^YSPHY1 I $D(YSUOUT),YSUOUT=1 D END^YSPHY1 Q
18 S YSIDT=9999999-YSYDT
19EN ;
20 L +^MR(YSDFN)
21 S DIE="^MR(YSDFN,YSPE,",DA(1)=YSDFN,DA=YSIDT S:'$D(^MR(YSDFN,YSPE,0)) ^(0)="^90.01D^^0",YSEDIT=1
22 I YSNEW=1 S YSNE=$P(^MR(YSDFN,YSPE,0),U,4)+1,^MR(YSDFN,YSPE,0)=$P(^MR(YSDFN,YSPE,0),U,1,2)_U_YSIDT_U_YSNE K YSNE
23 S:'$D(^MR(YSDFN,YSPE,YSIDT,0)) ^(0)=YSYDT,^MR(YSDFN,YSPE,"B",YSYDT,YSIDT)="",^MR("B",YSDFN,YSDFN)="",^MR(YSDFN,0)=YSDFN
24 S YSHDF=$P(^MR(0),U,3) S:YSDFN>YSHDF YSHDF=YSDFN S:YSEDIT=1 YSNM=$P(^MR(0),U,4)+1 S:YSEDIT=0 YSNM=$P(^MR(0),U,4) S ^MR(0)=$P(^MR(0),U,1,2)_U_YSHDF_U_YSNM K YSHDF,YSNM L -^MR(YSDFN)
25EN1 ;
26 R !!?3,"Enter 'M' for METRIC or 'E' for ENGLISH measurements",!?10," or 'B' for BOTH: E// ",X:DTIME S YSTOUT='$T,YSUOUT=X["^" I YSUOUT D ENCLN^YSPHY1 Q
27 I YSTOUT G END^YSPHY1
28 I "Ee"[$E(X) S DR="29//"_$P(^VA(200,DUZ,0),U)_";.02:.07;.9" G EN2
29 I "Mm"[$E(X) S DR="29//"_$P(^VA(200,DUZ,0),U)_";32:34;.05:.07;.9" G EN2
30 I "Bb"[$E(X) S DR="29//"_$P(^VA(200,DUZ,0),U)_";.02;32;.03;33;.04;34;.05:.07;.9" G EN2
31 W:X'["?" " ?",$C(7) W !?4,"Specify measurement system for height, weight, and temperature." G EN1
32EN2 ;
33 W ! K ^DISV(DUZ,"^VA(200,"),^DISV(DUZ,"^VA(200,") L +^MR(YSDFN) D ^DIE L -^MR(YSDFN) S YSTOUT=$D(DTOUT),YSUOUT=$O(Y(""))]"" I YSTOUT!YSUOUT D ENCLN^YSPHY1 G END^YSPHY1
34 I '$D(^MR(YSDFN,YSPE,YSIDT,.9)) L +^MR(YSDFN) S ^MR(YSDFN,YSPE,YSIDT,.9)="1^1^1^1^1^1^1^1^1^1^1^1^1^1^1^1^1^1^1^"
35 L -^MR(YSDFN)
36EN21 ;
37 S %=0 F Q:$G(%) W !!,"Is the ENTIRE physical exam NORMAL" S %=2 D YN^DICN I '% D
38 .S XQH="YS-PHY-EXAM-NORM" D EN^XQH
39 S YSTOUT=$D(DTOUT) I YSTOUT G END^YSPHY1
40 I %<0 S YSUOUT=%Y="^" D:YSUOUT&(YSEDIT=1) MSG3^YSPHY1 D:YSUOUT&(YSEDIT=0) MSG6^YSPHY1 G END^YSPHY1
41 I %=1 G IMP
42 S YSDIZ=DIE D YSDIZ^YSPHY1 I X["^" D:YSEDIT=1 MSG3^YSPHY1 D:YSEDIT=0 MSG6^YSPHY1 G END^YSPHY1
43IMP ;
44 S:'$D(Y) Y=1 ;Biloxi fix relative to Screen Man
45 S ^MR(YSDFN,YSPE,YSIDT,20,0)="",DIC="^MR(YSDFN,YSPE,YSIDT,20,",DWPK=1 W !!," Initial Impression: " D EN^DIWE
46 S ^MR(YSDFN,YSPE,YSIDT,19,0)="",DIC="^MR(YSDFN,YSPE,YSIDT,19,"
47IMP1 ;
48 W !,"Do you need to enter comments" S %=2 D YN^DICN
49 S YSTOUT=$D(DTOUT),YSUOUT=%<0 I YSTOUT!YSUOUT G END^YSPHY1
50 I '% W $C(7)," ?" D IMP1
51 I %=2 G END^YSPHY1
52 W !!," Comments: " S DWPK=1 D EN^DIWE G END^YSPHY1
53LIST ;
54 G:YSNP END^YSPHY1 S YSIDT=9999999-YSYDT,DA=YSIDT I '$D(^MR(YSDFN,YSPE,DA,0)) S Y=YSYDT D ENDD^YSUTL W $C(7),!!!?3,"No Physical Exam on file for ",Y H 2 D DTS G EL
55 S %ZIS="Q" D ^%ZIS G:POP END^YSPHY1 I $D(IO("Q")) S ZTRTN="^YSPHYR",(ZTSAVE("DA"),ZTSAVE("YS*"))="",ZTDESC="YS PHY EX PRINT" D ^%ZTLOAD G END^YSPHY1
56 G ^YSPHYR
57DTS ;
58 S (YSNP,YSTOUT,YSUOUT,YSNEW,YSEDIT)=0
59 I '$O(^MR(YSDFN,YSPE,0)) D QUIT
60 . S (YSNP,YSNEW)=1
61 . W $C(7),!!?3,"No Physical Exams on file",!!
62 S (YSK,YSIDT,YSLDT)=0 W !!?10,"PREVIOUS PHYSICAL EXAMS",!
63YSIDT ;
64 S YSIDT=$O(^MR(YSDFN,YSPE,YSIDT))
65 G:'YSIDT SEL
66 S YSK=YSK+1,YSHD=9999999-YSIDT,(A(+YSK),Y,YSY,YSA(+YSK))=YSHD,YSLDT=YSIDT
67 D ENDD^YSUTL S YSY=Y
68 W !?8,$J(YSK,3)," ",YSY
69 G YSIDT
70SEL ;
71 I YSK=1 W !?10,YSY," OK" S %=1 D YN^DICN S YSTOUT=$D(DTOUT),YSUOUT=%Y="^" Q:YSTOUT!YSUOUT I '% D HLP2^YSPHY1 G SEL
72 I YSK=1,%=2 D CHK2^YSPHY1 QUIT
73 I YSK=1 S YSYDT=YSA(+YSK) K YSA QUIT
74SL1 ;
75 R !!?3,"Enter EXAM NUMBER to edit or",!?8,"Enter <CR> to create NEW exam: ",YSX:DTIME
76 S YSTOUT='$T,YSUOUT=YSX["^" I YSTOUT!(YSUOUT) QUIT
77 D:YSX="" CHK2^YSPHY1 QUIT:YSX=""
78 S X1=$E(YSX)
79 D:X1="?" HLP4^YSPHY1
80 I +YSX'=YSX W " ?? ",$C(7) G SL1
81 I '($D(YSA(+YSX))#2) W:YSX'["?" $C(7)," ?" G SL1
82 S YSLDT=9999999-YSA(+YSX) S YSYDT=YSA(+YSX) K YSA Q
83 Q
Note: See TracBrowser for help on using the repository browser.