- 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 Feb 18, 2025@23:20:07 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
