source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHORD82.m@ 789

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

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1FHORD82 ; HISC/REL/NCA - Diet Order Lists (cont) ;3/25/96 08:36
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 S TF=$P(X0,"^",4) G:'TF L4
4 S Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0),X=$P(Y,"^",1),COM=$P(Y,"^",5),CAL=$P(Y,"^",7)
5 W !,?13,"Tubefeed.: " S ZZ="" D DT S DTE=X
6 F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 S X3=$G(^(TF2,0)),TUN=+X3,XX=$G(^FH(118.2,TUN,0)),TUN=$P(XX,"^",1) D CALC S:ZZ'="" ZZ=ZZ_", " S ZZ=ZZ_P2_" "_TUN
7 S ZZ=ZZ_", "_CAL_" Kcal/Day"
8 S REC=1 D LNE
9L3 W:COM'="" !?15,COM,!
10L4 F K1=DT-.00001:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"EL",K1)) Q:K1<1!(K1\1>K3) S Y=^(K1,0) D EL
11 D DISP^FHORD83
12 K N F K=0:0 S K=$O(^FHPT("ASP",FHDFN,ADM,K)) Q:K<1 S X=^FHPT(FHDFN,"A",ADM,"SP",K,0),M=$P(X,"^",3),M=$S(M="BNE":"A",1:$E(M,1)),N(M,K)=$P(X,"^",2,4),$P(N(M,K),"^",4,5)=$P(X,"^",8,9)
13 W !
14 F M="A","B","N","E" F K=0:0 S K=$O(N(M,K)) Q:K<1 S Z=+N(M,K) I Z D
15 .I ($Y>(IOSL-6)) D HDR^FHORD81,FLNE
16 .D SP S QTY=$P(N(M,K),"^",4)
17 .W !?13,"Stng. Order: ",M2,?38,$S(QTY:QTY,1:1)," ",$P($G(^FH(118.3,Z,0)),"^",1),$S($P(N(M,K),"^",5)'="Y":" (I)",1:"")
18 .S X=$P(N(M,K),"^",3) D DT W ?72,X Q
19 K L,N,M,M1,M2 S NM=$P(X0,"^",7) G:'NM L3^FHORD81 S Y=^FHPT(FHDFN,"A",ADM,"SF",NM,0)
20 S L=4 F K1=1:1:3 S K=0,N(K1)="" F K2=1:1:4 S Z=$P(Y,U,L+1),Q=$P(Y,U,L+2),L=L+2 I Z'="" S:'Q Q=1 S:N(K1)'="" N(K1)=N(K1)_"; " S N(K1)=N(K1)_Q_" "_$S($D(C(Z)):C(Z),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:" ")
21 S LST=$P(Y,"^",30)\1,X=LST,P1=0 D DT S:LST<OLN X=X_"*"
22 F K1=1:1:3 I N(K1)'="" W !?13,$P("10AM; 2PM; 8PM",";",K1),?19,$E(N(K1),1,52) I 'P1 S P1=1 W ?72,X
23 G L3^FHORD81
24SP S M1=$P(N(M,K),"^",2) I M1="BNE" S M2="All Meals" Q
25 S L=$E(M1,1),M2=$S(L="B":"Break",L="N":"Noon",1:"Even")
26 S L=$E(M1,2) Q:L="" S M2=M2_","_$S(L="B":"Break",L="N":"Noon",1:"Even") Q
27EL I ($Y>(IOSL-6)) D HDR^FHORD81,FLNE
28 S MEAL=$P(Y,"^",2),TIM=$P(Y,"^",3),BAG=$P(Y,"^",4),DTP=K1\1 D DTP^FH
29 W !?13,"Early/Late Tray: ",DTP,?39,$J(TIM,10)," ",$S(MEAL="B":"Breakfast",MEAL="N":"Noon",1:"Evening") W:BAG="Y" ", Bagged Meal" Q
30 Q
31DT S X=$J(+$E(X,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(X,4,5)) Q
32CALC ; Figure # of units for TF
33 I $E($P(XX,"^",3),$L($P(XX,"^",3)))="G" D GRM Q
34 S TU=$P(X3,"^",4)/$S(+$P(XX,"^",3):+$P(XX,"^",3),1:9999),TW=$P(X3,"^",5)
35 I TW<6 S TU=TU+.75\1,P2=TU,P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2)) Q
36 S TU=TU+.2*4\1/4,P2=$S(TU<1:"",1:TU\1) I TU#1 S:P2 P2=P2_"-" S P3=TU#1,P2=P2_$S(P3<.3:"1/4",P3<.6:"1/2",1:"3/4")
37 S P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2))
38 Q
39GRM S X=$P(X3,"^",3) D FIX^FHORT10 S Z5="" F LL=1:1:$L(X) I $E(X,LL)'=" " S Z5=Z5_$E(X,LL)
40 S Z5=$P(Z5,"/",2),Z5=$P(Z5,"X",2)
41 I 'Z5 S Z5=$P("1,24,2,3,12,8,6,4",",",K) G G1
42 I Z5'["F" S Z5=$S(K=1:1,K=2:Z5,K=3:2,K=4:3,K=5:Z5\2,K=6:Z5\3,K=7:Z5\4,1:Z5\6)
43 E S:K=1 Z5=1
44G1 S TU=+$P(X3,"^",3)*Z5
45 S TU=TU/$S(+$P(XX,"^",3):+$P(XX,"^",3),1:9999)
46 S P2=$S(TU<1:"",1:TU\1) I P2="" S TU=TU+.95\1,P2=TU
47 I TU#1 S:P2 P2=P2_"-" S TU=TU#1,P2=P2_$S(TU<.3:"1/4",TU<.6:"1/2",1:"3/4")
48 S P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2))
49 Q
50LNE ; Break Line if longer than 45 chars
51 I $L(ZZ)<46 D Q
52 .W ZZ
53 .I REC W ?72,DTE S REC=0
54 .Q
55 ;F L=47:-1:1 Q:$E(ZZ,L-1,L)=", "
56 F L=47:-1:1 Q:$E(ZZ,L)=" "!($E(ZZ,L)=",")
57 W $E(ZZ,1,L-1) I REC W ?72,DTE S REC=0
58 S ZZ=$E(ZZ,L+1,999)
59 Q:ZZ="" W !?24
60 G LNE
61FLNE I '$G(ADM)!'$G(DFN) Q
62 S DTP=$P(^DGPM(ADM,0),"^",1) D DTP^FH
63 W !!,RM,?13,$E($P($G(^DPT(DFN,0)),"^",1),1,24),?38,BID,?47,DTP
64 I $P($G(^FHPT(FHDFN,"A",ADM,0)),"^",5)'="" W ?67,$P(^FHPT(FHDFN,"A",ADM,0),"^",5)
65 Q
Note: See TracBrowser for help on using the repository browser.