FHOMWOR ;Hines OIFO/RTK OUTPATIENT MEALS/HL7 MESSAGING ;10/21/03 10:15
;;5.5;DIETETICS;**2,5,19**;Jan 28, 2005;Build 2
S FHDFN="",FHZ115="P"_DFN D ADD^FHOMDPA
I 'FHDFN S TXT="Outpatient not found" D GETOR^FHWOR,ERR Q
;Decode FHMSG(3) - PV1
S FHX=$G(FHMSG(3))
I $E(FHX,1,3)'="PV1" S TXT="3rd msg not PV1" D GETOR^FHWOR,ERR Q
S FHLOC=$P($P(FHX,"|",4),U,1)
I FHLOC="" S TXT="Missing Location" D GETOR^FHWOR,ERR Q
S FHLOC=$O(^FH(119.6,"AL",FHLOC,""))
I 'FHLOC S TXT="Invalid Location" D GETOR^FHWOR,ERR Q
;Decode FHMSG(4) - ORC
S FHX=$G(FHMSG(4))
I $E(FHX,1,3)'="ORC" S TXT="4th msg not ORC" D GETOR^FHWOR,ERR Q
S FHORN=$P(FHX,"|",3),FHORN=+FHORN,FILL=$P(FHX,"|",4)
S FHDUR=$P(FHX,"|",8),FHDOW=$P(FHDUR,U,2)
S DATE=$E($P(FHDUR,U,4),1,8) D CVT^FHWOR S STDT=DATE,FHOSTDT=STDT
S DATE=$P(FHDUR,U,5) D CVT^FHWOR S ENDT=DATE I ENDT'="" S ENDT=ENDT_.99
I ENDT="" S ENDT=9999999.99
S ACT=$P(FHX,"|",2) I ACT="CA"!(ACT="DC") D CANCEL Q
I ACT="NA" D NA Q
I ACT="SS" D OMSTAT^FHWORR Q
I ACT'="NW" S TXT="Action not NW, CA or DC" D GETOR^FHWOR,ERR Q
D NOW^%DTC S FHNOW=$P(%,".",1)
I STDT=""!(STDT<FHNOW) S TXT="Start Date not valid" D GETOR^FHWOR,ERR Q
I ENDT<STDT S TXT="End Date not valid" D GETOR^FHWOR,ERR Q
S FHPV=$P(FHX,"|",13),FHEFF=$P(FHX,"|",16)
I FHEFF="" S TXT="No effective date" D ERR Q
;Decode FHMSG(5) - ODS/ODT
S FHX=$G(FHMSG(5))
S FHINST=$P(FHX,"|",4),FHBAG="N" I FHINST="bagged" S FHBAG="Y"
S FHSVCP=$P($P(FHX,"|",3),U,4)
I $E(FHX,1,3)="ODT" D HL7SET^FHOMRE1 Q ;EARLY/LATE
I $E(FHX,1,3)="OBR" D HL7SET^FHOMIP Q ;ISOLATION/PRECAUTION
I $E(FHX,1,3)'="ODS" S TXT="5th message not ODT or ODS as expected" D GETOR^FHWOR,ERR Q
S FHTYPC=$P(FHX,"|",2) I FHTYPC="ZE" D HL7SET^FHOMRT1 Q ;TUBEFEEDING
S FHDTX=$P(FHX,"|",4),FHDIET=$P(FHDTX,U,4),FHDTX=$E(FHDTX,4,$L(FHDTX))
S FHCOM=$P(FHX,"|",5),FHM3=$P(FHX,"|",3)
I $E(FHDTX,1,4)="FH-6" D HL7SET^FHOMRA1 Q ;ADDITIONAL ORDERS
S FHMEAL=$S(FHM3=1:"B",FHM3=3:"N",FHM3=5:"E",1:"")
I FHMEAL="" S TXT="Meal missing" D GETOR^FHWOR,ERR Q
I FHDIET="" S TXT="Missing diet" D GETOR^FHWOR,ERR Q
I '$D(^FH(111,FHDIET)) S TXT="Invalid diet" D GETOR^FHWOR,ERR Q
I FHTYPC="S" D SM ;SPECIAL MEAL REQUEST
I FHTYPC="D" D RM I $G(FHAIL)'="" Q ;RECURRING MEAL ORDER
D SEND^FHWOR Q
SM ; Special Meal Request
; FHDFN,FHLOC set at top of FHOMWOR
D NOW^%DTC S FHNOW=%
S FHDUZ=$P($G(FHMSG(4)),"|",11),FHSTAT="P",FHRMBD=""
I FHDUZ'="",$D(^XUSEC("FHAUTH",FHDUZ)) S FHSTAT="A"
S FHQEL=1 D SETNODE^FHOMSR1
S FILL="S;"_FHSMID
Q
RM ;
; Recurring orders from CPRS will only have ONE diet, not up to 5 like
; for NonVA patients/inpatients therefore can set FHDIETX1-5 = NULL
; FHDFN,FHLOC set at top of FHOMWOR
S FHMPNUM=$O(^FHPT(FHDFN,"OP","C",""),-1) I FHMPNUM="" S FHMPNUM=0
S FHMPNUM=FHMPNUM+1
S (FHAIL,FHRMBD,FHDIETX(1),FHDIETX(2),FHDIETX(3),FHDIETX(4),FHDIETX(5))=""
S (C,FHENDL)=0,STDTLP=STDT,FHDZ="" F Q:FHENDL=1 D
.S X=STDTLP D H^%DTC S:%Y=0 %Y=7 S FHDZ=FHDZ_%Y_"^",X1=STDTLP,X2=1
.D C^%DTC S STDTLP=X,C=C+1 I STDTLP>ENDT!(C>6) S FHENDL=1 Q
S FHDAYS="" F FHH=1:1:7 S FHPCE=$P(FHDOW,"~",FHH) Q:FHPCE="" D
.S FHD3=$E(FHPCE,3)
.I FHD3'>0,FHD3'<8 Q
.I FHDZ'[FHD3 Q
.S FHDAYS=FHDAYS_$E("MTWRFSX",FHD3)
I FHDAYS="",$E(STDT,1,7)'=$E(ENDT,1,7) S (TXT,FHAIL)="Day of week invalid or not within date range" D GETOR^FHWOR,ERR Q
I FHDAYS="",$E(STDT,1,7)=$E(ENDT,1,7) S X=$E(STDT,1,7) D DOW^%DTC S FHDAYS=$E("XMTWRFS",Y+1)
D SETNODE^FHOMRO1
S FILL="R;"_FHMPNUM_";"_STDT_";"_ENDT_";"_FHDAYS_";"_FHMEAL
Q
CANCEL ;Cancel outpatient orders
S FHENDT=ENDT,FHX=$G(FHMSG(4)),FILL=$P(FHX,"|",4),FHMPNUM=""
S FHORSAV=FHORN,FHILSAV=FILL,FHACTSV=ACT
S FHTYPE=$P(FILL,";",1) I FHTYPE="R" S FHMPNUM=$P(FILL,";",2)
I "AEIGSRT"'[FHTYPE S TXT="Invalid cancel code" D ERR Q
S X1=STDT,X2=-1 D C^%DTC S STDT1=X
I "AET"[FHTYPE F FHRMDT=STDT1:0 S FHRMDT=$O(^FHPT(FHDFN,"OP","B",FHRMDT)) Q:FHRMDT'>0!(FHRMDT>FHENDT) D
.F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM)) Q:FHRNUM'>0 D
..I FHTYPE="A" D CANAO^FHOMRC1 Q
..I FHTYPE="E" D CANEL^FHOMRC1 Q
..I FHTYPE="T" D CANTF^FHOMRC1 Q
I FHTYPE="R" F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","C",FHMPNUM,FHRNUM)) Q:FHRNUM'>0 S FHRMDT=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1) D CANRM^FHOMRC1,ASSOC^FHOMRC2
I FHTYPE="I" D CAN^FHOMIP
I FHTYPE="S" S FHSMID=$P(FILL,";",2),FHCDT=FHDFN_"^"_FHSMID D CAN^FHOMSC1,CNSMEL^FHOMRC2 ;cancel a SM and associated SM Late Tray
I FHTYPE="G" S FHSMID=$P(FILL,";",2),FHCDT=FHDFN_"^"_FHSMID D CNSMEL^FHOMRC2 ;cancel a SM Late Tray only
S FHORN=FHORSAV,FILL=FHILSAV,ACT=FHACTSV D CSEND^FHWOR Q
Q
NA ;Number assign for outpatient
S FILL=$P(FHX,"|",4)
S FHTYPE=$P(FILL,";",1) S (FHMPN,FHRNUM)=+$P(FILL,";",2)
D NA^FHOMWOR1
Q
ERR ;
K MSG D RMSH^FHWOR ;Sets MSG(1) & MSG(2)
S ACT="UA" I $P(FHMSG(4),"|",2)="CA" S ACT="U"_$E($P(FHMSG(4),"|",2),1)
S $P(MSG(3),"|",1,2)="ORC|"_ACT,$P(MSG(3),"|",3)=FHORN
S $P(MSG(3),"|",4)=$P(FHMSG(3),"|",4)
S $P(MSG(3),"|",13)=$P(FHMSG(3),"|",13)
S $P(MSG(3),"|",16)=$P(FHMSG(3),"|",16),$P(MSG(3),"|",17)=TXT
;
;W ! F RK=0:0 S RK=$O(MSG(RK)) Q:RK'>0 W !," MSG"_RK_"= ",MSG(RK)
;F RK=0:0 S RK=$O(FHMSG(RK)) Q:RK'>0 W !,"FHMSG"_RK_"= ",FHMSG(RK)
;W !!,"TXT=",TXT,!!
;
D EVSEND^FHWOR Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMWOR 5309 printed Sep 23, 2025@19:29:13 Page 2
FHOMWOR ;Hines OIFO/RTK OUTPATIENT MEALS/HL7 MESSAGING ;10/21/03 10:15
+1 ;;5.5;DIETETICS;**2,5,19**;Jan 28, 2005;Build 2
+2 SET FHDFN=""
SET FHZ115="P"_DFN
DO ADD^FHOMDPA
+3 IF 'FHDFN
SET TXT="Outpatient not found"
DO GETOR^FHWOR
DO ERR
QUIT
+4 ;Decode FHMSG(3) - PV1
+5 SET FHX=$GET(FHMSG(3))
+6 IF $EXTRACT(FHX,1,3)'="PV1"
SET TXT="3rd msg not PV1"
DO GETOR^FHWOR
DO ERR
QUIT
+7 SET FHLOC=$PIECE($PIECE(FHX,"|",4),U,1)
+8 IF FHLOC=""
SET TXT="Missing Location"
DO GETOR^FHWOR
DO ERR
QUIT
+9 SET FHLOC=$ORDER(^FH(119.6,"AL",FHLOC,""))
+10 IF 'FHLOC
SET TXT="Invalid Location"
DO GETOR^FHWOR
DO ERR
QUIT
+11 ;Decode FHMSG(4) - ORC
+12 SET FHX=$GET(FHMSG(4))
+13 IF $EXTRACT(FHX,1,3)'="ORC"
SET TXT="4th msg not ORC"
DO GETOR^FHWOR
DO ERR
QUIT
+14 SET FHORN=$PIECE(FHX,"|",3)
SET FHORN=+FHORN
SET FILL=$PIECE(FHX,"|",4)
+15 SET FHDUR=$PIECE(FHX,"|",8)
SET FHDOW=$PIECE(FHDUR,U,2)
+16 SET DATE=$EXTRACT($PIECE(FHDUR,U,4),1,8)
DO CVT^FHWOR
SET STDT=DATE
SET FHOSTDT=STDT
+17 SET DATE=$PIECE(FHDUR,U,5)
DO CVT^FHWOR
SET ENDT=DATE
IF ENDT'=""
SET ENDT=ENDT_.99
+18 IF ENDT=""
SET ENDT=9999999.99
+19 SET ACT=$PIECE(FHX,"|",2)
IF ACT="CA"!(ACT="DC")
DO CANCEL
QUIT
+20 IF ACT="NA"
DO NA
QUIT
+21 IF ACT="SS"
DO OMSTAT^FHWORR
QUIT
+22 IF ACT'="NW"
SET TXT="Action not NW, CA or DC"
DO GETOR^FHWOR
DO ERR
QUIT
+23 DO NOW^%DTC
SET FHNOW=$PIECE(%,".",1)
+24 IF STDT=""!(STDT<FHNOW)
SET TXT="Start Date not valid"
DO GETOR^FHWOR
DO ERR
QUIT
+25 IF ENDT<STDT
SET TXT="End Date not valid"
DO GETOR^FHWOR
DO ERR
QUIT
+26 SET FHPV=$PIECE(FHX,"|",13)
SET FHEFF=$PIECE(FHX,"|",16)
+27 IF FHEFF=""
SET TXT="No effective date"
DO ERR
QUIT
+28 ;Decode FHMSG(5) - ODS/ODT
+29 SET FHX=$GET(FHMSG(5))
+30 SET FHINST=$PIECE(FHX,"|",4)
SET FHBAG="N"
IF FHINST="bagged"
SET FHBAG="Y"
+31 SET FHSVCP=$PIECE($PIECE(FHX,"|",3),U,4)
+32 ;EARLY/LATE
IF $EXTRACT(FHX,1,3)="ODT"
DO HL7SET^FHOMRE1
QUIT
+33 ;ISOLATION/PRECAUTION
IF $EXTRACT(FHX,1,3)="OBR"
DO HL7SET^FHOMIP
QUIT
+34 IF $EXTRACT(FHX,1,3)'="ODS"
SET TXT="5th message not ODT or ODS as expected"
DO GETOR^FHWOR
DO ERR
QUIT
+35 ;TUBEFEEDING
SET FHTYPC=$PIECE(FHX,"|",2)
IF FHTYPC="ZE"
DO HL7SET^FHOMRT1
QUIT
+36 SET FHDTX=$PIECE(FHX,"|",4)
SET FHDIET=$PIECE(FHDTX,U,4)
SET FHDTX=$EXTRACT(FHDTX,4,$LENGTH(FHDTX))
+37 SET FHCOM=$PIECE(FHX,"|",5)
SET FHM3=$PIECE(FHX,"|",3)
+38 ;ADDITIONAL ORDERS
IF $EXTRACT(FHDTX,1,4)="FH-6"
DO HL7SET^FHOMRA1
QUIT
+39 SET FHMEAL=$SELECT(FHM3=1:"B",FHM3=3:"N",FHM3=5:"E",1:"")
+40 IF FHMEAL=""
SET TXT="Meal missing"
DO GETOR^FHWOR
DO ERR
QUIT
+41 IF FHDIET=""
SET TXT="Missing diet"
DO GETOR^FHWOR
DO ERR
QUIT
+42 IF '$DATA(^FH(111,FHDIET))
SET TXT="Invalid diet"
DO GETOR^FHWOR
DO ERR
QUIT
+43 ;SPECIAL MEAL REQUEST
IF FHTYPC="S"
DO SM
+44 ;RECURRING MEAL ORDER
IF FHTYPC="D"
DO RM
IF $GET(FHAIL)'=""
QUIT
+45 DO SEND^FHWOR
QUIT
SM ; Special Meal Request
+1 ; FHDFN,FHLOC set at top of FHOMWOR
+2 DO NOW^%DTC
SET FHNOW=%
+3 SET FHDUZ=$PIECE($GET(FHMSG(4)),"|",11)
SET FHSTAT="P"
SET FHRMBD=""
+4 IF FHDUZ'=""
IF $DATA(^XUSEC("FHAUTH",FHDUZ))
SET FHSTAT="A"
+5 SET FHQEL=1
DO SETNODE^FHOMSR1
+6 SET FILL="S;"_FHSMID
+7 QUIT
RM ;
+1 ; Recurring orders from CPRS will only have ONE diet, not up to 5 like
+2 ; for NonVA patients/inpatients therefore can set FHDIETX1-5 = NULL
+3 ; FHDFN,FHLOC set at top of FHOMWOR
+4 SET FHMPNUM=$ORDER(^FHPT(FHDFN,"OP","C",""),-1)
IF FHMPNUM=""
SET FHMPNUM=0
+5 SET FHMPNUM=FHMPNUM+1
+6 SET (FHAIL,FHRMBD,FHDIETX(1),FHDIETX(2),FHDIETX(3),FHDIETX(4),FHDIETX(5))=""
+7 SET (C,FHENDL)=0
SET STDTLP=STDT
SET FHDZ=""
FOR
if FHENDL=1
QUIT
Begin DoDot:1
+8 SET X=STDTLP
DO H^%DTC
if %Y=0
SET %Y=7
SET FHDZ=FHDZ_%Y_"^"
SET X1=STDTLP
SET X2=1
+9 DO C^%DTC
SET STDTLP=X
SET C=C+1
IF STDTLP>ENDT!(C>6)
SET FHENDL=1
QUIT
End DoDot:1
+10 SET FHDAYS=""
FOR FHH=1:1:7
SET FHPCE=$PIECE(FHDOW,"~",FHH)
if FHPCE=""
QUIT
Begin DoDot:1
+11 SET FHD3=$EXTRACT(FHPCE,3)
+12 IF FHD3'>0
IF FHD3'<8
QUIT
+13 IF FHDZ'[FHD3
QUIT
+14 SET FHDAYS=FHDAYS_$EXTRACT("MTWRFSX",FHD3)
End DoDot:1
+15 IF FHDAYS=""
IF $EXTRACT(STDT,1,7)'=$EXTRACT(ENDT,1,7)
SET (TXT,FHAIL)="Day of week invalid or not within date range"
DO GETOR^FHWOR
DO ERR
QUIT
+16 IF FHDAYS=""
IF $EXTRACT(STDT,1,7)=$EXTRACT(ENDT,1,7)
SET X=$EXTRACT(STDT,1,7)
DO DOW^%DTC
SET FHDAYS=$EXTRACT("XMTWRFS",Y+1)
+17 DO SETNODE^FHOMRO1
+18 SET FILL="R;"_FHMPNUM_";"_STDT_";"_ENDT_";"_FHDAYS_";"_FHMEAL
+19 QUIT
CANCEL ;Cancel outpatient orders
+1 SET FHENDT=ENDT
SET FHX=$GET(FHMSG(4))
SET FILL=$PIECE(FHX,"|",4)
SET FHMPNUM=""
+2 SET FHORSAV=FHORN
SET FHILSAV=FILL
SET FHACTSV=ACT
+3 SET FHTYPE=$PIECE(FILL,";",1)
IF FHTYPE="R"
SET FHMPNUM=$PIECE(FILL,";",2)
+4 IF "AEIGSRT"'[FHTYPE
SET TXT="Invalid cancel code"
DO ERR
QUIT
+5 SET X1=STDT
SET X2=-1
DO C^%DTC
SET STDT1=X
+6 IF "AET"[FHTYPE
FOR FHRMDT=STDT1:0
SET FHRMDT=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT))
if FHRMDT'>0!(FHRMDT>FHENDT)
QUIT
Begin DoDot:1
+7 FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM))
if FHRNUM'>0
QUIT
Begin DoDot:2
+8 IF FHTYPE="A"
DO CANAO^FHOMRC1
QUIT
+9 IF FHTYPE="E"
DO CANEL^FHOMRC1
QUIT
+10 IF FHTYPE="T"
DO CANTF^FHOMRC1
QUIT
End DoDot:2
End DoDot:1
+11 IF FHTYPE="R"
FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","C",FHMPNUM,FHRNUM))
if FHRNUM'>0
QUIT
SET FHRMDT=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1)
DO CANRM^FHOMRC1
DO ASSOC^FHOMRC2
+12 IF FHTYPE="I"
DO CAN^FHOMIP
+13 ;cancel a SM and associated SM Late Tray
IF FHTYPE="S"
SET FHSMID=$PIECE(FILL,";",2)
SET FHCDT=FHDFN_"^"_FHSMID
DO CAN^FHOMSC1
DO CNSMEL^FHOMRC2
+14 ;cancel a SM Late Tray only
IF FHTYPE="G"
SET FHSMID=$PIECE(FILL,";",2)
SET FHCDT=FHDFN_"^"_FHSMID
DO CNSMEL^FHOMRC2
+15 SET FHORN=FHORSAV
SET FILL=FHILSAV
SET ACT=FHACTSV
DO CSEND^FHWOR
QUIT
+16 QUIT
NA ;Number assign for outpatient
+1 SET FILL=$PIECE(FHX,"|",4)
+2 SET FHTYPE=$PIECE(FILL,";",1)
SET (FHMPN,FHRNUM)=+$PIECE(FILL,";",2)
+3 DO NA^FHOMWOR1
+4 QUIT
ERR ;
+1 ;Sets MSG(1) & MSG(2)
KILL MSG
DO RMSH^FHWOR
+2 SET ACT="UA"
IF $PIECE(FHMSG(4),"|",2)="CA"
SET ACT="U"_$EXTRACT($PIECE(FHMSG(4),"|",2),1)
+3 SET $PIECE(MSG(3),"|",1,2)="ORC|"_ACT
SET $PIECE(MSG(3),"|",3)=FHORN
+4 SET $PIECE(MSG(3),"|",4)=$PIECE(FHMSG(3),"|",4)
+5 SET $PIECE(MSG(3),"|",13)=$PIECE(FHMSG(3),"|",13)
+6 SET $PIECE(MSG(3),"|",16)=$PIECE(FHMSG(3),"|",16)
SET $PIECE(MSG(3),"|",17)=TXT
+7 ;
+8 ;W ! F RK=0:0 S RK=$O(MSG(RK)) Q:RK'>0 W !," MSG"_RK_"= ",MSG(RK)
+9 ;F RK=0:0 S RK=$O(FHMSG(RK)) Q:RK'>0 W !,"FHMSG"_RK_"= ",FHMSG(RK)
+10 ;W !!,"TXT=",TXT,!!
+11 ;
+12 DO EVSEND^FHWOR
QUIT
+13 QUIT
