FHOMRO1 ;Hines OIFO/RTK RECURRING MEALS ORDER EDIT ;2/04/03 14:05
;;5.5;DIETETICS;**1,2,5,24**;Jan 28, 2005;Build 3
;
S FHDIET="" F FHDX=1:1:5 S FHDIETX(FHDX)=""
S FHMSG1="R",FHALL=0 D ^FHOMDPA I FHDFN="" Q
I '$D(^FHPT(FHDFN,0)) W !!,"UNKNOWN SELECTION !" Q
D NOW^%DTC S X1=$E(%,1,7),X2=-1 D C^%DTC S FHNOW=X D CHECK
I FHEXST=1 D ORDEDT,END Q
D ORDER,END Q
ORDEDT ;
W !!,"This person has an existing outpatient diet order."
K DIR S DIR(0)="SBO^E:Edit;O:New Order"
S DIR("A")="Edit the existing diet or order another one" D ^DIR
Q:$D(DIRUT)
I Y="O" D ORDER Q
I Y="E" D EDIT Q
Q
ORDER ;
W ! D OUTLOC^FHOMUTL I FHLOC="" D EXMSG^FHOMUTL Q
W ! D RMBED^FHOMUTL
DIETORD ;
I $P($G(^FH(119.6,FHLOC,1)),U,4)="Y" D MULTDT D:FHDIETX(1)="" EXMSG^FHOMUTL Q:FHDIETX(1)="" D DATE Q
D DIETLST^FHOMUTL I FHDEF="" W !!,"NO DEFAULT OUTPATIENT DIET SET!!",! Q
S FHDEF=$P($G(^FH(111,FHDEF,0)),U,1)
K DIC S DIC="^FH(111,",DIC("A")="Select DIET NAME: ",DIC(0)="AEMQZ"
S DIC("B")=FHDEF,DIC("S")="I $D(FHDIETS(+Y))" D ^DIC
I $D(DUOUT) D EXMSG^FHOMUTL Q
I Y=-1 D EXMSG^FHOMUTL Q
S FHDIET=+Y
DATE ;
K DIR S DIR("A")="Select Start Date: ",DIR(0)="DAO^DT" D ^DIR
I $D(DIRUT) D EXMSG^FHOMUTL Q
S (FHOSTDT,STDT)=Y S Y=STDT D DD^%DT W " ",Y
S FHMAX=$P($G(^FH(119.6,FHLOC,1)),U,2) I FHMAX="" S FHMAX=999
D NOW^%DTC S FHTODAY=$E(%,1,7),X1=FHTODAY,X2=FHMAX D C^%DTC S FHCUT=X
K DIR S DIR("A")="Select End Date: ",DIR(0)="DAO^"_STDT_":"_FHCUT D ^DIR
I $D(DIRUT) D EXMSG^FHOMUTL Q
S ENDT=Y S Y=ENDT D DD^%DT W " ",Y
DAYS ;
S FHIFLG=0 D SHDAYS
K DIR S DIR("A")="Select Days of Week: ",DIR(0)="FAO"
D ^DIR I $D(DIRUT) D EXMSG^FHOMUTL Q
S FHDAYS=Y D DAYCHK I FHIFLG=1 D DAYS Q
K DIR S DIR("A")="Select MEAL: "
S DIR(0)="SAO^B:Breakfast;N:Noon;E:Evening"
D ^DIR I $D(DIRUT) D EXMSG^FHOMUTL Q
S FHMEAL=Y W !
I STDT=DT S X=DT D H^%DTC I FHDAYS[$E("XMTWRFS",%Y+1) D CHECKSM I FHSMYES=1 D MSG1 S X1=STDT,X2=1 D C^%DTC S STDT=X I X>ENDT Q
K DIR S DIR("A")="Is this correct?: ",DIR(0)="YA",DIR("B")="Y" D ^DIR
S CONT=Y I CONT'=1 D EXMSG^FHOMUTL Q
S STDTMP=STDT,FHTDTMP=FHTODAY I STDT=DT D CHK1^FHOMRO2
D SETNODE,UPD100
I FHSETFLG=0 W !!!?5,"No meals ordered!",! Q
S FHMSG1="R" D OKMSG^FHOMUTL
S FHLTFLG=0 I STDTMP=FHTDTMP D CHK2^FHOMRO2
I FHLTFLG=1 F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHTODAY,FHRNUM)) Q:FHRNUM'>0 D
.I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL Q
.I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
.S FHEL="L",FHRMDT=FHTODAY D ORD^FHOMRE1
Q
SETNODE ;
S FHMPNUM=$O(^FHPT(FHDFN,"OP","C",""),-1),FHADSFF=0 I FHMPNUM="" S FHMPNUM=0
S FHMPNUM=FHMPNUM+1,FHSETFLG=0
K ODAYS S CCC=0,X1=STDT,X2=-1 D C^%DTC S STDT=X
S ENDL=0 F Q:ENDL=1 D
.S CCC=CCC+1,X1=STDT,X2=1 D C^%DTC S STDT=X
.I STDT>ENDT S ENDL=1 Q
.S X=STDT D DOW^%DTC
.I FHDAYS[$E("XMTWRFS",Y+1) S ODAYS(STDT)=STDT D SET
.Q
S FHACT="O",FHOPTY="R" D SETORX^FHOMRO2 ;creates RM events
I $G(FHDPATT)="",FHDIET'="@" S FHDPATT=FHDIET_"^^^^"
D SOSFFP^FHOMRO2 ;created diet related SO's, SF's, FP's
D SOEVNT^FHSPED ;creates so events
D SFEVNT^FHNO7 ;creates sf events
Q
SET ;
S FHPREVML=0 D PREV I FHPREVML=1 Q
S FHSETFLG=1
;I $O(^FHPT(FHDFN,"OP","B",STDT,FHRNUM)) Q:FHRNUM'>0 D
D CPRSO^FHSPED ;check previous SO
D CPRSF^FHNO7 ;check previous SF
S Y=STDT K DIC,DO S DA(1)=FHDFN,DIC="^FHPT("_DA(1)_",""OP"","
S DIC(0)="L" ;,DIC("P")=$P(^DD(115,16,0),U,2),X=+Y,DINUM=X
D FILE^DICN I Y=-1 Q
K DIE S DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"","
S FHORN=$S($G(FHORN)="":"",1:FHORN),DA=+Y
S DR="1////^S X=FHDIET;2////^S X=FHLOC;2.5////^S X=FHRMBD;3////^S X=FHMEAL;5////^S X=FHMPNUM;6////^S X=FHDIETX(1);7////^S X=FHDIETX(2);8////^S X=FHDIETX(3);9////^S X=FHDIETX(4);10////^S X=FHDIETX(5);.05////^S X=FHORN;24.5////^S X=DUZ" D ^DIE
S ADM=DA
D PPRSO^FHSPED ;process previous SO automatically to the new Recurring meal entry.
D PPRSF^FHNO7 ;process previous SF automatically.
Q
MULTDT ;
S FHDPATT="",FHDIET="@" F FHDX=1:1:5 S FHDIETX(FHDX)="@"
D ^FHOMRO3 I $O(FHDI(0))="" F FHDX=1:1:5 S FHDIETX(FHDX)="" Q
S FHDX=0 F FHD0=0:0 S FHD0=$O(FHDI(FHD0)) Q:FHD0="" S FHDX=FHDX+1,FHDIETX(FHDX)=$P(FHDI(FHD0),"^",1),FHDPATT=FHDPATT_FHDIETX(FHDX)_"^"
Q
SHDAYS ;
W !!," Mon Tues Wed Thur Fri Sat Sun"
W !," M T W R F S X"
W !!,"Enter string of characters for desired days of week: e.g., MWF",!
Q
DAYCHK ;
S X=FHDAYS D TR^FH S FHDAYS=X
S X1="" F K=1:1 S Z=$E(FHDAYS,K) Q:Z=""!(FHIFLG=1) D
.I X1[Z S FHIFLG=1 Q
.I "MTWRFSX"'[Z S FHIFLG=1 Q
.S X1=X1_Z Q
I FHIFLG=1 W !!,"Please enter the desired days of the week.",!
Q
PREV ;
F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",STDT,FHRNUM)) Q:FHRNUM'>0!(FHPREVML=1) D
.I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL Q
.I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
.D PATNAME^FHOMUTL S FHPREDT=$$FMTE^XLFDT(STDT,"P") I $G(FHHL7)'=1 D
..W !!?3,FHPTNM," ALREADY HAS A "
..W $S(FHMEAL="B":"BREAKFAST",FHMEAL="N":"NOON",1:"EVENING")
..W " MEAL ORDERED FOR ",FHPREDT
.S FHPREVML=1
Q
CHECK ;
S FHEXST=0 I $O(^FHPT(FHDFN,"OP","B",FHNOW)) D
.F FHRMDT=FHNOW:0 S FHRMDT=$O(^FHPT(FHDFN,"OP","B",FHRMDT)) Q:FHRMDT'>0 F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM)) Q:FHRNUM'>0 I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)'="C" S FHEXST=1
Q
CHECKSM ; Check if the OP has an existing SM for this date/meal
S FHSMYES=0
F FHZ=DT:0 S FHZ=$O(^FHPT(FHDFN,"SM","B",FHZ)) Q:FHZ'>0 D
.I $P($G(^FHPT(FHDFN,"SM",FHZ,0)),U,9)'=FHMEAL Q
.I $P($G(^FHPT(FHDFN,"SM",FHZ,0)),U,2)="C" Q
.I $P($G(^FHPT(FHDFN,"SM",FHZ,0)),U,2)="D" Q
.S FHSMYES=1
Q
MSG1 ;
W !!,"This patient already has a Special Meal ordered for "
S DTP=DT D DTP^FH W DTP," "
W $S(FHMEAL="B":"Breakfast",FHMEAL="N":"Noon",1:"Evening"),! H 1 Q
;
END ;Kill local variables before exiting
D KILL^FHOMRO2
Q
;
EDIT ;
D NOW^%DTC S STDT=$E(%,1,7),FHDTRLE=%
D DISP^FHOMRR1
EDT1 K DIR S DIR(0)="NAO^1:"_NUM,DIR("A")="Edit Which Order? " D ^DIR
Q:$D(DIRUT)
S ORDNUM=Y,Y=$P(FHLIST(ORDNUM),U,2) D DD^%DT W !,Y,!
S DA=$P(FHLIST(ORDNUM),U,1),DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"","
I $P($G(^FHPT(FHDFN,"OP",DA,0)),U,15)="C" W !!?3,"The selected order has been cancelled!",! D EDT1 Q
S FHLPT=$P($G(^FHPT(FHDFN,"OP",DA,0)),U,3),FHMEAL=$P($G(^FHPT(FHDFN,"OP",DA,0)),U,4)
D OUTLOC I FHLOC="" D UPXMSG^FHOMUTL Q
I $P($G(^FH(119.6,FHLOC,1)),U,4)="Y" D MULTDT D:FHDIETX(1)="" UPXMSG^FHOMUTL Q:FHDIETX(1)="" S FHDIET="@" D SETEDT Q
D DIETLST^FHOMUTL I FHDEF="" W !!,"NO DEFAULT OUTPATIENT DIET SET!!",! Q
S FHDEF2=$P($G(^FHPT(FHDFN,"OP",DA,0)),U,2) I FHDEF2'="" S FHDEF=$P($G(^FH(111,FHDEF2,0)),U,1)
K DIC S DIC="^FH(111,",DIC("A")="Select DIET NAME: ",DIC(0)="AEMQZ"
S DIC("B")=FHDEF,DIC("S")="I FHSPDTS[$P(^(0),U)" D ^DIC
I $D(DUOUT) D UPXMSG^FHOMUTL Q
I Y=-1 D UPXMSG^FHOMUTL Q
S FHDIET=+Y F FHDX=1:1:5 S FHDIETX(FHDX)="@"
SETEDT ;
W ! S FHZDA=DA,DR="2////^S X=FHLOC;1////^S X=FHDIET;6////^S X=FHDIETX(1);7////^S X=FHDIETX(2);8////^S X=FHDIETX(3);9////^S X=FHDIETX(4);10////^S X=FHDIETX(5);25////^S X=FHDTRLE;24.5////^S X=DUZ"
D ^DIE,UPDMSG^FHOMUTL,ED100
Q
OUTLOC ;Prompt for outpatient location - screen for ONLY Outpatient Locations
S FHLOC="",FHOUT="O"
K DIC S DIC="^FH(119.6,",DIC(0)="AEQZ",DIC("B")=FHLPT
S DIC("A")="Select OUTPATIENT LOCATION: "
S DIC("S")="I $P(^(0),U,3)=FHOUT" D ^DIC
Q:$D(DUOUT) I Y=-1 Q
S FHLOC=+Y I '$D(^FH(119.6,FHLOC,"L")) S FHLOC="" W !!,"The selected location does not have an Associated Hospital Location."
Q
UPD100 ;Backdoor message to update file #100 with a new RM 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
K N1 S FHODAYS=""
F N=1:1:7 S FH1=$E(FHDAYS,N) Q:FH1="" S M=$F("MTWRFSX",FH1)-1,N1(M)=""
F N=0:0 S N=$O(N1(N)) Q:N'>0 S FHODAYS=FHODAYS_"~QJ"_N
S FHODAYS=$E(FHODAYS,2,999)
S FHOMEAL=$S(FHMEAL="B":1,FHMEAL="N":3,FHMEAL="E":5,1:"")
I FHDIET'="@" S FHODNM=$P($G(^FH(111,FHDIET,0)),U,1)
S FHOSTDT=$$FMTHL7^XLFDT(FHOSTDT),FHOENDT=$$FMTHL7^XLFDT(ENDT)
S FHOTDAY=$$FMTHL7^XLFDT(FHTODAY)
S FILL="R;"_FHMPNUM_";"_FHOSTDT_";"_ENDT_";"_FHDAYS_";"_FHMEAL
S MSG(4)="ORC|SN||"_FILL_"^FH||||^"_FHODAYS_"^^"_FHOSTDT_"^"_FHOENDT_"||||||||"_FHOTDAY
I FHDIET'="@" S MSG(5)="ODS|D|"_FHOMEAL_"|^^^"_FHDIET_"^"_FHODNM_"^99FHD|"
I FHDIET="@" D
.F N=0:0 S N=$O(FHDIETX(N)) Q:N'>0 Q:FHDIETX(N)="" S FHODNM=$P($G(^FH(111,FHDIETX(N),0)),U,1),MSG(N+4)="ODS|D|"_FHOMEAL_"|^^^"_FHDIETX(N)_"^"_FHODNM_"^99FHD|"
D EVSEND^FHWOR
Q
ED100 ;Backdoor message to update file #100 with an edited RM 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 (FHOSTDT,FHOENDT)=$P($G(^FHPT(FHDFN,"OP",FHZDA,0)),U,1)
S FHOSTDT=$$FMTHL7^XLFDT(FHOSTDT),FHOENDT=$$FMTHL7^XLFDT(FHOENDT)
S FILL="RMEDIT;"_FHZDA,FHORN=$P($G(^FHPT(FHDFN,"OP",FHZDA,0)),U,12)
S FHODNM=$P($G(^FH(111,FHDIET,0)),U,1)
S FHOMEAL=$S(FHMEAL="B":1,FHMEAL="N":3,FHMEAL="E":5,1:"")
S MSG(4)="ORC|XX|"_FHORN_"^OR|"_FILL_"^FH||||^^^"_FHOSTDT_"^"_FHOENDT_"||||||||"
S MSG(5)="ODS|D|"_FHOMEAL_"|^^^"_FHDIET_"^"_FHODNM_"^99FHD|"
D EVSEND^FHWOR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMRO1 9344 printed Dec 13, 2024@01:52:59 Page 2
FHOMRO1 ;Hines OIFO/RTK RECURRING MEALS ORDER EDIT ;2/04/03 14:05
+1 ;;5.5;DIETETICS;**1,2,5,24**;Jan 28, 2005;Build 3
+2 ;
+3 SET FHDIET=""
FOR FHDX=1:1:5
SET FHDIETX(FHDX)=""
+4 SET FHMSG1="R"
SET FHALL=0
DO ^FHOMDPA
IF FHDFN=""
QUIT
+5 IF '$DATA(^FHPT(FHDFN,0))
WRITE !!,"UNKNOWN SELECTION !"
QUIT
+6 DO NOW^%DTC
SET X1=$EXTRACT(%,1,7)
SET X2=-1
DO C^%DTC
SET FHNOW=X
DO CHECK
+7 IF FHEXST=1
DO ORDEDT
DO END
QUIT
+8 DO ORDER
DO END
QUIT
ORDEDT ;
+1 WRITE !!,"This person has an existing outpatient diet order."
+2 KILL DIR
SET DIR(0)="SBO^E:Edit;O:New Order"
+3 SET DIR("A")="Edit the existing diet or order another one"
DO ^DIR
+4 if $DATA(DIRUT)
QUIT
+5 IF Y="O"
DO ORDER
QUIT
+6 IF Y="E"
DO EDIT
QUIT
+7 QUIT
ORDER ;
+1 WRITE !
DO OUTLOC^FHOMUTL
IF FHLOC=""
DO EXMSG^FHOMUTL
QUIT
+2 WRITE !
DO RMBED^FHOMUTL
DIETORD ;
+1 IF $PIECE($GET(^FH(119.6,FHLOC,1)),U,4)="Y"
DO MULTDT
if FHDIETX(1)=""
DO EXMSG^FHOMUTL
if FHDIETX(1)=""
QUIT
DO DATE
QUIT
+2 DO DIETLST^FHOMUTL
IF FHDEF=""
WRITE !!,"NO DEFAULT OUTPATIENT DIET SET!!",!
QUIT
+3 SET FHDEF=$PIECE($GET(^FH(111,FHDEF,0)),U,1)
+4 KILL DIC
SET DIC="^FH(111,"
SET DIC("A")="Select DIET NAME: "
SET DIC(0)="AEMQZ"
+5 SET DIC("B")=FHDEF
SET DIC("S")="I $D(FHDIETS(+Y))"
DO ^DIC
+6 IF $DATA(DUOUT)
DO EXMSG^FHOMUTL
QUIT
+7 IF Y=-1
DO EXMSG^FHOMUTL
QUIT
+8 SET FHDIET=+Y
DATE ;
+1 KILL DIR
SET DIR("A")="Select Start Date: "
SET DIR(0)="DAO^DT"
DO ^DIR
+2 IF $DATA(DIRUT)
DO EXMSG^FHOMUTL
QUIT
+3 SET (FHOSTDT,STDT)=Y
SET Y=STDT
DO DD^%DT
WRITE " ",Y
+4 SET FHMAX=$PIECE($GET(^FH(119.6,FHLOC,1)),U,2)
IF FHMAX=""
SET FHMAX=999
+5 DO NOW^%DTC
SET FHTODAY=$EXTRACT(%,1,7)
SET X1=FHTODAY
SET X2=FHMAX
DO C^%DTC
SET FHCUT=X
+6 KILL DIR
SET DIR("A")="Select End Date: "
SET DIR(0)="DAO^"_STDT_":"_FHCUT
DO ^DIR
+7 IF $DATA(DIRUT)
DO EXMSG^FHOMUTL
QUIT
+8 SET ENDT=Y
SET Y=ENDT
DO DD^%DT
WRITE " ",Y
DAYS ;
+1 SET FHIFLG=0
DO SHDAYS
+2 KILL DIR
SET DIR("A")="Select Days of Week: "
SET DIR(0)="FAO"
+3 DO ^DIR
IF $DATA(DIRUT)
DO EXMSG^FHOMUTL
QUIT
+4 SET FHDAYS=Y
DO DAYCHK
IF FHIFLG=1
DO DAYS
QUIT
+5 KILL DIR
SET DIR("A")="Select MEAL: "
+6 SET DIR(0)="SAO^B:Breakfast;N:Noon;E:Evening"
+7 DO ^DIR
IF $DATA(DIRUT)
DO EXMSG^FHOMUTL
QUIT
+8 SET FHMEAL=Y
WRITE !
+9 IF STDT=DT
SET X=DT
DO H^%DTC
IF FHDAYS[$EXTRACT("XMTWRFS",%Y+1)
DO CHECKSM
IF FHSMYES=1
DO MSG1
SET X1=STDT
SET X2=1
DO C^%DTC
SET STDT=X
IF X>ENDT
QUIT
+10 KILL DIR
SET DIR("A")="Is this correct?: "
SET DIR(0)="YA"
SET DIR("B")="Y"
DO ^DIR
+11 SET CONT=Y
IF CONT'=1
DO EXMSG^FHOMUTL
QUIT
+12 SET STDTMP=STDT
SET FHTDTMP=FHTODAY
IF STDT=DT
DO CHK1^FHOMRO2
+13 DO SETNODE
DO UPD100
+14 IF FHSETFLG=0
WRITE !!!?5,"No meals ordered!",!
QUIT
+15 SET FHMSG1="R"
DO OKMSG^FHOMUTL
+16 SET FHLTFLG=0
IF STDTMP=FHTDTMP
DO CHK2^FHOMRO2
+17 IF FHLTFLG=1
FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHTODAY,FHRNUM))
if FHRNUM'>0
QUIT
Begin DoDot:1
+18 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL
QUIT
+19 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
QUIT
+20 SET FHEL="L"
SET FHRMDT=FHTODAY
DO ORD^FHOMRE1
End DoDot:1
+21 QUIT
SETNODE ;
+1 SET FHMPNUM=$ORDER(^FHPT(FHDFN,"OP","C",""),-1)
SET FHADSFF=0
IF FHMPNUM=""
SET FHMPNUM=0
+2 SET FHMPNUM=FHMPNUM+1
SET FHSETFLG=0
+3 KILL ODAYS
SET CCC=0
SET X1=STDT
SET X2=-1
DO C^%DTC
SET STDT=X
+4 SET ENDL=0
FOR
if ENDL=1
QUIT
Begin DoDot:1
+5 SET CCC=CCC+1
SET X1=STDT
SET X2=1
DO C^%DTC
SET STDT=X
+6 IF STDT>ENDT
SET ENDL=1
QUIT
+7 SET X=STDT
DO DOW^%DTC
+8 IF FHDAYS[$EXTRACT("XMTWRFS",Y+1)
SET ODAYS(STDT)=STDT
DO SET
+9 QUIT
End DoDot:1
+10 ;creates RM events
SET FHACT="O"
SET FHOPTY="R"
DO SETORX^FHOMRO2
+11 IF $GET(FHDPATT)=""
IF FHDIET'="@"
SET FHDPATT=FHDIET_"^^^^"
+12 ;created diet related SO's, SF's, FP's
DO SOSFFP^FHOMRO2
+13 ;creates so events
DO SOEVNT^FHSPED
+14 ;creates sf events
DO SFEVNT^FHNO7
+15 QUIT
SET ;
+1 SET FHPREVML=0
DO PREV
IF FHPREVML=1
QUIT
+2 SET FHSETFLG=1
+3 ;I $O(^FHPT(FHDFN,"OP","B",STDT,FHRNUM)) Q:FHRNUM'>0 D
+4 ;check previous SO
DO CPRSO^FHSPED
+5 ;check previous SF
DO CPRSF^FHNO7
+6 SET Y=STDT
KILL DIC,DO
SET DA(1)=FHDFN
SET DIC="^FHPT("_DA(1)_",""OP"","
+7 ;,DIC("P")=$P(^DD(115,16,0),U,2),X=+Y,DINUM=X
SET DIC(0)="L"
+8 DO FILE^DICN
IF Y=-1
QUIT
+9 KILL DIE
SET DA(1)=FHDFN
SET DIE="^FHPT("_DA(1)_",""OP"","
+10 SET FHORN=$SELECT($GET(FHORN)="":"",1:FHORN)
SET DA=+Y
+11 SET DR="1////^S X=FHDIET;2////^S X=FHLOC;2.5////^S X=FHRMBD;3////^S X=FHMEAL;5////^S X=FHMPNUM;6////^S X=FHDIETX(1);7////^S X=FHDIETX(2);8////^S X=FHDIETX(3);9////^S X=FHDIETX(4);10////^S X=FHDIETX(5);.05////^S X=FHORN;24.5////^S X=DUZ"
DO ^DIE
+12 SET ADM=DA
+13 ;process previous SO automatically to the new Recurring meal entry.
DO PPRSO^FHSPED
+14 ;process previous SF automatically.
DO PPRSF^FHNO7
+15 QUIT
MULTDT ;
+1 SET FHDPATT=""
SET FHDIET="@"
FOR FHDX=1:1:5
SET FHDIETX(FHDX)="@"
+2 DO ^FHOMRO3
IF $ORDER(FHDI(0))=""
FOR FHDX=1:1:5
SET FHDIETX(FHDX)=""
QUIT
+3 SET FHDX=0
FOR FHD0=0:0
SET FHD0=$ORDER(FHDI(FHD0))
if FHD0=""
QUIT
SET FHDX=FHDX+1
SET FHDIETX(FHDX)=$PIECE(FHDI(FHD0),"^",1)
SET FHDPATT=FHDPATT_FHDIETX(FHDX)_"^"
+4 QUIT
SHDAYS ;
+1 WRITE !!," Mon Tues Wed Thur Fri Sat Sun"
+2 WRITE !," M T W R F S X"
+3 WRITE !!,"Enter string of characters for desired days of week: e.g., MWF",!
+4 QUIT
DAYCHK ;
+1 SET X=FHDAYS
DO TR^FH
SET FHDAYS=X
+2 SET X1=""
FOR K=1:1
SET Z=$EXTRACT(FHDAYS,K)
if Z=""!(FHIFLG=1)
QUIT
Begin DoDot:1
+3 IF X1[Z
SET FHIFLG=1
QUIT
+4 IF "MTWRFSX"'[Z
SET FHIFLG=1
QUIT
+5 SET X1=X1_Z
QUIT
End DoDot:1
+6 IF FHIFLG=1
WRITE !!,"Please enter the desired days of the week.",!
+7 QUIT
PREV ;
+1 FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",STDT,FHRNUM))
if FHRNUM'>0!(FHPREVML=1)
QUIT
Begin DoDot:1
+2 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL
QUIT
+3 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
QUIT
+4 DO PATNAME^FHOMUTL
SET FHPREDT=$$FMTE^XLFDT(STDT,"P")
IF $GET(FHHL7)'=1
Begin DoDot:2
+5 WRITE !!?3,FHPTNM," ALREADY HAS A "
+6 WRITE $SELECT(FHMEAL="B":"BREAKFAST",FHMEAL="N":"NOON",1:"EVENING")
+7 WRITE " MEAL ORDERED FOR ",FHPREDT
End DoDot:2
+8 SET FHPREVML=1
End DoDot:1
+9 QUIT
CHECK ;
+1 SET FHEXST=0
IF $ORDER(^FHPT(FHDFN,"OP","B",FHNOW))
Begin DoDot:1
+2 FOR FHRMDT=FHNOW:0
SET FHRMDT=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT))
if FHRMDT'>0
QUIT
FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM))
if FHRNUM'>0
QUIT
IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)'="C"
SET FHEXST=1
End DoDot:1
+3 QUIT
CHECKSM ; Check if the OP has an existing SM for this date/meal
+1 SET FHSMYES=0
+2 FOR FHZ=DT:0
SET FHZ=$ORDER(^FHPT(FHDFN,"SM","B",FHZ))
if FHZ'>0
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^FHPT(FHDFN,"SM",FHZ,0)),U,9)'=FHMEAL
QUIT
+4 IF $PIECE($GET(^FHPT(FHDFN,"SM",FHZ,0)),U,2)="C"
QUIT
+5 IF $PIECE($GET(^FHPT(FHDFN,"SM",FHZ,0)),U,2)="D"
QUIT
+6 SET FHSMYES=1
End DoDot:1
+7 QUIT
MSG1 ;
+1 WRITE !!,"This patient already has a Special Meal ordered for "
+2 SET DTP=DT
DO DTP^FH
WRITE DTP," "
+3 WRITE $SELECT(FHMEAL="B":"Breakfast",FHMEAL="N":"Noon",1:"Evening"),!
HANG 1
QUIT
+4 ;
END ;Kill local variables before exiting
+1 DO KILL^FHOMRO2
+2 QUIT
+3 ;
EDIT ;
+1 DO NOW^%DTC
SET STDT=$EXTRACT(%,1,7)
SET FHDTRLE=%
+2 DO DISP^FHOMRR1
EDT1 KILL DIR
SET DIR(0)="NAO^1:"_NUM
SET DIR("A")="Edit Which Order? "
DO ^DIR
+1 if $DATA(DIRUT)
QUIT
+2 SET ORDNUM=Y
SET Y=$PIECE(FHLIST(ORDNUM),U,2)
DO DD^%DT
WRITE !,Y,!
+3 SET DA=$PIECE(FHLIST(ORDNUM),U,1)
SET DA(1)=FHDFN
SET DIE="^FHPT("_DA(1)_",""OP"","
+4 IF $PIECE($GET(^FHPT(FHDFN,"OP",DA,0)),U,15)="C"
WRITE !!?3,"The selected order has been cancelled!",!
DO EDT1
QUIT
+5 SET FHLPT=$PIECE($GET(^FHPT(FHDFN,"OP",DA,0)),U,3)
SET FHMEAL=$PIECE($GET(^FHPT(FHDFN,"OP",DA,0)),U,4)
+6 DO OUTLOC
IF FHLOC=""
DO UPXMSG^FHOMUTL
QUIT
+7 IF $PIECE($GET(^FH(119.6,FHLOC,1)),U,4)="Y"
DO MULTDT
if FHDIETX(1)=""
DO UPXMSG^FHOMUTL
if FHDIETX(1)=""
QUIT
SET FHDIET="@"
DO SETEDT
QUIT
+8 DO DIETLST^FHOMUTL
IF FHDEF=""
WRITE !!,"NO DEFAULT OUTPATIENT DIET SET!!",!
QUIT
+9 SET FHDEF2=$PIECE($GET(^FHPT(FHDFN,"OP",DA,0)),U,2)
IF FHDEF2'=""
SET FHDEF=$PIECE($GET(^FH(111,FHDEF2,0)),U,1)
+10 KILL DIC
SET DIC="^FH(111,"
SET DIC("A")="Select DIET NAME: "
SET DIC(0)="AEMQZ"
+11 SET DIC("B")=FHDEF
SET DIC("S")="I FHSPDTS[$P(^(0),U)"
DO ^DIC
+12 IF $DATA(DUOUT)
DO UPXMSG^FHOMUTL
QUIT
+13 IF Y=-1
DO UPXMSG^FHOMUTL
QUIT
+14 SET FHDIET=+Y
FOR FHDX=1:1:5
SET FHDIETX(FHDX)="@"
SETEDT ;
+1 WRITE !
SET FHZDA=DA
SET DR="2////^S X=FHLOC;1////^S X=FHDIET;6////^S X=FHDIETX(1);7////^S X=FHDIETX(2);8////^S X=FHDIETX(3);9////^S X=FHDIETX(4);10////^S X=FHDIETX(5);25////^S X=FHDTRLE;24.5////^S X=DUZ"
+2 DO ^DIE
DO UPDMSG^FHOMUTL
DO ED100
+3 QUIT
OUTLOC ;Prompt for outpatient location - screen for ONLY Outpatient Locations
+1 SET FHLOC=""
SET FHOUT="O"
+2 KILL DIC
SET DIC="^FH(119.6,"
SET DIC(0)="AEQZ"
SET DIC("B")=FHLPT
+3 SET DIC("A")="Select OUTPATIENT LOCATION: "
+4 SET DIC("S")="I $P(^(0),U,3)=FHOUT"
DO ^DIC
+5 if $DATA(DUOUT)
QUIT
IF Y=-1
QUIT
+6 SET FHLOC=+Y
IF '$DATA(^FH(119.6,FHLOC,"L"))
SET FHLOC=""
WRITE !!,"The selected location does not have an Associated Hospital Location."
+7 QUIT
UPD100 ;Backdoor message to update file #100 with a new RM 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 KILL N1
SET FHODAYS=""
+4 FOR N=1:1:7
SET FH1=$EXTRACT(FHDAYS,N)
if FH1=""
QUIT
SET M=$FIND("MTWRFSX",FH1)-1
SET N1(M)=""
+5 FOR N=0:0
SET N=$ORDER(N1(N))
if N'>0
QUIT
SET FHODAYS=FHODAYS_"~QJ"_N
+6 SET FHODAYS=$EXTRACT(FHODAYS,2,999)
+7 SET FHOMEAL=$SELECT(FHMEAL="B":1,FHMEAL="N":3,FHMEAL="E":5,1:"")
+8 IF FHDIET'="@"
SET FHODNM=$PIECE($GET(^FH(111,FHDIET,0)),U,1)
+9 SET FHOSTDT=$$FMTHL7^XLFDT(FHOSTDT)
SET FHOENDT=$$FMTHL7^XLFDT(ENDT)
+10 SET FHOTDAY=$$FMTHL7^XLFDT(FHTODAY)
+11 SET FILL="R;"_FHMPNUM_";"_FHOSTDT_";"_ENDT_";"_FHDAYS_";"_FHMEAL
+12 SET MSG(4)="ORC|SN||"_FILL_"^FH||||^"_FHODAYS_"^^"_FHOSTDT_"^"_FHOENDT_"||||||||"_FHOTDAY
+13 IF FHDIET'="@"
SET MSG(5)="ODS|D|"_FHOMEAL_"|^^^"_FHDIET_"^"_FHODNM_"^99FHD|"
+14 IF FHDIET="@"
Begin DoDot:1
+15 FOR N=0:0
SET N=$ORDER(FHDIETX(N))
if N'>0
QUIT
if FHDIETX(N)=""
QUIT
SET FHODNM=$PIECE($GET(^FH(111,FHDIETX(N),0)),U,1)
SET MSG(N+4)="ODS|D|"_FHOMEAL_"|^^^"_FHDIETX(N)_"^"_FHODNM_"^99FHD|"
End DoDot:1
+16 DO EVSEND^FHWOR
+17 QUIT
ED100 ;Backdoor message to update file #100 with an edited RM 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 (FHOSTDT,FHOENDT)=$PIECE($GET(^FHPT(FHDFN,"OP",FHZDA,0)),U,1)
+4 SET FHOSTDT=$$FMTHL7^XLFDT(FHOSTDT)
SET FHOENDT=$$FMTHL7^XLFDT(FHOENDT)
+5 SET FILL="RMEDIT;"_FHZDA
SET FHORN=$PIECE($GET(^FHPT(FHDFN,"OP",FHZDA,0)),U,12)
+6 SET FHODNM=$PIECE($GET(^FH(111,FHDIET,0)),U,1)
+7 SET FHOMEAL=$SELECT(FHMEAL="B":1,FHMEAL="N":3,FHMEAL="E":5,1:"")
+8 SET MSG(4)="ORC|XX|"_FHORN_"^OR|"_FILL_"^FH||||^^^"_FHOSTDT_"^"_FHOENDT_"||||||||"
+9 SET MSG(5)="ODS|D|"_FHOMEAL_"|^^^"_FHDIET_"^"_FHODNM_"^99FHD|"
+10 DO EVSEND^FHWOR
+11 QUIT
