FHOMRE1 ;Hines OIFO/RTK-OUTPATIENT MEALS EARLY/LATE TRAY ;5/20/03 08:35
;;5.5;DIETETICS;**2,11**;Jan 28, 2005;Build 4
;
;09/08/2006 KAM/BAY Remedy Call 149576 - Add check for provide bagged meal
;
S FHMSG1="E" D EN1,END Q
EN1 D GETOPT^FHOMUTL I FHFIND=0 Q
K NUM D DISP^FHOMRR1 I $G(NUM)="" Q
EL1 K DIR S DIR(0)="NAO^1:"_NUM,DIR("A")="Early/Late Tray For Which Order? "
D ^DIR Q:$D(DIRUT)
S FHRMSEL=Y,FHC=FHRMSEL,FHRNUM=$P(FHLIST(FHRMSEL),U,1)
S FHRMDT=$P(FHLIST(FHRMSEL),U,2),Y=FHRMDT D DD^%DT W !,Y,!
I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" W !!?3,"The selected order has been cancelled!",! D EL1 Q
I $D(^FHPT(FHDFN,"OP",FHRNUM,2)) W !,"Early/Late Tray already exists for this meal." K DIR S DIR(0)="YA",DIR("A")="Do you wish to overwrite? ",DIR("B")="N" D ^DIR Q:$D(DIRUT) Q:Y'=1
; Only allow selection of one order at a time, rather than a range
; because they could be different meals which could have different
; allowable meal window times.
K DIR S DIR(0)="SAO^E:EARLY;L:LATE",DIR("A")="Early or Late (E or L)? "
D ^DIR I $D(DIRUT) D EXMSG^FHOMUTL Q
S FHEL=Y
ORD S FHLOC=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3),FHORN="",FHMSG1="E"
S FHDIET=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,2)
S FHCOMM=$P($G(^FH(119.6,FHLOC,0)),U,8),FHCOMM1=$G(^FH(119.73,FHCOMM,1))
S FHMEAL=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
S FH1=$S(FHMEAL="B":1,FHMEAL="N":7,1:13) I FHEL="L" S FH1=FH1+3
TIME S FH3=FH1+2,FHCNT=0 F FHT=FH1:1:FH3 D
.I $P(FHCOMM1,U,FHT)="" Q
.S FHCNT=FHCNT+1,FHTM(FHCNT)=$P(FHCOMM1,U,FHT)
W !,"Select Time: ( " F J=1:1:FHCNT W J,"=",FHTM(J)," "
R ") ",FHS:DTIME I FHS=""!(FHS["^") D EXMSG^FHOMUTL Q
I (FHS'?1N)!(FHS<1)!(FHS>FHCNT) W !!,"Invalid time selection!" D TIME Q
S FHTIME=FHTM(FHS),X=FHRMDT_"@"_FHTIME,%DT="XT" D ^%DT S FHDTM=Y
D NOW^%DTC I FHDTM<% W !!,"Cannot order for a Date/Time before now!" D TIME Q
;09/08/2006 KAM/BAY Rem Call 149576 Check file 119.73 PROVIDE BAGGED MEAL
;
S FHBAG="N" I $P($G(^FH(119.73,FHCOMM,2)),U,10)="Y" D
. K DIR S DIR(0)="SAO^Y:Yes;N:No",DIR("A")="Bagged Meal? ",DIR("B")="N"
. D ^DIR I $D(DIRUT) D EXMSG^FHOMUTL Q
. S FHBAG=Y
D SET,UPD100,OKMSG^FHOMUTL,END Q
;
SET S DA=FHRNUM,DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"","
S FHORN=$S($G(FHORN)="":"",1:FHORN)
D NOW^%DTC S FHTODAY=$E(%,1,12)
S DR="14////^S X=FHTIME;15////^S X=FHBAG;16////^S X=DUZ;17////^S X=FHTODAY;17.5////^S X=FHORN;17.6////^S X=""@""" D ^DIE
S FHACT="O",FHOPTY="E",FHAET=FHTIME D SETAET^FHOMRO2
Q
END K A,FHFIND,FHCLST,FHC,FHCOMM,FH1,FH3,FHTEXT,NUM
K FHSEL,FHT,FHCNT,FHCOMM1,FHS Q
Q
HL7SET ;
; Entry point for E/L trays placed from CPRS/OERR
S (FHRFLG,FHSFLG)=0,FHMEAL=$E(FHSVCP,1),FILL=""
S FHEL=$E(FHSVCP,2),FHTM=$E(FHSVCP,3)
I FHEL'?1"E",FHEL'?1"L" S TXT="Missing E/L" D GETOR^FHWOR,ERR^FHOMWOR Q
I FHTM<1!(FHTM>3) S TXT="Invalid time" D GETOR^FHWOR,ERR^FHOMWOR Q
S FHRMDT=STDT,ENDT=FHRMDT_.9999
S FH1=$S(FHMEAL="B":1,FHMEAL="N":7,1:13) I FHEL="L" S FH1=FH1+3
S FH1=FH1+FHTM-1
S FHCOMM=$P($G(^FH(119.6,FHLOC,0)),U,8),FHCOMM1=$G(^FH(119.73,FHCOMM,1))
S FHTIME=$P(FHCOMM1,U,FH1),X1=STDT,X2=-1 D C^%DTC S STDT1=X
RM ; Check recurring meals
I '$D(^FHPT(FHDFN,"OP","B",FHRMDT)) D SM Q
F FHRMDT=STDT1:0 S FHRMDT=$O(^FHPT(FHDFN,"OP","B",FHRMDT)) Q:FHRMDT'>0!(FHRMDT>ENDT) F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM)) Q:FHRNUM'>0 D
.Q:$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL
.Q:$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
.S FHRNUM1=FHRNUM,FHRFLG=1 D SET Q
S FILL="E;"_$G(FHRNUM1)
SM ; Check special meals
F FHSMDT=STDT:0 S FHSMDT=$O(^FHPT(FHDFN,"SM",FHSMDT)) Q:FHSMDT'>0!(FHSMDT>ENDT) D SETELSM
;
I FHRFLG=0,FHSFLG=0 D REJECT Q
I FILL="" D REJECT Q
D SEND^FHWOR
Q
SETELSM ; Set E/L for Special Meals
Q:$P($G(^FHPT(FHDFN,"SM",FHSMDT,0)),U,9)'=FHMEAL
S FHSFLG=1,DA=FHSMDT,DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""SM"","
D NOW^%DTC S FHTODAY=$E(%,1,12)
S FHORN=$S($G(FHORN)="":"",1:FHORN),FILL="G;"_FHSMDT
S DR="8////^S X=FHTIME;9////^S X=FHBAG;10////^S X=DUZ;11////^S X=FHORN" D ^DIE
S FHZN=$G(^FHPT(FHDFN,"SM",FHSMDT,0))
S FHACT="O",FHOPTY="S",FHSTAT="",FHOPDT=FHTODAY D SETSM^FHOMRO2
Q
REJECT ; Reject if no recurring or special meals found
S TXT="No Recurring or Special Meal ordered for this date/meal"
D GETOR^FHWOR,ERR^FHOMWOR Q
Q
UPD100 ;Backdoor message to update file #100 with a new EL order
Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
Q:'DFN K MSG D MSHOM^FHOMUTL ;Sets MSG(1), MSG(2) & MSG(3) for OM
S FILL="E;"_FHRNUM,FHODT=$$FMTHL7^XLFDT(FHRMDT)
S FHOMELN=FHMEAL_FHEL_FHS,FHOBAG="" I FHBAG="Y" S FHOBAG="bagged"
S MSG(4)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"^"_FHODT_"||||||||"_FHTODAY
S MSG(5)="ODT|"_$S(FHEL="E":"EARLY",1:"LATE")_"|^^^"_FHOMELN_"^^99FHD|"_FHOBAG
D EVSEND^FHWOR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMRE1 4831 printed Dec 13, 2024@01:52:56 Page 2
FHOMRE1 ;Hines OIFO/RTK-OUTPATIENT MEALS EARLY/LATE TRAY ;5/20/03 08:35
+1 ;;5.5;DIETETICS;**2,11**;Jan 28, 2005;Build 4
+2 ;
+3 ;09/08/2006 KAM/BAY Remedy Call 149576 - Add check for provide bagged meal
+4 ;
+5 SET FHMSG1="E"
DO EN1
DO END
QUIT
EN1 DO GETOPT^FHOMUTL
IF FHFIND=0
QUIT
+1 KILL NUM
DO DISP^FHOMRR1
IF $GET(NUM)=""
QUIT
EL1 KILL DIR
SET DIR(0)="NAO^1:"_NUM
SET DIR("A")="Early/Late Tray For Which Order? "
+1 DO ^DIR
if $DATA(DIRUT)
QUIT
+2 SET FHRMSEL=Y
SET FHC=FHRMSEL
SET FHRNUM=$PIECE(FHLIST(FHRMSEL),U,1)
+3 SET FHRMDT=$PIECE(FHLIST(FHRMSEL),U,2)
SET Y=FHRMDT
DO DD^%DT
WRITE !,Y,!
+4 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
WRITE !!?3,"The selected order has been cancelled!",!
DO EL1
QUIT
+5 IF $DATA(^FHPT(FHDFN,"OP",FHRNUM,2))
WRITE !,"Early/Late Tray already exists for this meal."
KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Do you wish to overwrite? "
SET DIR("B")="N"
DO ^DIR
if $DATA(DIRUT)
QUIT
if Y'=1
QUIT
+6 ; Only allow selection of one order at a time, rather than a range
+7 ; because they could be different meals which could have different
+8 ; allowable meal window times.
+9 KILL DIR
SET DIR(0)="SAO^E:EARLY;L:LATE"
SET DIR("A")="Early or Late (E or L)? "
+10 DO ^DIR
IF $DATA(DIRUT)
DO EXMSG^FHOMUTL
QUIT
+11 SET FHEL=Y
ORD SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3)
SET FHORN=""
SET FHMSG1="E"
+1 SET FHDIET=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,2)
+2 SET FHCOMM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
SET FHCOMM1=$GET(^FH(119.73,FHCOMM,1))
+3 SET FHMEAL=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
+4 SET FH1=$SELECT(FHMEAL="B":1,FHMEAL="N":7,1:13)
IF FHEL="L"
SET FH1=FH1+3
TIME SET FH3=FH1+2
SET FHCNT=0
FOR FHT=FH1:1:FH3
Begin DoDot:1
+1 IF $PIECE(FHCOMM1,U,FHT)=""
QUIT
+2 SET FHCNT=FHCNT+1
SET FHTM(FHCNT)=$PIECE(FHCOMM1,U,FHT)
End DoDot:1
+3 WRITE !,"Select Time: ( "
FOR J=1:1:FHCNT
WRITE J,"=",FHTM(J)," "
+4 READ ") ",FHS:DTIME
IF FHS=""!(FHS["^")
DO EXMSG^FHOMUTL
QUIT
+5 IF (FHS'?1N)!(FHS<1)!(FHS>FHCNT)
WRITE !!,"Invalid time selection!"
DO TIME
QUIT
+6 SET FHTIME=FHTM(FHS)
SET X=FHRMDT_"@"_FHTIME
SET %DT="XT"
DO ^%DT
SET FHDTM=Y
+7 DO NOW^%DTC
IF FHDTM<%
WRITE !!,"Cannot order for a Date/Time before now!"
DO TIME
QUIT
+8 ;09/08/2006 KAM/BAY Rem Call 149576 Check file 119.73 PROVIDE BAGGED MEAL
+9 ;
+10 SET FHBAG="N"
IF $PIECE($GET(^FH(119.73,FHCOMM,2)),U,10)="Y"
Begin DoDot:1
+11 KILL DIR
SET DIR(0)="SAO^Y:Yes;N:No"
SET DIR("A")="Bagged Meal? "
SET DIR("B")="N"
+12 DO ^DIR
IF $DATA(DIRUT)
DO EXMSG^FHOMUTL
QUIT
+13 SET FHBAG=Y
End DoDot:1
+14 DO SET
DO UPD100
DO OKMSG^FHOMUTL
DO END
QUIT
+15 ;
SET SET DA=FHRNUM
SET DA(1)=FHDFN
SET DIE="^FHPT("_DA(1)_",""OP"","
+1 SET FHORN=$SELECT($GET(FHORN)="":"",1:FHORN)
+2 DO NOW^%DTC
SET FHTODAY=$EXTRACT(%,1,12)
+3 SET DR="14////^S X=FHTIME;15////^S X=FHBAG;16////^S X=DUZ;17////^S X=FHTODAY;17.5////^S X=FHORN;17.6////^S X=""@"""
DO ^DIE
+4 SET FHACT="O"
SET FHOPTY="E"
SET FHAET=FHTIME
DO SETAET^FHOMRO2
+5 QUIT
END KILL A,FHFIND,FHCLST,FHC,FHCOMM,FH1,FH3,FHTEXT,NUM
+1 KILL FHSEL,FHT,FHCNT,FHCOMM1,FHS
QUIT
+2 QUIT
HL7SET ;
+1 ; Entry point for E/L trays placed from CPRS/OERR
+2 SET (FHRFLG,FHSFLG)=0
SET FHMEAL=$EXTRACT(FHSVCP,1)
SET FILL=""
+3 SET FHEL=$EXTRACT(FHSVCP,2)
SET FHTM=$EXTRACT(FHSVCP,3)
+4 IF FHEL'?1"E"
IF FHEL'?1"L"
SET TXT="Missing E/L"
DO GETOR^FHWOR
DO ERR^FHOMWOR
QUIT
+5 IF FHTM<1!(FHTM>3)
SET TXT="Invalid time"
DO GETOR^FHWOR
DO ERR^FHOMWOR
QUIT
+6 SET FHRMDT=STDT
SET ENDT=FHRMDT_.9999
+7 SET FH1=$SELECT(FHMEAL="B":1,FHMEAL="N":7,1:13)
IF FHEL="L"
SET FH1=FH1+3
+8 SET FH1=FH1+FHTM-1
+9 SET FHCOMM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
SET FHCOMM1=$GET(^FH(119.73,FHCOMM,1))
+10 SET FHTIME=$PIECE(FHCOMM1,U,FH1)
SET X1=STDT
SET X2=-1
DO C^%DTC
SET STDT1=X
RM ; Check recurring meals
+1 IF '$DATA(^FHPT(FHDFN,"OP","B",FHRMDT))
DO SM
QUIT
+2 FOR FHRMDT=STDT1:0
SET FHRMDT=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT))
if FHRMDT'>0!(FHRMDT>ENDT)
QUIT
FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM))
if FHRNUM'>0
QUIT
Begin DoDot:1
+3 if $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL
QUIT
+4 if $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
QUIT
+5 SET FHRNUM1=FHRNUM
SET FHRFLG=1
DO SET
QUIT
End DoDot:1
+6 SET FILL="E;"_$GET(FHRNUM1)
SM ; Check special meals
+1 FOR FHSMDT=STDT:0
SET FHSMDT=$ORDER(^FHPT(FHDFN,"SM",FHSMDT))
if FHSMDT'>0!(FHSMDT>ENDT)
QUIT
DO SETELSM
+2 ;
+3 IF FHRFLG=0
IF FHSFLG=0
DO REJECT
QUIT
+4 IF FILL=""
DO REJECT
QUIT
+5 DO SEND^FHWOR
+6 QUIT
SETELSM ; Set E/L for Special Meals
+1 if $PIECE($GET(^FHPT(FHDFN,"SM",FHSMDT,0)),U,9)'=FHMEAL
QUIT
+2 SET FHSFLG=1
SET DA=FHSMDT
SET DA(1)=FHDFN
SET DIE="^FHPT("_DA(1)_",""SM"","
+3 DO NOW^%DTC
SET FHTODAY=$EXTRACT(%,1,12)
+4 SET FHORN=$SELECT($GET(FHORN)="":"",1:FHORN)
SET FILL="G;"_FHSMDT
+5 SET DR="8////^S X=FHTIME;9////^S X=FHBAG;10////^S X=DUZ;11////^S X=FHORN"
DO ^DIE
+6 SET FHZN=$GET(^FHPT(FHDFN,"SM",FHSMDT,0))
+7 SET FHACT="O"
SET FHOPTY="S"
SET FHSTAT=""
SET FHOPDT=FHTODAY
DO SETSM^FHOMRO2
+8 QUIT
REJECT ; Reject if no recurring or special meals found
+1 SET TXT="No Recurring or Special Meal ordered for this date/meal"
+2 DO GETOR^FHWOR
DO ERR^FHOMWOR
QUIT
+3 QUIT
UPD100 ;Backdoor message to update file #100 with a new EL order
+1 ;must have CPRSv26 for O.M. backdoor
if '$$PATCH^XPDUTL("OR*3.0*215")
QUIT
+2 ;Sets MSG(1), MSG(2) & MSG(3) for OM
if 'DFN
QUIT
KILL MSG
DO MSHOM^FHOMUTL
+3 SET FILL="E;"_FHRNUM
SET FHODT=$$FMTHL7^XLFDT(FHRMDT)
+4 SET FHOMELN=FHMEAL_FHEL_FHS
SET FHOBAG=""
IF FHBAG="Y"
SET FHOBAG="bagged"
+5 SET MSG(4)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"^"_FHODT_"||||||||"_FHTODAY
+6 SET MSG(5)="ODT|"_$SELECT(FHEL="E":"EARLY",1:"LATE")_"|^^^"_FHOMELN_"^^99FHD|"_FHOBAG
+7 DO EVSEND^FHWOR
+8 QUIT
