source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSHX1.m@ 1005

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1YSHX1 ;SLC/DKG-HISTORY OF PRESENT ILLNESS ;4/20/92 09:25 ;08/12/93 17:41
2 ;;5.01;MENTAL HEALTH;**9**;Dec 30, 1994
3 ;
4 ; Called from the top by MENU option YSHX1
5 ;
6 S YSHX="HX",P=","
71 ;
8 W ! D ^YSLRP G:YSDFN<1 END S YSDT=DT W @IOF,!!?3,"HISTORY PART ONE FOR ",YSNM," ",YSSEX," AGE ",YSAGE,!!
9FN ;
10 D DTS G END:YSTOUT!YSUOUT K ^UTILITY($J,"W")
11EL ;
12 W !!?3,"(E)nter" W:'YSNH "/Edit, (P)rint" R " OR (Q)uit: E// ",A1:DTIME S YSTOUT='$T,YSUOUT=A1["^" S:A1="" A1="E" S A1=$TR($E(A1),"epq","EPQ")
13 G END:YSTOUT!YSUOUT,ENT:A1="E",^YSHX1R:A1="P"&'YSNH,1:A1="Q",ELQ
14ENT ;
15 S YSIDT=9999999-YSDT,YSCD=1,^PTX(YSDFN,YSHX,YSIDT,1,DUZ,1,YSCD,1,0)="",DIC="^PTX(YSDFN,YSHX,YSIDT,1,DUZ,1,YSCD,1,"
16 N DIWESUB S DIWESUB="Chief Complaint",DIWEPSE=1
17 W !!,"CHIEF COMPLAINT: "
18 D ENDTM^YSUTL S DWPK=1 D EN^DIWE
19 I '($D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,1,YSCD,1,1,0))#2) K ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,1,YSCD,1,0) G HS
20 L +^PTX(YSDFN) S ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,0)=DUZ,^(1,0)="^99.07D^1^1" S:'$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,1,YSCD,0)) ^(0)=YSDTM L -^PTX(YSDFN)
21HS ;
22 S ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,1,0)="",DIC="^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,1,"
23 S DIWESUB="Hx of Present Illness",DIWEPSE=1
24 W !!,"HISTORY OF PRESENT ILLNESS: "
25 D ENDTM^YSUTL S DWPK=1 D EN^DIWE
26 I '($D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,1,1,0))#2) K ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,1,0) G MD
27 L +^PTX(YSDFN) S:'$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,0)) ^(0)=DUZ S ^(2,0)="^99.09D^1^1" S:'$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,0)) ^(0)=YSDTM L -^PTX(YSDFN)
28MD ;
29 S ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,1,0)="",DIC="^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,1,"
30 S DIWESUB="Current Meds & Source",DIWEPSE=1
31 W !!,"CURRENT MEDS AND SOURCE: "
32 D ENDTM^YSUTL S DWPK=1 D EN^DIWE
33 I '($D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,1,1,0))#2) K ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,1,0) G DC
34 L +^PTX(YSDFN) S:'$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,0)) ^(0)=DUZ S ^(3,0)="^99.11D^1^1" S:'$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,0)) ^(0)=YSDTM L -^PTX(YSDFN)
35DC ;
36 I '$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,1,YSCD,1,1,0))&('$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,1,1,0)))&('$D(^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,1,1,0))) K ^PTX(YSDFN,YSHX,YSIDT,1,DUZ)
37 I '$O(^PTX(+YSDFN,YSHX,YSIDT,1,0)) L +^PTX(+YSDFN) K ^PTX(+YSDFN,YSHX,YSIDT) L -^PTX(+YSDFN) G END:$G(X)["^",1
38 I '$D(^PTX(YSDFN,0)) L +^PTX(+YSDFN) S ^PTX(YSDFN,0)=YSDFN,^PTX("B",YSDFN,YSDFN)="" L -^PTX(YSDFN)
39 L +^PTX(0) S YSTN=$P(^PTX(0),U,4)+1,L=$P(^PTX(0),U,3)
40 S L=$S(YSDFN>L:YSDFN,1:L),^PTX(0)=$P(^PTX(0),U,1,2)_U_L_U_YSTN L -^PTX(0) K L,YSTN
41 L +^PTX(YSDFN)
42 I $D(^PTX(YSDFN,YSHX,0)) S YSNU=$P(^(0),U,4)+1,^(0)=$P(^(0),U,1,3)_U_YSNU K YSNU
43 E S ^(0)="^99.05D^"_YSIDT_"^1"
44 S:'$D(^PTX(YSDFN,YSHX,YSIDT,0)) ^(0)=DT
45 I $D(^PTX(YSDFN,YSHX,YSIDT,1,0)) S YSUR=$P(^(0),U,3),YSUR=$S(DUZ>YSUR:DUZ,1:YSUR),YSNU=$P(^(0),U,4)+1,^(0)=$P(^(0),U,1,2)_U_YSUR_U_YSNU K YSUR,YSNU
46 E S ^(0)="^99.06P^"_DUZ_"^1"
47 L -^PTX(YSDFN) G END:$G(X)="^",1
48END ; Called by routine YSHX1R
49 I $G(YSTOUT),IOST?1"C-".E W:IOF]"" @IOF
50 K %,%DT,A,A1,B4,C,D,DIC,DIW,DIWEPSE,DIWF,DIWL,DIWR,DIWT,DN,YSDT(0),YSDT(1),DW2,DWI,DXS,I,I0,IO("Q"),J,K,M,P,X,X1,Y,YSAGE,YSCD,YSCON,YSDFN,YSDOB,YSDTM,YSFTR,YSHD,YSFHDR,YSHR,YSHX,YSIDT
51 K YSLFT,YSMN,YSNM,YSNH,YSP0,YSPF,YSPT,YSPTD,YSSEX,YSSL,YSSSN,YSTM,YSTOUT,YSUOUT,YSUS,YSUSN,YSUSER,YSUTL,YSYD,Z,ZTSK Q
52DTS ;
53 S (YSTOUT,YSUOUT)=0 I '$D(^PTX(YSDFN,"HX")) S YSNH=1 W $C(7),!!?3,"NO HX1'S ON FILE",!! Q
54 S (YSNH,K,YSIDT)=0 K A W !!?10,"PREVIOUS HX1'S",!
55YSIDT ;
56 S YSIDT=$O(^PTX(YSDFN,YSHX,YSIDT)) G:'YSIDT SEL S K=K+1,YSHD=9999999-YSIDT,(Y,A(K))=YSHD
57 D ENDD^YSUTL W !?8,$J(K,3)," ",Y G YSIDT
58SEL ;
59 I K>1 G SL1
60 I K=1 W !?10,Y R " OK? Y// ",AA:DTIME S YSTOUT='$T,YSUOUT=AA["^"
61 G END:YSTOUT Q:YSUOUT
62 S AA=$TR(AA,"yn","YN") S:AA="" AA="Y" G:AA="?" SELQ1 G:AA["??" SELQ2 S AA=$E(AA) I AA="Y" S YSDT=A(K) Q
63 I K=1 S:"N"[AA YSNH=1 Q
64 I K=1 W:AA'["?" " ?",$C(7) G SELQ1
65SL1 ;
66 W !!?3,"Select HX1 NUMBER: " R AB:DTIME S YSOUT='$T,YSUOUT=AB["^" I YSTOUT G END
67 Q:YSUOUT!(AB']"") G:AB["?" SL1Q I AB<1!(AB>K) G SL1
68 S YSDT=A(AB) Q
69SELQ1 ;
70 W !!,"""YES"" = edit. ""N"" = new. Only one HX1 per day.",! K AA G SEL
71SELQ2 ;
72 W !!,"""YES"" permits altering of previously entered information.",!,"""NO"" allows the addition of a new history - only 1 per day.",! K AA G SEL
73SL1Q ;
74 W !!,"Enter number of HX1 you wish to edit OR a "" to enter a new HX1.",!,"Only one HX1 may be entered per day.",! G SL1
75ELQ ;
76 W !!,"""E"" permits altering or addition of new HX1.",!,"""P"" produces a report.",!,"""Q"" exits option.",! G EL
Note: See TracBrowser for help on using the repository browser.