1 | FHORD1 ; HISC/REL/NCA - Diet Order ;3/28/01 10:28
|
---|
2 | ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
|
---|
3 | F0 S ALL=1 D ^FHDPA G:'DFN KIL G:'FHDFN KIL
|
---|
4 | I $G(ADM)="" W *7,!!," NOT CURRENTLY AN INPATIENT" D KIL Q
|
---|
5 | D D0 G:'DFN KIL G:'FHDFN KIL D PROC
|
---|
6 | S DTE="" D ^FHORD1A I FHWF,DTE S (SDT,EDT)=DTE,WKD="",SERV="L" D EL^FHWOR3 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG
|
---|
7 | S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) I TF W !!,"An ACTIVE Tubefeeding Order Exists!" S FHD="Y" D DIS^FHORT2,ASK^FHORT2 D:FHD="Y" CAN^FHORT2
|
---|
8 | G F0
|
---|
9 | D0 ; Process Diet Order
|
---|
10 | D CUR^FHORD7 W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
|
---|
11 | D ALG^FHCLN W !!,"Allergies: ",$S(ALG="":"None on file",1:ALG)
|
---|
12 | I FHORD S COM=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) I COM'="" W !,"Comment: ",COM
|
---|
13 | D NOW^%DTC S NOW=% K %,%H,%I D FUT
|
---|
14 | C0 I CT W *7 R !!,"A new order with no expiration date will CANCEL these diets.",!!,"Do you wish to CONTINUE? (Y/N): ",X:DTIME G:'$T!(X="^") AB S:X="" X="^" D TR^FH G:$P("NO",X,1)="" AB I $P("YES",X,1)'="" W *7," Answer YES or NO" G C0
|
---|
15 | F7 S WRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8),SVC="" I WRD>0 S SVC=$P($G(^FH(119.6,WRD,0)),"^",10)
|
---|
16 | S:SVC="" SVC="T" I $L(SVC)=1 S TYP=SVC G F8
|
---|
17 | S N1=$P(^FHPT(FHDFN,"A",ADM,0),"^",5) S:SVC'[N1 N1=""
|
---|
18 | S X="Tray^Cafeteria^Dining Room" W !!,$P(X,"^",$F("TCD",$E(SVC,1))-1),$S($L(SVC)=2:" or ",1:", "),$P(X,"^",$F("TCD",$E(SVC,2))-1)
|
---|
19 | W:$L(SVC)=3 " or ",$P(X,"^",$F("TCD",$E(SVC,3))-1) W ": ",$S(N1="":$E(SVC,1),1:N1),"// "
|
---|
20 | R X:DTIME G:'$T!(X="^") AB S:X="" X=$S(N1="":$E(SVC,1),1:N1) S X=$E(X,1) D TR^FH
|
---|
21 | I SVC'[X W *7,!,"Enter one of the given type of services." G F7
|
---|
22 | S TYP=X
|
---|
23 | I 'FHORD!(N1="")!(N1=TYP) G F8
|
---|
24 | S N1=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0) I "^^^^"[$P(N1,"^",2,6) G F8
|
---|
25 | R1 R !!,"Retain Current Diet? N// ",Y:DTIME G:'$T!(Y="^") AB S:Y="" Y="N" S X=Y D TR^FH S Y=X I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7," Answer YES or NO" G R1
|
---|
26 | G:Y?1"N".E F8 S FHOR=$P(N1,"^",2,6),(D3,D4)=0,D2=$P(N1,"^",10)
|
---|
27 | S D1=NOW G F10
|
---|
28 | F8 K DI S N1=0 G:FHWF=2 F1 R !!,"Order a REGULAR Diet? (Y/N) ",Y:DTIME G:'$T!(Y="^") AB S:Y="" Y="^" S X=Y D TR^FH S Y=X I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7," Answer YES or NO" G F8
|
---|
29 | G:Y'?1"Y".E F1 S Y(0)=^FH(111,1,0),PREC=$P(Y(0),U,4),DI(PREC)="1^"_Y(0),N1=1 G F5
|
---|
30 | F1 W ! K DIC S DIC="^FH(111,",DIC(0)="AEQMZ" S DIC("S")="I '$D(^(""I""))&(Y>1)" D ^DIC K DIC G AB:X[U!$D(DTOUT),F5:X="",F1:Y<1
|
---|
31 | S PREC=$P(Y(0),U,4) I PREC,$D(DI(PREC)) W *7,!!,"This conflicts with ",$P(DI(PREC),"^",2),! G F1
|
---|
32 | S N1=N1+1,DI(PREC)=+Y_"^"_Y(0) G F5:+Y=1,F1:N1<5 W *7,!!,"You have now selected the maximum of 5 Diet Modifications!"
|
---|
33 | F5 G:'N1 AB W !!,"You have selected the following Diet:",!
|
---|
34 | S (D3,D4)=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" W !?5,$P(DI(D0),U,2) S:$P(DI(D0),U,4)="Y" D3=1 S:$P(DI(D0),U,7)="Y" D4=1
|
---|
35 | F9 G:FHWF=2 F6 R !!,"Is this Correct? Y// ",Y:DTIME G:'$T!(Y="^") AB S:Y="" Y="Y" S X=Y D TR^FH S Y=X
|
---|
36 | I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7,!," Answer YES to accept diet list; NO to select diets again" G F9
|
---|
37 | I Y'?1"Y".E K DI S N1=0 W !!,"Select new diets ..." G F1
|
---|
38 | F6 S COM="" ;R !!,"Comment: ",COM:DTIME G:'$T!(COM["^") AB I COM'?.ANP W *7," ??" G F6
|
---|
39 | I $L(COM)>80!(COM?1"?".E) W *7,!,"Enter any special instructions of up to 80 characters!" G F6
|
---|
40 | D GETD^FHORD71 G:'D1 AB
|
---|
41 | S FHOR="^^^^",FHEVTX="",N1=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" S N1=N1+1,$P(FHOR,U,N1)=+DI(D0),FHEVTX=FHEVTX_", "_$P(DI(D0),U,8)
|
---|
42 | ; [SEE NOIS SDC-0402-62498] S FHDPATT=$O(^FH(111.1,"AB",FHOR,0)) I FHDPATT'="" I $G(^FH(111.1,FHDPATT,"I"))="Y" W !!," ** INACTIVE DIET PATTERN! **" G AB
|
---|
43 | I '$O(^FH(111.1,"AB",FHOR,0)),$P($G(^FH(119.9,1,4)),"^",2)="Y" S EVT="M^O^^No Diet Pattern ("_$E(FHEVTX,3,999)_")" D ^FHORX
|
---|
44 | F10 S FHLD="" W:FHWF'=2 !!,"... Diet Order Accepted"
|
---|
45 | Q
|
---|
46 | PROC ; Process & file order
|
---|
47 | D STR^FHORD7,^FHORDR D:D4 POST^FHORD7 Q
|
---|
48 | AB W *7,!!,"Diet Order for this Patient is UNCHANGED -- No order entered!",! S (DFN,FHDFN)="" Q
|
---|
49 | KIL ; Final variable kill
|
---|
50 | K %,%H,%I,%T,%DT,A1,A2,ADM,ALL,C,COM,CORD,CT,D0,D1,D2,D3,D4,DA,FHDFN,DFN,DTP,DI,DIC,FHDU,FHD,FHLD,FHOR,FHPAR,FHWF,FHPV,FLG,I,J,K,KK,N1,NOW,FHORD,FHSAV,FHSAV1,FHDAY
|
---|
51 | K FHK,FHK1,FHOE,FHOLD,FHMSG,FHNEW,K1,K2,KK1,LC,M,PREC,SVC,TYP,X,X1,X2,Y,WRD,WARD,TF,QUA,STR,TUN,XMKK,Z Q
|
---|
52 | FUT ; List future diets
|
---|
53 | S CT=0,CORD=FHORD F KK=NOW:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1 S FHORD=$P(^(KK,0),"^",2) D T1
|
---|
54 | S FHORD=CORD Q
|
---|
55 | T1 Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) S DTP=KK D DTP^FH,C2^FHORD7
|
---|
56 | I 'CT W !!,"Future Diet Orders:",!
|
---|
57 | S CT=CT+1 W !?5,DTP,?25,Y Q
|
---|