source: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSHX1.m@ 636

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