- 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 Jan 18, 2025@02:54:12 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