source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHMTK6.m@ 901

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

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1FHMTK6 ; HISC/NCA/RTK/FAI - History of Diet Patterns ;10/20/04 07:12
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 S (ANS,O1,FHO1)="",FHALL=1 D ^FHOMDPA G:'FHDFN KIL
4 I $O(^FHPT(FHDFN,"A",0))<1 W !!,"NO ADMISSIONS ON FILE!" G FHMTK6
5 D ADM I ADM'="" S FHADM=ADM D CUR^FHORD7 G:FHLD'="" KIL S FHO1=FHORD,O1=Y,ANS=""
6 S DIC="^FHPT(FHDFN,""A"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
7A0 W !!,"Select ADMISSION",$S($D(^DPT(DFN,.1)):" (or C for CURRENT)",1:""),": " R X:DTIME G:'$T!("^"[X) KIL D:X="c" TR^FH
8 I X="C" D ADM G P0:ADM'<1,FHMTK6
9 S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
10P0 W !!!,"Current Diet: ",$S(O1'="":O1,1:"No Current Diet") S FHORD=""
11 K S S (LST,N1)=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"DI",K)) Q:K<1 S X=$G(^(K,0)),X1=$G(^(2)),X2=$G(^(3)) I X1'="" S (FHORD,LST)=K D LIS
12 I 'N1 W !!,"No Diet Pattern for this Admission!" G FHMTK6
13P1 R !!,"Detailed Display of which Pattern #? ",X:DTIME G:'$T!("^"[X) FHMTK6 I X'?1N.N!(X<1)!(X>N1) W *7," Enter Pattern # to List" G P1
14 I '$G(S(+X)) W !!,"No Pattern Saved for this Diet!" G FHMTK6
15 S FHORD=+S(+X) W ! S MP=0 D LIS^FHMTK4 G:ANS="^" FHMTK6
16 S PD=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",13)
17 S CLERK=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,3)),"^",1)
18 W !!?25,"Pattern Entered By: ",$E($P($G(^VA(200,+CLERK,0)),"^",1),1,30),!
19 S Z=$O(^FHPT(FHDFN,"P",0)) I Z D PSE G:ANS="^" FHMTK6 D DISP^FHSEL1
20 I FHO1="" Q
21 S FHOR=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHO1,0)),"^",2,6)
22R5 R !!,"Do You Want to Store this Pattern As the Patient's Individual Pattern? N// ",Y:DTIME G:'$T!(Y="^") FHMTK6 S:Y="" Y="N" S X=Y D TR^FH S Y=X
23 I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7,!," Answer YES to Store this Pattern as the patient's Diet Pattern; NO, not to store." G R5
24 G:Y'?1"Y".E FHMTK6 W !!,"Storing Patient's Diet Pattern ..."
25 G:STR="" FHMTK6
26 S:$E(STR,$L(STR))=";" STR=$E(STR,1,$L(STR)-1)
27 I $L(STR)>240 S LN=$L($E(STR,1,240)," "),STR=$P(STR," ",1,LN-1)
28 S ^FHPT(FHDFN,"A",FHADM,"DI",FHO1,2)=STR D NOW^%DTC S TIM=%
29 S:$G(^FHPT(FHDFN,"A",FHADM,"DI",FHO1,3))="" ^FHPT(FHDFN,"A",FHADM,"DI",FHO1,3)=DUZ_"^"_TIM
30 I PD S $P(^FHPT(FHDFN,"A",FHADM,"DI",FHO1,0),"^",13)=PD
31 G FHMTK6
32ADM S WARD=$G(^DPT(DFN,.1))
33 I WARD="" W *7,!!,"NOT CURRENTLY AN INPATIENT!",! S ADM="" Q
34 S ADM=$G(^DPT("CN",WARD,DFN)) Q
35LIS I 'N1 W !!,"Pat Date/Time Entered Diet Pattern",!
36 S D1=$P(X2,"^",2)
37 S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),Y=""
38 I FHLD'="" Q
39 S N1=N1+1,S(N1)=FHORD
40 S DTP=D1 S:DTP="" DTP=$P(X,"^",9)
41 D:DTP'="" DTP^FH W !,$J(N1,3)," ",$S(DTP'="":DTP,1:"")
42 S Y="" F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
43 W:Y'="" ?24,Y
44 Q
45KIL K ^TMP($J) G KILL^XUSCLEAN
46PSE I IOST?1"C-".E R !!,"Press RETURN to Continue ",X:DTIME W ! S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PSE
47 Q
Note: See TracBrowser for help on using the repository browser.