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