FHORE1 ; HISC/REL - Early/Late Trays ;8/8/96 13:57 ;
;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL D F1 G:'$D(DFN) KIL G:'$D(FHDFN) KIL I 'FHWF S FHORN="" D ^FHORE1A G KIL
; Set HL7
S FHORN="" D ^FHORE1A I FHDAY D EL^FHWOR3 D KIL I $D(MSG) D MSG^XQOR("FH EVSEND OR",.MSG) K MSG
Q
F1 ; Process order
D NOW^%DTC S NOW=%,DT=NOW\1 K %
S X1=DT,X2=31 D C^%DTC S X31=X
F2 W ! D ALG^FHCLN W !,"Allergies: ",$S(ALG="":"None on file",1:ALG)
S %DT="AEX",%DT("A")="Select Start Date: " D ^%DT K %DT G AB:U[X!$D(DTOUT),F2:Y<1 S SDT=+Y\1 I SDT<DT G F15
I SDT>X31 W *7,!," [ Cannot schedule more than 31 days in the future ]" G F2
F3 S DTP=SDT D DTP^FH
S %DT="AEX",%DT("A")="Select End Date: "_DTP_"// " D ^%DT K %DT G AB:X["^"!$D(DTOUT) S:X="" Y=SDT G F3:Y<1 S EDT=+Y\1
S WKD="" G:SDT=EDT F6 I EDT<SDT W *7," [ End before Start? ] " G F2
I EDT>X31 W *7,!," [ Cannot schedule for more than 31 days in the future ]" G F3
OK W !!?10,"Mon Tues Wed Thur Fri Sat Sun"
W !?10," M T W R F S X"
W !!,"Enter string of characters for desired days of week: e.g., MWF",!
F4 R !,"Days of Week: ",WKD:DTIME G:'$T!("^"[WKD) AB S X=WKD D TR^FH S WKD=X
S X1="" F K=1:1 S Z=$E(WKD,K) Q:Z="" G:X1[Z F16 S X1=X1_Z I "MTWRFSX"'[Z W !,"Please enter the desired days of the week." G OK
F6 R !,"Select Meal (B,N,E): ",MEAL:DTIME G:'$T!("^"[MEAL) AB S X=MEAL D TR^FH S MEAL=X
I "BNE"'[MEAL!(MEAL'?1U) W *7,!,"Enter B for Breakfast, N for Noon , or E for Evening" G F6
G:SDT'=EDT F7 F K=SDT:0 S K=$O(^FHPT(FHDFN,"A",ADM,"EL",K)) Q:K<1!(K\1'=SDT) I $P(^(K,0),"^",2)=MEAL W *7,!!,"Early/Late Meal Already Ordered for this Date!" G AB
F7 R !,"Early or Late (E or L): ",X1:DTIME G AB:'$T!("^"[X1)
I "el"[X1 S X=X1 D TR^FH S X1=X
I X1'="E",X1'="L" W *7,!,"Enter E for early tray, L for late tray" G F7
S SERV=X1 D DP S K=$S(MEAL="B":0,MEAL="N":6,1:12)+(X1="L"*3)
K N S K2=0 F K1=K+1:1:K+3 S X2=$P(Y,"^",K1) I X2'="" S K2=K2+1,N(K2)=X2
I 'K2 W *7,!!,"No Early/Late Delivery Times -- Notify Dietetics" G AB
I K2=1 S K1=1 G F9
F8 W !,"Select Time: ( " F K1=1:1:K2 W K1,"=",N(K1)," "
R ") ",K1:DTIME G AB:'$T!("^"[K1) I K1<1!(K1>K2)!(K1'?1N) W *7,!,"Enter the number of the desired time" G F8
F9 S TIM=N(K1),X=SDT_"@"_TIM,%DT="XT",NUM=K1 D ^%DT S (SDT,DTE)=Y,EDT=EDT+(SDT#1) G F10:SDT'=EDT,F15:DTE<NOW
D CUR I FHLD'="" W *7,!!,"Patient is on a WITHHOLD ORDER at that time!" G AB
I "^^^^"[FHOR W *7,!!,"Patient has NO DIET ORDER at that time!" G AB
F10 S BAG="N" I $P(FHPAR,"^",10)'="N" R !,"Bagged Meal: NO// ",BAG:DTIME G:'$T!(BAG=U) AB S:BAG="" BAG="N" S X=BAG D TR^FH S BAG=X I $P("YES",BAG,1)'="",$P("NO",BAG,1)'="" W *7," Enter Y or N" G F10
S BAG=$E(BAG,1) W !?5 Q
DP S Y="" S W1=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8),DP=$P($G(^FH(119.6,+W1,0)),"^",8)
S Y=$G(^FH(119.73,+DP,1)),FHPAR=$G(^FH(119.73,+DP,2)) Q
F15 W *7,!!,"Cannot Order a Meal for a Date/Time before now!" G AB
F16 W *7,!," Error - Illegal character or repeated day" G F4
DTP ; Printable Date
Q:Y<1 S Y=$J(+$E(Y,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(Y,4,5))_"-"_$E(Y,2,3) Q
CUR S A1=0,(FHOR,FHLD)="" F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1!(KK>DTE) S A1=KK
Q:'A1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2),X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7) Q
AB W *7,!!,"Early/Late Tray operation TERMINATED - No change!"
KIL K %,%H,%I,%T,%DT,A1,ADM,ALL,BAG,C,DA,FHDFN,DFN,DP,DTE,DTP,EDT,FHDAY,FHLD,FHOR,FHPAR,FHWF,FHPV,I,K,K1,K2,KK,MEAL,N,NUM,NOW,FHORN,FHORD,SDT,SERV,TIM,WARD,WKD,X,X1,X2,X31,Y,Z Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORE1 3648 printed Sep 23, 2025@19:29:45 Page 2
FHORE1 ; HISC/REL - Early/Late Trays ;8/8/96 13:57 ;
+1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
+2 SET ALL=0
DO ^FHDPA
if 'DFN
GOTO KIL
if 'FHDFN
GOTO KIL
DO F1
if '$DATA(DFN)
GOTO KIL
if '$DATA(FHDFN)
GOTO KIL
IF 'FHWF
SET FHORN=""
DO ^FHORE1A
GOTO KIL
+3 ; Set HL7
+4 SET FHORN=""
DO ^FHORE1A
IF FHDAY
DO EL^FHWOR3
DO KIL
IF $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
+5 QUIT
F1 ; Process order
+1 DO NOW^%DTC
SET NOW=%
SET DT=NOW\1
KILL %
+2 SET X1=DT
SET X2=31
DO C^%DTC
SET X31=X
F2 WRITE !
DO ALG^FHCLN
WRITE !,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG)
+1 SET %DT="AEX"
SET %DT("A")="Select Start Date: "
DO ^%DT
KILL %DT
if U[X!$DATA(DTOUT)
GOTO AB
if Y<1
GOTO F2
SET SDT=+Y\1
IF SDT<DT
GOTO F15
+2 IF SDT>X31
WRITE *7,!," [ Cannot schedule more than 31 days in the future ]"
GOTO F2
F3 SET DTP=SDT
DO DTP^FH
+1 SET %DT="AEX"
SET %DT("A")="Select End Date: "_DTP_"// "
DO ^%DT
KILL %DT
if X["^"!$DATA(DTOUT)
GOTO AB
if X=""
SET Y=SDT
if Y<1
GOTO F3
SET EDT=+Y\1
+2 SET WKD=""
if SDT=EDT
GOTO F6
IF EDT<SDT
WRITE *7," [ End before Start? ] "
GOTO F2
+3 IF EDT>X31
WRITE *7,!," [ Cannot schedule for more than 31 days in the future ]"
GOTO F3
OK WRITE !!?10,"Mon Tues Wed Thur Fri Sat Sun"
+1 WRITE !?10," M T W R F S X"
+2 WRITE !!,"Enter string of characters for desired days of week: e.g., MWF",!
F4 READ !,"Days of Week: ",WKD:DTIME
if '$TEST!("^"[WKD)
GOTO AB
SET X=WKD
DO TR^FH
SET WKD=X
+1 SET X1=""
FOR K=1:1
SET Z=$EXTRACT(WKD,K)
if Z=""
QUIT
if X1[Z
GOTO F16
SET X1=X1_Z
IF "MTWRFSX"'[Z
WRITE !,"Please enter the desired days of the week."
GOTO OK
F6 READ !,"Select Meal (B,N,E): ",MEAL:DTIME
if '$TEST!("^"[MEAL)
GOTO AB
SET X=MEAL
DO TR^FH
SET MEAL=X
+1 IF "BNE"'[MEAL!(MEAL'?1U)
WRITE *7,!,"Enter B for Breakfast, N for Noon , or E for Evening"
GOTO F6
+2 if SDT'=EDT
GOTO F7
FOR K=SDT:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"EL",K))
if K<1!(K\1'=SDT)
QUIT
IF $PIECE(^(K,0),"^",2)=MEAL
WRITE *7,!!,"Early/Late Meal Already Ordered for this Date!"
GOTO AB
F7 READ !,"Early or Late (E or L): ",X1:DTIME
if '$TEST!("^"[X1)
GOTO AB
+1 IF "el"[X1
SET X=X1
DO TR^FH
SET X1=X
+2 IF X1'="E"
IF X1'="L"
WRITE *7,!,"Enter E for early tray, L for late tray"
GOTO F7
+3 SET SERV=X1
DO DP
SET K=$SELECT(MEAL="B":0,MEAL="N":6,1:12)+(X1="L"*3)
+4 KILL N
SET K2=0
FOR K1=K+1:1:K+3
SET X2=$PIECE(Y,"^",K1)
IF X2'=""
SET K2=K2+1
SET N(K2)=X2
+5 IF 'K2
WRITE *7,!!,"No Early/Late Delivery Times -- Notify Dietetics"
GOTO AB
+6 IF K2=1
SET K1=1
GOTO F9
F8 WRITE !,"Select Time: ( "
FOR K1=1:1:K2
WRITE K1,"=",N(K1)," "
+1 READ ") ",K1:DTIME
if '$TEST!("^"[K1)
GOTO AB
IF K1<1!(K1>K2)!(K1'?1N)
WRITE *7,!,"Enter the number of the desired time"
GOTO F8
F9 SET TIM=N(K1)
SET X=SDT_"@"_TIM
SET %DT="XT"
SET NUM=K1
DO ^%DT
SET (SDT,DTE)=Y
SET EDT=EDT+(SDT#1)
if SDT'=EDT
GOTO F10
if DTE<NOW
GOTO F15
+1 DO CUR
IF FHLD'=""
WRITE *7,!!,"Patient is on a WITHHOLD ORDER at that time!"
GOTO AB
+2 IF "^^^^"[FHOR
WRITE *7,!!,"Patient has NO DIET ORDER at that time!"
GOTO AB
F10 SET BAG="N"
IF $PIECE(FHPAR,"^",10)'="N"
READ !,"Bagged Meal: NO// ",BAG:DTIME
if '$TEST!(BAG=U)
GOTO AB
if BAG=""
SET BAG="N"
SET X=BAG
DO TR^FH
SET BAG=X
IF $PIECE("YES",BAG,1)'=""
IF $PIECE("NO",BAG,1)'=""
WRITE *7," Enter Y or N"
GOTO F10
+1 SET BAG=$EXTRACT(BAG,1)
WRITE !?5
QUIT
DP SET Y=""
SET W1=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
SET DP=$PIECE($GET(^FH(119.6,+W1,0)),"^",8)
+1 SET Y=$GET(^FH(119.73,+DP,1))
SET FHPAR=$GET(^FH(119.73,+DP,2))
QUIT
F15 WRITE *7,!!,"Cannot Order a Meal for a Date/Time before now!"
GOTO AB
F16 WRITE *7,!," Error - Illegal character or repeated day"
GOTO F4
DTP ; Printable Date
+1 if Y<1
QUIT
SET Y=$JUSTIFY(+$EXTRACT(Y,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(Y,4,5))_"-"_$EXTRACT(Y,2,3)
QUIT
CUR SET A1=0
SET (FHOR,FHLD)=""
FOR KK=0:0
SET KK=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",KK))
if KK<1!(KK>DTE)
QUIT
SET A1=KK
+1 if 'A1
QUIT
SET FHORD=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
SET X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
SET FHOR=$PIECE(X,"^",2,6)
SET FHLD=$PIECE(X,"^",7)
QUIT
AB WRITE *7,!!,"Early/Late Tray operation TERMINATED - No change!"
KIL KILL %,%H,%I,%T,%DT,A1,ADM,ALL,BAG,C,DA,FHDFN,DFN,DP,DTE,DTP,EDT,FHDAY,FHLD,FHOR,FHPAR,FHWF,FHPV,I,K,K1,K2,KK,MEAL,N,NUM,NOW,FHORN,FHORD,SDT,SERV,TIM,WARD,WKD,X,X1,X2,X31,Y,Z
QUIT
