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

YSPHY ;SLC/RWF,SLC/DKG-PHYSICAL EXAM / MENTAL HEALTH ;11/19/90  16:43 ;
 ;;5.01;MENTAL HEALTH;**12,14**;Dec 30, 1994
 ;
 ;If YSEDIT=1, new exam.  If YSEDIT=0, editing previous exam.
 ;
 ; Called from the top by MENU option YSPHYEXAM
 ;
1 ;
 D ^YSLRP G:YSDFN<1 END^YSPHY1 S YSPE="PE",P=",",YSTIME=0
 S YSYDT=DT W !!?3,"Physical Exam for ",YSNM,"   ",YSSEX,"   Age ",YSAGE,!!
 D DTS Q:YSUOUT  I YSTOUT G END^YSPHY1
EL ;
 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
 Q:YSUOUT!(A="Q")
 G IN:"E"[A,LIST:"P"[A W:A'["?" $C(7)," ?" D:A["?" HLP1^YSPHY1 G EL
IN ;
 D CHK1^YSPHY1 I $D(YSUOUT),YSUOUT=1 D END^YSPHY1 Q
 S YSIDT=9999999-YSYDT
EN ;
 L +^MR(YSDFN)
 S DIE="^MR(YSDFN,YSPE,",DA(1)=YSDFN,DA=YSIDT S:'$D(^MR(YSDFN,YSPE,0)) ^(0)="^90.01D^^0",YSEDIT=1
 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
 S:'$D(^MR(YSDFN,YSPE,YSIDT,0)) ^(0)=YSYDT,^MR(YSDFN,YSPE,"B",YSYDT,YSIDT)="",^MR("B",YSDFN,YSDFN)="",^MR(YSDFN,0)=YSDFN
 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)
EN1 ;
 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
 I YSTOUT G END^YSPHY1
 I "Ee"[$E(X) S DR="29//"_$P(^VA(200,DUZ,0),U)_";.02:.07;.9" G EN2
 I "Mm"[$E(X) S DR="29//"_$P(^VA(200,DUZ,0),U)_";32:34;.05:.07;.9" G EN2
 I "Bb"[$E(X) S DR="29//"_$P(^VA(200,DUZ,0),U)_";.02;32;.03;33;.04;34;.05:.07;.9" G EN2
 W:X'["?" " ?",$C(7) W !?4,"Specify measurement system for height, weight, and temperature." G EN1
EN2 ;
 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
 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^"
 L -^MR(YSDFN)
EN21 ;
 S %=0 F  Q:$G(%)  W !!,"Is the ENTIRE physical exam NORMAL" S %=2 D YN^DICN I '% D
 .S XQH="YS-PHY-EXAM-NORM" D EN^XQH
 S YSTOUT=$D(DTOUT) I YSTOUT G END^YSPHY1
 I %<0 S YSUOUT=%Y="^" D:YSUOUT&(YSEDIT=1) MSG3^YSPHY1 D:YSUOUT&(YSEDIT=0) MSG6^YSPHY1 G END^YSPHY1
 I %=1 G IMP
 S YSDIZ=DIE D YSDIZ^YSPHY1 I X["^" D:YSEDIT=1 MSG3^YSPHY1 D:YSEDIT=0 MSG6^YSPHY1 G END^YSPHY1
IMP ;
 S:'$D(Y) Y=1 ;Biloxi fix relative to Screen Man
 S ^MR(YSDFN,YSPE,YSIDT,20,0)="",DIC="^MR(YSDFN,YSPE,YSIDT,20,",DWPK=1 W !!," Initial Impression: " D EN^DIWE
 S ^MR(YSDFN,YSPE,YSIDT,19,0)="",DIC="^MR(YSDFN,YSPE,YSIDT,19,"
IMP1 ;
 W !,"Do you need to enter comments" S %=2 D YN^DICN
 S YSTOUT=$D(DTOUT),YSUOUT=%<0 I YSTOUT!YSUOUT G END^YSPHY1
 I '% W $C(7)," ?" D IMP1
 I %=2 G END^YSPHY1
 W !!," Comments: " S DWPK=1 D EN^DIWE G END^YSPHY1
LIST ;
 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
 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
 G ^YSPHYR
DTS ;
 S (YSNP,YSTOUT,YSUOUT,YSNEW,YSEDIT)=0
 I '$O(^MR(YSDFN,YSPE,0)) D  QUIT
 .  S (YSNP,YSNEW)=1
 .  W $C(7),!!?3,"No Physical Exams on file",!!
 S (YSK,YSIDT,YSLDT)=0 W !!?10,"PREVIOUS PHYSICAL EXAMS",!
YSIDT ;
 S YSIDT=$O(^MR(YSDFN,YSPE,YSIDT))
 G:'YSIDT SEL
 S YSK=YSK+1,YSHD=9999999-YSIDT,(A(+YSK),Y,YSY,YSA(+YSK))=YSHD,YSLDT=YSIDT
 D ENDD^YSUTL S YSY=Y
 W !?8,$J(YSK,3),"  ",YSY
 G YSIDT
SEL ;
 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
 I YSK=1,%=2 D CHK2^YSPHY1 QUIT
 I YSK=1 S YSYDT=YSA(+YSK) K YSA QUIT
SL1 ;
 R !!?3,"Enter EXAM NUMBER to edit or",!?8,"Enter <CR> to create NEW exam: ",YSX:DTIME
 S YSTOUT='$T,YSUOUT=YSX["^" I YSTOUT!(YSUOUT) QUIT
 D:YSX="" CHK2^YSPHY1 QUIT:YSX=""
 S X1=$E(YSX)
 D:X1="?" HLP4^YSPHY1
 I +YSX'=YSX W "  ?? ",$C(7) G SL1
 I '($D(YSA(+YSX))#2) W:YSX'["?" $C(7)," ?" G SL1
 S YSLDT=9999999-YSA(+YSX) S YSYDT=YSA(+YSX) K YSA Q
 Q