77 lines
4.4 KiB
Mathematica
77 lines
4.4 KiB
Mathematica
YSHX1 ;SLC/DKG-HISTORY OF PRESENT ILLNESS ;4/20/92 09:25 ;08/12/93 17:41
|
|
;;5.01;MENTAL HEALTH;**9**;Dec 30, 1994
|
|
;
|
|
; Called from the top by MENU option YSHX1
|
|
;
|
|
S YSHX="HX",P=","
|
|
1 ;
|
|
W ! D ^YSLRP G:YSDFN<1 END S YSDT=DT W @IOF,!!?3,"HISTORY PART ONE FOR ",YSNM," ",YSSEX," AGE ",YSAGE,!!
|
|
FN ;
|
|
D DTS G END:YSTOUT!YSUOUT K ^UTILITY($J,"W")
|
|
EL ;
|
|
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")
|
|
G END:YSTOUT!YSUOUT,ENT:A1="E",^YSHX1R:A1="P"&'YSNH,1:A1="Q",ELQ
|
|
ENT ;
|
|
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,"
|
|
N DIWESUB S DIWESUB="Chief Complaint",DIWEPSE=1
|
|
W !!,"CHIEF COMPLAINT: "
|
|
D ENDTM^YSUTL S DWPK=1 D EN^DIWE
|
|
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
|
|
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)
|
|
HS ;
|
|
S ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,1,0)="",DIC="^PTX(YSDFN,YSHX,YSIDT,1,DUZ,2,YSCD,1,"
|
|
S DIWESUB="Hx of Present Illness",DIWEPSE=1
|
|
W !!,"HISTORY OF PRESENT ILLNESS: "
|
|
D ENDTM^YSUTL S DWPK=1 D EN^DIWE
|
|
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
|
|
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)
|
|
MD ;
|
|
S ^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,1,0)="",DIC="^PTX(YSDFN,YSHX,YSIDT,1,DUZ,3,YSCD,1,"
|
|
S DIWESUB="Current Meds & Source",DIWEPSE=1
|
|
W !!,"CURRENT MEDS AND SOURCE: "
|
|
D ENDTM^YSUTL S DWPK=1 D EN^DIWE
|
|
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
|
|
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)
|
|
DC ;
|
|
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)
|
|
I '$O(^PTX(+YSDFN,YSHX,YSIDT,1,0)) L +^PTX(+YSDFN) K ^PTX(+YSDFN,YSHX,YSIDT) L -^PTX(+YSDFN) G END:$G(X)["^",1
|
|
I '$D(^PTX(YSDFN,0)) L +^PTX(+YSDFN) S ^PTX(YSDFN,0)=YSDFN,^PTX("B",YSDFN,YSDFN)="" L -^PTX(YSDFN)
|
|
L +^PTX(0) S YSTN=$P(^PTX(0),U,4)+1,L=$P(^PTX(0),U,3)
|
|
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
|
|
L +^PTX(YSDFN)
|
|
I $D(^PTX(YSDFN,YSHX,0)) S YSNU=$P(^(0),U,4)+1,^(0)=$P(^(0),U,1,3)_U_YSNU K YSNU
|
|
E S ^(0)="^99.05D^"_YSIDT_"^1"
|
|
S:'$D(^PTX(YSDFN,YSHX,YSIDT,0)) ^(0)=DT
|
|
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
|
|
E S ^(0)="^99.06P^"_DUZ_"^1"
|
|
L -^PTX(YSDFN) G END:$G(X)="^",1
|
|
END ; Called by routine YSHX1R
|
|
I $G(YSTOUT),IOST?1"C-".E W:IOF]"" @IOF
|
|
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
|
|
K YSLFT,YSMN,YSNM,YSNH,YSP0,YSPF,YSPT,YSPTD,YSSEX,YSSL,YSSSN,YSTM,YSTOUT,YSUOUT,YSUS,YSUSN,YSUSER,YSUTL,YSYD,Z,ZTSK Q
|
|
DTS ;
|
|
S (YSTOUT,YSUOUT)=0 I '$D(^PTX(YSDFN,"HX")) S YSNH=1 W $C(7),!!?3,"NO HX1'S ON FILE",!! Q
|
|
S (YSNH,K,YSIDT)=0 K A W !!?10,"PREVIOUS HX1'S",!
|
|
YSIDT ;
|
|
S YSIDT=$O(^PTX(YSDFN,YSHX,YSIDT)) G:'YSIDT SEL S K=K+1,YSHD=9999999-YSIDT,(Y,A(K))=YSHD
|
|
D ENDD^YSUTL W !?8,$J(K,3)," ",Y G YSIDT
|
|
SEL ;
|
|
I K>1 G SL1
|
|
I K=1 W !?10,Y R " OK? Y// ",AA:DTIME S YSTOUT='$T,YSUOUT=AA["^"
|
|
G END:YSTOUT Q:YSUOUT
|
|
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
|
|
I K=1 S:"N"[AA YSNH=1 Q
|
|
I K=1 W:AA'["?" " ?",$C(7) G SELQ1
|
|
SL1 ;
|
|
W !!?3,"Select HX1 NUMBER: " R AB:DTIME S YSOUT='$T,YSUOUT=AB["^" I YSTOUT G END
|
|
Q:YSUOUT!(AB']"") G:AB["?" SL1Q I AB<1!(AB>K) G SL1
|
|
S YSDT=A(AB) Q
|
|
SELQ1 ;
|
|
W !!,"""YES"" = edit. ""N"" = new. Only one HX1 per day.",! K AA G SEL
|
|
SELQ2 ;
|
|
W !!,"""YES"" permits altering of previously entered information.",!,"""NO"" allows the addition of a new history - only 1 per day.",! K AA G SEL
|
|
SL1Q ;
|
|
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
|
|
ELQ ;
|
|
W !!,"""E"" permits altering or addition of new HX1.",!,"""P"" produces a report.",!,"""Q"" exits option.",! G EL
|