source: FOIAVistA/tag/r/DIETETICS-FH/FHOMRO1.m@ 1779

FHOMRO1 ;Hines OIFO/RTK RECURRING MEALS ORDER EDIT  ;2/04/03  14:05
 ;;5.5;DIETETICS;**1,2,5**;Jan 28, 2005;Build 53
 ;
 S FHDIET="" F FHDX=1:1:5 S FHDIETX(FHDX)=""
 S FHMSG1="R" 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