- FHORD2 ; HISC/REL/NCA - Review Diet Orders ;11/7/92 09:57
- ;;5.5;DIETETICS;**1**;Jan 28, 2005
- F0 S ALL=0 D ^FHDPA G KIL:'DFN,KIL:'FHDFN,F0:'$D(^DGPM(ADM,0))
- S DTP=$P(^DGPM(ADM,0),"^",1) D DTP^FH
- F01 W !!,"List Orders from Date/Time: "_DTP_" // " R X:DTIME G:'$T!(X["^") KIL S:X="" Y=0 I X'="" S %DT="EXTS" D ^%DT G:Y<1 F01
- S D4=Y D CUR^FHORD7 W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
- I Y'="",FHORD>0 I $D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) W !,"Comment: ",^(1)
- S X1=^FHPT(FHDFN,"A",ADM,0),DTP=$P(X1,"^",3) I DTP D DTP^FH W !,"Expires: ",DTP
- S TF=$P(X1,"^",4) G:TF<1 F1
- S Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
- S DTP=$P(Y,"^",1),COM=$P(Y,"^",5),TQU=$P(Y,"^",6),CAL=$P(Y,"^",7)
- D DTP^FH W !!,"Tubefeed Ordered: ",DTP
- F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 S XY=^(TF2,0) D LP
- W !,"Total Quantity: ",TQU," ml",?42,"Total KCAL: ",CAL
- W:COM'="" !,"Comment: ",COM
- F1 S CT=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"OO",K)) Q:K<1 S X=^(K,0) I $P(X,"^",2)'<D4,$P(X,"^",5)="S" D L1
- S N1=0 F FHORD=0:0 S FHORD=$O(^FHPT(FHDFN,"A",ADM,"DI",FHORD)) Q:FHORD<1 S X=^(FHORD,0) D LST
- I 'N1 W !!,"No Diet Orders Entered",! G F0
- D TLN G F0
- KIL K %,%DT,A1,ADM,ALL,C,CAL,COM,CT,D1,D2,D3,D4,DA,DTP,FHDFN,DFN,FHDU,FHLD,FHOR,I,K,KK,N1,NOW,FHORD,FHWF,FHPV,POP,TYP,TF,TF2,TQU,TUN,STR,QUA,WARD,X,X1,X2,XY,Y Q
- LP S TUN=$P(XY,"^",1),STR=$P(XY,"^",2),QUA=$P(XY,"^",3)
- I QUA["CC" S QUAFI=$P(QUA,"CC",1),QUASE=$P(QUA,"CC",2),QUA=QUAFI_"ML"_QUASE
- W !,"Product: ",$P($G(^FH(118.2,TUN,0)),"^",1),", ",$S(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA Q
- L1 I 'CT W !!,"Saved Additional Orders:",! S CT=1
- S DTP=$P(X,"^",2) D DTP^FH W !,DTP,?20,$P(X,"^",3) Q
- LST S COM=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) Q:$P(X,"^",9)<D4
- I 'N1 W !!," Effective Expires Type Order",!
- S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),D1=$P(X,"^",9),D2=$P(X,"^",10),TYP=$P(X,"^",8),D3=$P(X,"^",12),N1=N1+1
- S DTP=D1 D DTP^FH W !,DTP I D2 S DTP=D2 D DTP^FH W ?20,DTP
- W ?40,TYP,?44 D ORD I $L(Y)<36 W Y
- E W $P(Y,", ",1,3) W:$P(Y,", ",4)'="" ",",!?44,$P(Y,", ",4,5)
- W:COM'="" !?44,COM Q
- ORD S Y="" I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
- 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)
- Q
- TLN W !!?24,"----- Diet Orders Time Line -----",!," Effective Type Order",!
- F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1 S FHORD=$P(^(KK,0),"^",2) D T1
- Q
- T1 S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0) Q:$P(X,"^",9)<D4
- S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),TYP=$P(X,"^",8)
- S DTP=KK D DTP^FH W !,DTP,?20,TYP,?24 D ORD I $L(Y)<56 W Y Q
- W $P(Y,", ",1,4),",",!?24,$P(Y,", ",5) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD2 2749 printed Feb 18, 2025@23:19:49 Page 2
- FHORD2 ; HISC/REL/NCA - Review Diet Orders ;11/7/92 09:57
- +1 ;;5.5;DIETETICS;**1**;Jan 28, 2005
- F0 SET ALL=0
- DO ^FHDPA
- if 'DFN
- GOTO KIL
- if 'FHDFN
- GOTO KIL
- if '$DATA(^DGPM(ADM,0))
- GOTO F0
- +1 SET DTP=$PIECE(^DGPM(ADM,0),"^",1)
- DO DTP^FH
- F01 WRITE !!,"List Orders from Date/Time: "_DTP_" // "
- READ X:DTIME
- if '$TEST!(X["^")
- GOTO KIL
- if X=""
- SET Y=0
- IF X'=""
- SET %DT="EXTS"
- DO ^%DT
- if Y<1
- GOTO F01
- +1 SET D4=Y
- DO CUR^FHORD7
- WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No current order")
- +2 IF Y'=""
- IF FHORD>0
- IF $DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
- WRITE !,"Comment: ",^(1)
- +3 SET X1=^FHPT(FHDFN,"A",ADM,0)
- SET DTP=$PIECE(X1,"^",3)
- IF DTP
- DO DTP^FH
- WRITE !,"Expires: ",DTP
- +4 SET TF=$PIECE(X1,"^",4)
- if TF<1
- GOTO F1
- +5 SET Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
- +6 SET DTP=$PIECE(Y,"^",1)
- SET COM=$PIECE(Y,"^",5)
- SET TQU=$PIECE(Y,"^",6)
- SET CAL=$PIECE(Y,"^",7)
- +7 DO DTP^FH
- WRITE !!,"Tubefeed Ordered: ",DTP
- +8 FOR TF2=0:0
- SET TF2=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2))
- if TF2<1
- QUIT
- SET XY=^(TF2,0)
- DO LP
- +9 WRITE !,"Total Quantity: ",TQU," ml",?42,"Total KCAL: ",CAL
- +10 if COM'=""
- WRITE !,"Comment: ",COM
- F1 SET CT=0
- FOR K=0:0
- SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"OO",K))
- if K<1
- QUIT
- SET X=^(K,0)
- IF $PIECE(X,"^",2)'<D4
- IF $PIECE(X,"^",5)="S"
- DO L1
- +1 SET N1=0
- FOR FHORD=0:0
- SET FHORD=$ORDER(^FHPT(FHDFN,"A",ADM,"DI",FHORD))
- if FHORD<1
- QUIT
- SET X=^(FHORD,0)
- DO LST
- +2 IF 'N1
- WRITE !!,"No Diet Orders Entered",!
- GOTO F0
- +3 DO TLN
- GOTO F0
- KIL KILL %,%DT,A1,ADM,ALL,C,CAL,COM,CT,D1,D2,D3,D4,DA,DTP,FHDFN,DFN,FHDU,FHLD,FHOR,I,K,KK,N1,NOW,FHORD,FHWF,FHPV,POP,TYP,TF,TF2,TQU,TUN,STR,QUA,WARD,X,X1,X2,XY,Y
- QUIT
- LP SET TUN=$PIECE(XY,"^",1)
- SET STR=$PIECE(XY,"^",2)
- SET QUA=$PIECE(XY,"^",3)
- +1 IF QUA["CC"
- SET QUAFI=$PIECE(QUA,"CC",1)
- SET QUASE=$PIECE(QUA,"CC",2)
- SET QUA=QUAFI_"ML"_QUASE
- +2 WRITE !,"Product: ",$PIECE($GET(^FH(118.2,TUN,0)),"^",1),", ",$SELECT(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA
- QUIT
- L1 IF 'CT
- WRITE !!,"Saved Additional Orders:",!
- SET CT=1
- +1 SET DTP=$PIECE(X,"^",2)
- DO DTP^FH
- WRITE !,DTP,?20,$PIECE(X,"^",3)
- QUIT
- LST SET COM=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
- if $PIECE(X,"^",9)<D4
- QUIT
- +1 IF 'N1
- WRITE !!," Effective Expires Type Order",!
- +2 SET FHOR=$PIECE(X,"^",2,6)
- SET FHLD=$PIECE(X,"^",7)
- SET D1=$PIECE(X,"^",9)
- SET D2=$PIECE(X,"^",10)
- SET TYP=$PIECE(X,"^",8)
- SET D3=$PIECE(X,"^",12)
- SET N1=N1+1
- +3 SET DTP=D1
- DO DTP^FH
- WRITE !,DTP
- IF D2
- SET DTP=D2
- DO DTP^FH
- WRITE ?20,DTP
- +4 WRITE ?40,TYP,?44
- DO ORD
- IF $LENGTH(Y)<36
- WRITE Y
- +5 IF '$TEST
- WRITE $PIECE(Y,", ",1,3)
- if $PIECE(Y,", ",4)'=""
- WRITE ",",!?44,$PIECE(Y,", ",4,5)
- +6 if COM'=""
- WRITE !?44,COM
- QUIT
- ORD SET Y=""
- IF FHLD'=""
- SET FHDU=";"_$PIECE(^DD(115.02,6,0),"^",3)
- SET %=$FIND(FHDU,";"_FHLD_":")
- if %<1
- QUIT
- SET Y=$PIECE($EXTRACT(FHDU,%,999),";",1)
- QUIT
- +1 FOR A1=1:1:5
- SET D3=$PIECE(FHOR,"^",A1)
- IF D3
- if Y'=""
- SET Y=Y_", "
- SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
- +2 QUIT
- TLN WRITE !!?24,"----- Diet Orders Time Line -----",!," Effective Type Order",!
- +1 FOR KK=0:0
- SET KK=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",KK))
- if KK<1
- QUIT
- SET FHORD=$PIECE(^(KK,0),"^",2)
- DO T1
- +2 QUIT
- T1 SET X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
- if $PIECE(X,"^",9)<D4
- QUIT
- +1 SET FHOR=$PIECE(X,"^",2,6)
- SET FHLD=$PIECE(X,"^",7)
- SET TYP=$PIECE(X,"^",8)
- +2 SET DTP=KK
- DO DTP^FH
- WRITE !,DTP,?20,TYP,?24
- DO ORD
- IF $LENGTH(Y)<56
- WRITE Y
- QUIT
- +3 WRITE $PIECE(Y,", ",1,4),",",!?24,$PIECE(Y,", ",5)
- QUIT
