FHORD82 ; HISC/REL/NCA - Diet Order Lists (cont) ;3/25/96 08:36
;;5.5;DIETETICS;;Jan 28, 2005
S TF=$P(X0,"^",4) G:'TF L4
S Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0),X=$P(Y,"^",1),COM=$P(Y,"^",5),CAL=$P(Y,"^",7)
W !,?13,"Tubefeed.: " S ZZ="" D DT S DTE=X
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
S ZZ=ZZ_", "_CAL_" Kcal/Day"
S REC=1 D LNE
L3 W:COM'="" !?15,COM,!
L4 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
D DISP^FHORD83
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)
W !
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
.I ($Y>(IOSL-6)) D HDR^FHORD81,FLNE
.D SP S QTY=$P(N(M,K),"^",4)
.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:"")
.S X=$P(N(M,K),"^",3) D DT W ?72,X Q
K L,N,M,M1,M2 S NM=$P(X0,"^",7) G:'NM L3^FHORD81 S Y=^FHPT(FHDFN,"A",ADM,"SF",NM,0)
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:" ")
S LST=$P(Y,"^",30)\1,X=LST,P1=0 D DT S:LST<OLN X=X_"*"
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
G L3^FHORD81
SP S M1=$P(N(M,K),"^",2) I M1="BNE" S M2="All Meals" Q
S L=$E(M1,1),M2=$S(L="B":"Break",L="N":"Noon",1:"Even")
S L=$E(M1,2) Q:L="" S M2=M2_","_$S(L="B":"Break",L="N":"Noon",1:"Even") Q
EL I ($Y>(IOSL-6)) D HDR^FHORD81,FLNE
S MEAL=$P(Y,"^",2),TIM=$P(Y,"^",3),BAG=$P(Y,"^",4),DTP=K1\1 D DTP^FH
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
Q
DT 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
CALC ; Figure # of units for TF
I $E($P(XX,"^",3),$L($P(XX,"^",3)))="G" D GRM Q
S TU=$P(X3,"^",4)/$S(+$P(XX,"^",3):+$P(XX,"^",3),1:9999),TW=$P(X3,"^",5)
I TW<6 S TU=TU+.75\1,P2=TU,P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2)) Q
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")
S P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2))
Q
GRM 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)
S Z5=$P(Z5,"/",2),Z5=$P(Z5,"X",2)
I 'Z5 S Z5=$P("1,24,2,3,12,8,6,4",",",K) G G1
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)
E S:K=1 Z5=1
G1 S TU=+$P(X3,"^",3)*Z5
S TU=TU/$S(+$P(XX,"^",3):+$P(XX,"^",3),1:9999)
S P2=$S(TU<1:"",1:TU\1) I P2="" S TU=TU+.95\1,P2=TU
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")
S P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2))
Q
LNE ; Break Line if longer than 45 chars
I $L(ZZ)<46 D Q
.W ZZ
.I REC W ?72,DTE S REC=0
.Q
;F L=47:-1:1 Q:$E(ZZ,L-1,L)=", "
F L=47:-1:1 Q:$E(ZZ,L)=" "!($E(ZZ,L)=",")
W $E(ZZ,1,L-1) I REC W ?72,DTE S REC=0
S ZZ=$E(ZZ,L+1,999)
Q:ZZ="" W !?24
G LNE
FLNE I '$G(ADM)!'$G(DFN) Q
S DTP=$P(^DGPM(ADM,0),"^",1) D DTP^FH
W !!,RM,?13,$E($P($G(^DPT(DFN,0)),"^",1),1,24),?38,BID,?47,DTP
I $P($G(^FHPT(FHDFN,"A",ADM,0)),"^",5)'="" W ?67,$P(^FHPT(FHDFN,"A",ADM,0),"^",5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD82 3549 printed Apr 09, 2024@20:53:56 Page 2
FHORD82 ; HISC/REL/NCA - Diet Order Lists (cont) ;3/25/96 08:36
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET TF=$PIECE(X0,"^",4)
if 'TF
GOTO L4
+3 SET Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
SET X=$PIECE(Y,"^",1)
SET COM=$PIECE(Y,"^",5)
SET CAL=$PIECE(Y,"^",7)
+4 WRITE !,?13,"Tubefeed.: "
SET ZZ=""
DO DT
SET DTE=X
+5 FOR TF2=0:0
SET TF2=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2))
if TF2<1
QUIT
SET X3=$GET(^(TF2,0))
SET TUN=+X3
SET XX=$GET(^FH(118.2,TUN,0))
SET TUN=$PIECE(XX,"^",1)
DO CALC
if ZZ'=""
SET ZZ=ZZ_", "
SET ZZ=ZZ_P2_" "_TUN
+6 SET ZZ=ZZ_", "_CAL_" Kcal/Day"
+7 SET REC=1
DO LNE
L3 if COM'=""
WRITE !?15,COM,!
L4 FOR K1=DT-.00001:0
SET K1=$ORDER(^FHPT(FHDFN,"A",ADM,"EL",K1))
if K1<1!(K1\1>K3)
QUIT
SET Y=^(K1,0)
DO EL
+1 DO DISP^FHORD83
+2 KILL N
FOR K=0:0
SET K=$ORDER(^FHPT("ASP",FHDFN,ADM,K))
if K<1
QUIT
SET X=^FHPT(FHDFN,"A",ADM,"SP",K,0)
SET M=$PIECE(X,"^",3)
SET M=$SELECT(M="BNE":"A",1:$EXTRACT(M,1))
SET N(M,K)=$PIECE(X,"^",2,4)
SET $PIECE(N(M,K),"^",4,5)=$PIECE(X,"^",8,9)
+3 WRITE !
+4 FOR M="A","B","N","E"
FOR K=0:0
SET K=$ORDER(N(M,K))
if K<1
QUIT
SET Z=+N(M,K)
IF Z
Begin DoDot:1
+5 IF ($Y>(IOSL-6))
DO HDR^FHORD81
DO FLNE
+6 DO SP
SET QTY=$PIECE(N(M,K),"^",4)
+7 WRITE !?13,"Stng. Order: ",M2,?38,$SELECT(QTY:QTY,1:1)," ",$PIECE($GET(^FH(118.3,Z,0)),"^",1),$SELECT($PIECE(N(M,K),"^",5)'="Y":" (I)",1:"")
+8 SET X=$PIECE(N(M,K),"^",3)
DO DT
WRITE ?72,X
QUIT
End DoDot:1
+9 KILL L,N,M,M1,M2
SET NM=$PIECE(X0,"^",7)
if 'NM
GOTO L3^FHORD81
SET Y=^FHPT(FHDFN,"A",ADM,"SF",NM,0)
+10 SET L=4
FOR K1=1:1:3
SET K=0
SET N(K1)=""
FOR K2=1:1:4
SET Z=$PIECE(Y,U,L+1)
SET Q=$PIECE(Y,U,L+2)
SET L=L+2
IF Z'=""
if 'Q
SET Q=1
if N(K1)'=""
SET N(K1)=N(K1)_"; "
SET N(K1)=N(K1)_Q_" "_$SELECT($DATA(C(Z)):C(Z),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:" ")
+11 SET LST=$PIECE(Y,"^",30)\1
SET X=LST
SET P1=0
DO DT
if LST<OLN
SET X=X_"*"
+12 FOR K1=1:1:3
IF N(K1)'=""
WRITE !?13,$PIECE("10AM; 2PM; 8PM",";",K1),?19,$EXTRACT(N(K1),1,52)
IF 'P1
SET P1=1
WRITE ?72,X
+13 GOTO L3^FHORD81
SP SET M1=$PIECE(N(M,K),"^",2)
IF M1="BNE"
SET M2="All Meals"
QUIT
+1 SET L=$EXTRACT(M1,1)
SET M2=$SELECT(L="B":"Break",L="N":"Noon",1:"Even")
+2 SET L=$EXTRACT(M1,2)
if L=""
QUIT
SET M2=M2_","_$SELECT(L="B":"Break",L="N":"Noon",1:"Even")
QUIT
EL IF ($Y>(IOSL-6))
DO HDR^FHORD81
DO FLNE
+1 SET MEAL=$PIECE(Y,"^",2)
SET TIM=$PIECE(Y,"^",3)
SET BAG=$PIECE(Y,"^",4)
SET DTP=K1\1
DO DTP^FH
+2 WRITE !?13,"Early/Late Tray: ",DTP,?39,$JUSTIFY(TIM,10)," ",$SELECT(MEAL="B":"Breakfast",MEAL="N":"Noon",1:"Evening")
if BAG="Y"
WRITE ", Bagged Meal"
QUIT
+3 QUIT
DT SET X=$JUSTIFY(+$EXTRACT(X,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(X,4,5))
QUIT
CALC ; Figure # of units for TF
+1 IF $EXTRACT($PIECE(XX,"^",3),$LENGTH($PIECE(XX,"^",3)))="G"
DO GRM
QUIT
+2 SET TU=$PIECE(X3,"^",4)/$SELECT(+$PIECE(XX,"^",3):+$PIECE(XX,"^",3),1:9999)
SET TW=$PIECE(X3,"^",5)
+3 IF TW<6
SET TU=TU+.75\1
SET P2=TU
SET P2=P2_" "_$SELECT(P2>1:$PIECE(XX,"^",2)_"S",1:$PIECE(XX,"^",2))
QUIT
+4 SET TU=TU+.2*4\1/4
SET P2=$SELECT(TU<1:"",1:TU\1)
IF TU#1
if P2
SET P2=P2_"-"
SET P3=TU#1
SET P2=P2_$SELECT(P3<.3:"1/4",P3<.6:"1/2",1:"3/4")
+5 SET P2=P2_" "_$SELECT(P2>1:$PIECE(XX,"^",2)_"S",1:$PIECE(XX,"^",2))
+6 QUIT
GRM SET X=$PIECE(X3,"^",3)
DO FIX^FHORT10
SET Z5=""
FOR LL=1:1:$LENGTH(X)
IF $EXTRACT(X,LL)'=" "
SET Z5=Z5_$EXTRACT(X,LL)
+1 SET Z5=$PIECE(Z5,"/",2)
SET Z5=$PIECE(Z5,"X",2)
+2 IF 'Z5
SET Z5=$PIECE("1,24,2,3,12,8,6,4",",",K)
GOTO G1
+3 IF Z5'["F"
SET Z5=$SELECT(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)
+4 IF '$TEST
if K=1
SET Z5=1
G1 SET TU=+$PIECE(X3,"^",3)*Z5
+1 SET TU=TU/$SELECT(+$PIECE(XX,"^",3):+$PIECE(XX,"^",3),1:9999)
+2 SET P2=$SELECT(TU<1:"",1:TU\1)
IF P2=""
SET TU=TU+.95\1
SET P2=TU
+3 IF TU#1
if P2
SET P2=P2_"-"
SET TU=TU#1
SET P2=P2_$SELECT(TU<.3:"1/4",TU<.6:"1/2",1:"3/4")
+4 SET P2=P2_" "_$SELECT(P2>1:$PIECE(XX,"^",2)_"S",1:$PIECE(XX,"^",2))
+5 QUIT
LNE ; Break Line if longer than 45 chars
+1 IF $LENGTH(ZZ)<46
Begin DoDot:1
+2 WRITE ZZ
+3 IF REC
WRITE ?72,DTE
SET REC=0
+4 QUIT
End DoDot:1
QUIT
+5 ;F L=47:-1:1 Q:$E(ZZ,L-1,L)=", "
+6 FOR L=47:-1:1
if $EXTRACT(ZZ,L)=" "!($EXTRACT(ZZ,L)=",")
QUIT
+7 WRITE $EXTRACT(ZZ,1,L-1)
IF REC
WRITE ?72,DTE
SET REC=0
+8 SET ZZ=$EXTRACT(ZZ,L+1,999)
+9 if ZZ=""
QUIT
WRITE !?24
+10 GOTO LNE
FLNE IF '$GET(ADM)!'$GET(DFN)
QUIT
+1 SET DTP=$PIECE(^DGPM(ADM,0),"^",1)
DO DTP^FH
+2 WRITE !!,RM,?13,$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",1),1,24),?38,BID,?47,DTP
+3 IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",5)'=""
WRITE ?67,$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)
+4 QUIT
