FHORD82.m

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

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