FHORD81 ; HISC/REL/NCA - Diet Order Lists (cont) ;11/30/00 13:55
;;5.5;DIETETICS;**1,5,17**;Jan 28, 2005;Build 9
;patch 5 - added outpatiet SOs & SFs and outpt room-bed.
K C,^TMP("FH",$J) F L=0:0 S L=$O(^FH(118,L)) Q:L<1 I '$D(^FH(118,L,"I")) S C(L)=$P(^(0),"^",1)
D NOW^%DTC S NOW=%,DT=NOW\1,X1=DT,X2=-14 D C^%DTC S OLN=+X S X1=NOW,X2=-3 D C^%DTC S OLD=+X
S X1=DT,X2=2 D C^%DTC S K3=+X
F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0) D F0
S (PG,REC)=0,NXW="" F S NXW=$O(^TMP("FH",$J,NXW)) Q:NXW="" F W1=0:0 S W1=$O(^TMP("FH",$J,NXW,W1)) Q:W1<1 D F2
;
OUTP ;Outpatient data
D GETOUT^FHOMRBL1
S (ADM,DTP,FHPTSA,RM,FHLSAV,FHI)=""
I SRT="R" D RMS ;sort by room-bed
F S FHI=$O(^TMP($J,"FH",FHI)) Q:FHI="" D
.S FHJ="" F S FHJ=$O(^TMP($J,"FH",FHI,FHJ)) Q:FHJ="" D
..S FHPTSA=FHJ
..F FHK=0:0 S FHK=$O(^TMP($J,"FH",FHI,FHJ,FHK)) Q:FHK'>0 D
...S FHDAT=""
...S FHL=$O(^TMP($J,"FH",FHI,FHJ,FHK,0))
...I $G(FHL) D REC Q
...D PROC
W ! Q
;
RMS ;SORT BY ROOM-BED
M ^TMP($J,"FHR")=^TMP($J,"FH") K ^TMP($J,"FH")
F S FHI=$O(^TMP($J,"FHR",FHI)) Q:FHI="" D
.S FHJ="" F S FHJ=$O(^TMP($J,"FHR",FHI,FHJ)) Q:FHJ="" D
..S FHPTSA=FHJ
..F FHK=0:0 S FHK=$O(^TMP($J,"FHR",FHI,FHJ,FHK)) Q:FHK'>0 D
...S FHDAT=""
...S FHL=$O(^TMP($J,"FHR",FHI,FHJ,FHK,0))
...I $G(FHL) D RM1 Q
...D RM2
K ^TMP($J,"FHR")
Q
RM1 F FHL=0:0 S FHL=$O(^TMP($J,"FHR",FHI,FHJ,FHK,FHL)) Q:FHL'>0 D
.S FHDAT=^TMP($J,"FHR",FHI,FHJ,FHK,FHL)
.S FHDFN=$P(FHDAT,U,2)
.S RM=""
.I $G(FHDFN),$D(^FHPT(FHDFN,"OP",FHL,0)) S RM=$P(^(0),U,18)
.I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^(0),U,1)
.S:RM'="" RM=$E(RM,1,12)
.S:RM="" RM=" "
.S ^TMP($J,"FH",FHI,RM,FHK,FHL)=FHDAT
Q
RM2 S FHDAT=^TMP($J,"FHR",FHI,FHJ,FHK)
S FHDFN=$P(FHDAT,U,2)
S FHTYP=$P(FHDAT,U,1)
S RM=""
I $G(FHDFN),FHTYP="GM",$D(^FHPT(FHDFN,"GM",FHK,0)) S RM=$P(^(0),U,11)
I $G(FHDFN),FHTYP="SM",$D(^FHPT(FHDFN,"SM",FHK,0)) S RM=$P(^(0),U,13)
I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^(0),U,1)
S:RM'="" RM=$E(RM,1,12)
S:RM="" RM=" "
S ^TMP($J,"FH",FHI,RM,FHK)=FHDAT
Q
;
PROC ;process/print
S FHPLD=0
S:FHDAT="" FHDAT=^TMP($J,"FH",FHI,FHJ,FHK)
S FHCAT=$P(FHDAT,U,1)
S FHDFN=$P(FHDAT,U,2)
S FHDIE=$P(FHDAT,U,3)
S FHSTA=$P(FHDAT,U,4)
S FHMEAL=$P(FHDAT,U,5)
S FHLOC=$P(FHDAT,U,6)
S FHDAIN=$P(FHDAT,U,7)
S (FHSERT,FHSERC,FHSERD,FHSER)=""
I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) D
.S:$P(^FH(119.6,FHLOC,0),U,5) FHSERT="T"
.S:$P(^FH(119.6,FHLOC,0),U,6) FHSERC="C"
.S:$P(^FH(119.6,FHLOC,0),U,7) FHSERD="D"
.S FHSER=FHSERT_FHSERC_FHSERD
I (FHXX="C"),(WRD>0),(WRD'=FHSTA) Q
I (FHXX="L"),(WRD>0),(WRD'=FHLOC) Q
I (SER'="A"),(FHSER'[SER) Q
I FHI'=FHLSAV S FHLSAV=FHI,WRDN=$E(FHI,3,$L(FHI)) D HDR
S FHDIET=""
D PATNAME^FHOMUTL
S RM=""
I FHCAT="OP",$D(^FHPT(FHDFN,"OP",FHDAIN,0)) S RM=$P(^(0),U,18)
I FHCAT="GM",$D(^FHPT(FHDFN,"GM",FHDAIN,0)) S RM=$P(^(0),U,11)
I FHCAT="SM",$D(^FHPT(FHDFN,"SM",FHDAIN,0)) S RM=$P(^(0),U,13)
I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
I FHLSAV'=FHI S FHLSAV=FHI D HDR
W !!,$E(RM,1,12),?13,$E(FHPTNM,1,24),?38,FHBID,?67,FHSER
I $Y>(IOSL-6) D HDR
I $D(^FH(111,FHDIE,0)) S FHDIET=$P(^FH(111,FHDIE,0),U,7)
S FHTYP=$S(FHCAT="OP":"Recurring",FHCAT="GM":"Guest",FHCAT="SM":"Special",1:"")
S DTP=FHK D DTP^FH
W !,?14,"Diet Order: ",FHDIET,?40,"Meal: ","(",FHMEAL,")"
W !,?14,"Service Type: ",FHTYP,?40,"Date: ",DTP
;S FHDAIN=$O(^FHPT(FHDFN,""_FHCAT_"","B",FHK,0))
I $G(FHDAIN),$D(^FHPT(FHDFN,""_FHCAT_"",FHDAIN,"TF")) D OUTF
I $G(FHDAIN),FHCAT="OP",$D(^FHPT(FHDFN,"OP",FHDAIN,"SP")) D OSO
I $G(FHDAIN),FHCAT="OP",$D(^FHPT(FHDFN,"OP",FHDAIN,"SF")) D OSF
S FHPLD=1
D:'$G(FHL) ^FHORD83
Q
;
OSO ;process outpt SOs.
;
K N F K=0:0 S K=$O(^FHPT(FHDFN,"OP",FHDAIN,"SP",K)) Q:K'>0 S X=^(K,0) Q:$P(X,"^",6) D
.S M=$P(X,"^",3),N(M,K)=$P(X,"^",2,4),$P(N(M,K),"^",4,5)=$P(X,"^",8,9)
F M="B","N","E" F K=0:0 S K=$O(N(M,K)) Q:K<1 S Z=+N(M,K) I Z D
.I ($Y>(IOSL-6)) D HDR,FLNE^FHORD82
.S M2=$S(M="B":"Break",M="N":"Noon",1:"Even") S QTY=$P(N(M,K),"^",4)
.W !?13,"Stng. Order: ",M2,?38,$S(QTY:QTY,1:1)," ",$P($G(^FH(118.3,Z,0)),"^",1),$S($P(N(M,K),"^",5)'="Y":" (I)",1:"")
.S X=$P(N(M,K),"^",3) D DT W ?72,X Q
Q
;
OSF ;process outpt SFs.
S NM=$P($G(^FHPT(FHDFN,"OP",FHDAIN,"SF",0)),U,3) Q:'$G(NM)
K L,N,M,M1,M2 Q:'NM S Y=^FHPT(FHDFN,"OP",FHDAIN,"SF",NM,0) Q:$P(Y,"^",32)
S L=4 F K1=1:1:3 S K=0,N(K1)="" F K2=1:1:4 S Z=$P(Y,U,L+1),Q=$P(Y,U,L+2),L=L+2 I Z'="" S:'Q Q=1 S:N(K1)'="" N(K1)=N(K1)_"; " S N(K1)=N(K1)_Q_" "_$S($D(C(Z)):C(Z),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:" ")
S LST=$P(Y,"^",30)\1,X=LST,P1=0 D DT S:LST<OLN X=X_"*"
F K1=1:1:3 I N(K1)'="" W !?13,$P("10AM; 2PM; 8PM",";",K1),?19,$E(N(K1),1,52) I 'P1 S P1=1 W ?72,X
Q
;
REC ;set/get recurring data
F FHL=0:0 S FHL=$O(^TMP($J,"FH",FHI,FHJ,FHK,FHL)) Q:FHL'>0 D
.S FHDAT=^TMP($J,"FH",FHI,FHJ,FHK,FHL)
.D PROC
D:$G(FHPLD) ^FHORD83
Q
;
OUTF ;outpatient TF
S REC=1
S (FHTFPR,FHTFQU,FHTFST,FHTFCOM,FHTFTC,FHTFKD,FHTFCN)=""
I $G(FHDAIN),$D(^FHPT(FHDFN,"OP",FHDAIN,3)) D
.S FHRDAT3=$G(^FHPT(FHDFN,"OP",FHDAIN,3))
.S FHTFCOM=$P(FHRDAT3,U,1)
.S FHTFTC=$P(FHRDAT3,U,2)
.S FHTFTKD=$P(FHRDAT3,U,3)
.S FHTFCN=$P(FHRDAT3,U,5)
.S:FHTFCN="C" FHTFCN="Cancelled"
F FHTFDA=0:0 S FHTFDA=$O(^FHPT(FHDFN,"OP",FHDAIN,"TF",FHTFDA)) Q:FHTFDA'>0 D
.S FHTFDAT=$G(^FHPT(FHDFN,"OP",FHDAIN,"TF",FHTFDA,0))
.S FHTFPR=$P(FHTFDAT,U,1)
.I $G(FHTFPR),$D(^FH(118.2,FHTFPR,0)) S FHTFPR=$P(^FH(118.2,FHTFPR,0),U,1)
.S FHTFST=$P(FHTFDAT,U,2)
.S:$G(FHTFST) FHTFST=$S(FHTFST=1:"1/4",FHTFST=2:"1/2",FHTFST=3:"3/4",FHTFST=4:"FULL",1:"")
.S FHTFQU=$P(FHTFDAT,U,3)
.S FHTFCC=$P(FHTFDAT,U,4)
.;I FHAOT'="" S ZZ=" Additional Order: "_FHAOT_" "_FHAOCN_" By: "_FHAOC D LNE^FHORD82
.;I FHELTT'="" S ZZ=" Early/Late Tray Time: "_FHELTT_" Bag Meal: "_FHELTBM D LNE^FHOR82
.I $Y>(IOSL-6) D LNE^FHORD82
.W !,?5,"Tubefeed.:"
.S ZZ=FHTFCOM_" TF Total MLs: "_FHTFTC_" TF Total KCALS/Day: "_FHTFTKD_" "_FHTFCN W ZZ
.I FHTFPR'="" D
..I $Y>(IOSL-6) D LNE^FHORD82
..W !,?5
..S ZZ="TF Product: "_FHTFPR_" TF Strength: "_FHTFST_" TF Quantity: "_FHTFQU
..W ZZ
..I $Y>(IOSL-6) D LNE^FHORD82
..W !,?5
..S ZZ="TF Product ML/Day: "_FHTFCC_" "_FHTFCN
..W ZZ
Q
F0 ;
I $P(X,U,3)="O" Q
I FHXX="C" S K1=$P(X,"^",8) I WRD,K1'=WRD Q
I FHXX="L" S K1=$P(X,"^",1) I WRD,W1'=WRD Q
S K1=$S(FHXX="W":"",K1<1:99,K1<10:"0"_K1,1:K1),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
S WRDN=$P(^FH(119.6,W1,0),"^",1),^TMP("FH",$J,K1_P0_$E(WRDN,1,26),W1)="" Q
F2 S WRDN=$P(^FH(119.6,W1,0),"^",1)
K ^TMP($J) F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=^(FHDFN) D RM
Q:'$D(^TMP($J,"FHSRT")) S NX="" D HDR
L2 S NX=$O(^TMP($J,"FHSRT",NX)) I NX="" W ! Q
S FHDFN=""
L3 ; Get Next Patient data
S FHDFN=$O(^TMP($J,"FHSRT",NX,FHDFN)) G:FHDFN="" L2 S ADM=^(FHDFN)
D PATNAME^FHOMUTL I DFN="" G L3
G:ADM<1 L3 S Y(0)=^DPT(DFN,0) G:'$D(^DGPM(ADM,0)) L3
G:'$D(^FHPT(FHDFN,"A",ADM,0)) L3 S LEN=0 D CUR^FHORD7 S MEAL=Y,X0=^FHPT(FHDFN,"A",ADM,0) S:$L(MEAL)>48 LEN=$L($E(MEAL,1,48),",")
I SER'="A",$P(X0,"^",5)'=SER G L3
D:$Y>(IOSL-6) HDR S DTP=$P(^DGPM(ADM,0),"^",1) D DTP^FH
S RM=$S(SRT="R":NX,$D(^DPT(DFN,.101)):^(.101),1:"") D PID^FHDPA
W !!,RM,?13,$E($P(Y(0),"^",1),1,24),?38,BID,?47,DTP
S Y=$P(X0,"^",5) I Y'="" W ?67,Y
D GET I Y'="" W !?13,"Nut. Status: ",Y S X=+X5 D DT W ?72,X
D ALG^FHCLN I ALG'="" W !?13,"Allergies: " S ZZ=ALG D LNE^FHORD82
I "NO ORDER"'[MEAL!'$P(X0,"^",4) W !?13,"Diet Order: ",$S(LEN:$P(MEAL,",",1,LEN-1)_",",1:MEAL)
I I FHORD S X=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",9) D DT W ?72,X D:FHLD'="" NPO W:LEN !?24,$P(MEAL,",",LEN,999) D COM
G ^FHORD82
GET S Y="",X5=$O(^FHPT(FHDFN,"S",0)) Q:X5="" S X5=^(X5,0)
Q:$P(X5,"^",1)<$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",1)
S Y=$P($G(^FH(115.4,+$P(X5,"^",2),0)),"^",2) Q
NPO S LST=0 F K1=0:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"AC",K1)) Q:K1<1!(K1>NOW) I $P(^(K1,0),"^",2)=FHORD S LST=K1
W:LST<OLD "*" Q
COM ; List comment if any
S COM=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) Q:COM="" I $L(COM)<51 W !?16,COM Q
F LEN=51:-1:1 Q:$E(COM,LEN)=" "
W !?16,$E(COM,1,LEN-1) S COM=$E(COM,LEN+1,999)
W:COM'="" !?19,COM Q
DT S X=$J(+$E(X,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(X,4,5)) Q
RM ;
D PATNAME^FHOMUTL I DFN="" Q
I SRT="R" S RM=$G(^DPT(DFN,.101))
E S RM=$P($G(^DPT(DFN,0)),"^",1)
S:RM="" RM=" " S ^TMP($J,"FHSRT",RM,FHDFN)=ADM Q
HDR ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH
W @IOF S PG=PG+1,DTP=NOW D DTP^FH
W !,DTP,?(67-$L(WRDN)\2),WRDN," DIET ORDERS",?72,"Page ",PG
I SER'="A" S X=$S(SER="T":"TRAY",SER="C":"CAFETERIA",1:"DINING ROOM")_" Service Only" W !!?(79-$L(X)\2),X
W !!,"Room",?13,"Patient",?39,"ID#",?48,"Admission Date",?66,"Svc",?71,"Ord Date" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD81 8858 printed Apr 09, 2024@20:51:53 Page 2
FHORD81 ; HISC/REL/NCA - Diet Order Lists (cont) ;11/30/00 13:55
+1 ;;5.5;DIETETICS;**1,5,17**;Jan 28, 2005;Build 9
+2 ;patch 5 - added outpatiet SOs & SFs and outpt room-bed.
+3 KILL C,^TMP("FH",$JOB)
FOR L=0:0
SET L=$ORDER(^FH(118,L))
if L<1
QUIT
IF '$DATA(^FH(118,L,"I"))
SET C(L)=$PIECE(^(0),"^",1)
+4 DO NOW^%DTC
SET NOW=%
SET DT=NOW\1
SET X1=DT
SET X2=-14
DO C^%DTC
SET OLN=+X
SET X1=NOW
SET X2=-3
DO C^%DTC
SET OLD=+X
+5 SET X1=DT
SET X2=2
DO C^%DTC
SET K3=+X
+6 FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
if W1<1
QUIT
SET X=^(W1,0)
DO F0
+7 SET (PG,REC)=0
SET NXW=""
FOR
SET NXW=$ORDER(^TMP("FH",$JOB,NXW))
if NXW=""
QUIT
FOR W1=0:0
SET W1=$ORDER(^TMP("FH",$JOB,NXW,W1))
if W1<1
QUIT
DO F2
+8 ;
OUTP ;Outpatient data
+1 DO GETOUT^FHOMRBL1
+2 SET (ADM,DTP,FHPTSA,RM,FHLSAV,FHI)=""
+3 ;sort by room-bed
IF SRT="R"
DO RMS
+4 FOR
SET FHI=$ORDER(^TMP($JOB,"FH",FHI))
if FHI=""
QUIT
Begin DoDot:1
+5 SET FHJ=""
FOR
SET FHJ=$ORDER(^TMP($JOB,"FH",FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:2
+6 SET FHPTSA=FHJ
+7 FOR FHK=0:0
SET FHK=$ORDER(^TMP($JOB,"FH",FHI,FHJ,FHK))
if FHK'>0
QUIT
Begin DoDot:3
+8 SET FHDAT=""
+9 SET FHL=$ORDER(^TMP($JOB,"FH",FHI,FHJ,FHK,0))
+10 IF $GET(FHL)
DO REC
QUIT
+11 DO PROC
End DoDot:3
End DoDot:2
End DoDot:1
+12 WRITE !
QUIT
+13 ;
RMS ;SORT BY ROOM-BED
+1 MERGE ^TMP($JOB,"FHR")=^TMP($JOB,"FH")
KILL ^TMP($JOB,"FH")
+2 FOR
SET FHI=$ORDER(^TMP($JOB,"FHR",FHI))
if FHI=""
QUIT
Begin DoDot:1
+3 SET FHJ=""
FOR
SET FHJ=$ORDER(^TMP($JOB,"FHR",FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:2
+4 SET FHPTSA=FHJ
+5 FOR FHK=0:0
SET FHK=$ORDER(^TMP($JOB,"FHR",FHI,FHJ,FHK))
if FHK'>0
QUIT
Begin DoDot:3
+6 SET FHDAT=""
+7 SET FHL=$ORDER(^TMP($JOB,"FHR",FHI,FHJ,FHK,0))
+8 IF $GET(FHL)
DO RM1
QUIT
+9 DO RM2
End DoDot:3
End DoDot:2
End DoDot:1
+10 KILL ^TMP($JOB,"FHR")
+11 QUIT
RM1 FOR FHL=0:0
SET FHL=$ORDER(^TMP($JOB,"FHR",FHI,FHJ,FHK,FHL))
if FHL'>0
QUIT
Begin DoDot:1
+1 SET FHDAT=^TMP($JOB,"FHR",FHI,FHJ,FHK,FHL)
+2 SET FHDFN=$PIECE(FHDAT,U,2)
+3 SET RM=""
+4 IF $GET(FHDFN)
IF $DATA(^FHPT(FHDFN,"OP",FHL,0))
SET RM=$PIECE(^(0),U,18)
+5 IF $GET(RM)
IF $DATA(^DG(405.4,RM,0))
SET RM=$PIECE(^(0),U,1)
+6 if RM'=""
SET RM=$EXTRACT(RM,1,12)
+7 if RM=""
SET RM=" "
+8 SET ^TMP($JOB,"FH",FHI,RM,FHK,FHL)=FHDAT
End DoDot:1
+9 QUIT
RM2 SET FHDAT=^TMP($JOB,"FHR",FHI,FHJ,FHK)
+1 SET FHDFN=$PIECE(FHDAT,U,2)
+2 SET FHTYP=$PIECE(FHDAT,U,1)
+3 SET RM=""
+4 IF $GET(FHDFN)
IF FHTYP="GM"
IF $DATA(^FHPT(FHDFN,"GM",FHK,0))
SET RM=$PIECE(^(0),U,11)
+5 IF $GET(FHDFN)
IF FHTYP="SM"
IF $DATA(^FHPT(FHDFN,"SM",FHK,0))
SET RM=$PIECE(^(0),U,13)
+6 IF $GET(RM)
IF $DATA(^DG(405.4,RM,0))
SET RM=$PIECE(^(0),U,1)
+7 if RM'=""
SET RM=$EXTRACT(RM,1,12)
+8 if RM=""
SET RM=" "
+9 SET ^TMP($JOB,"FH",FHI,RM,FHK)=FHDAT
+10 QUIT
+11 ;
PROC ;process/print
+1 SET FHPLD=0
+2 if FHDAT=""
SET FHDAT=^TMP($JOB,"FH",FHI,FHJ,FHK)
+3 SET FHCAT=$PIECE(FHDAT,U,1)
+4 SET FHDFN=$PIECE(FHDAT,U,2)
+5 SET FHDIE=$PIECE(FHDAT,U,3)
+6 SET FHSTA=$PIECE(FHDAT,U,4)
+7 SET FHMEAL=$PIECE(FHDAT,U,5)
+8 SET FHLOC=$PIECE(FHDAT,U,6)
+9 SET FHDAIN=$PIECE(FHDAT,U,7)
+10 SET (FHSERT,FHSERC,FHSERD,FHSER)=""
+11 IF $GET(FHLOC)
IF $DATA(^FH(119.6,FHLOC,0))
Begin DoDot:1
+12 if $PIECE(^FH(119.6,FHLOC,0),U,5)
SET FHSERT="T"
+13 if $PIECE(^FH(119.6,FHLOC,0),U,6)
SET FHSERC="C"
+14 if $PIECE(^FH(119.6,FHLOC,0),U,7)
SET FHSERD="D"
+15 SET FHSER=FHSERT_FHSERC_FHSERD
End DoDot:1
+16 IF (FHXX="C")
IF (WRD>0)
IF (WRD'=FHSTA)
QUIT
+17 IF (FHXX="L")
IF (WRD>0)
IF (WRD'=FHLOC)
QUIT
+18 IF (SER'="A")
IF (FHSER'[SER)
QUIT
+19 IF FHI'=FHLSAV
SET FHLSAV=FHI
SET WRDN=$EXTRACT(FHI,3,$LENGTH(FHI))
DO HDR
+20 SET FHDIET=""
+21 DO PATNAME^FHOMUTL
+22 SET RM=""
+23 IF FHCAT="OP"
IF $DATA(^FHPT(FHDFN,"OP",FHDAIN,0))
SET RM=$PIECE(^(0),U,18)
+24 IF FHCAT="GM"
IF $DATA(^FHPT(FHDFN,"GM",FHDAIN,0))
SET RM=$PIECE(^(0),U,11)
+25 IF FHCAT="SM"
IF $DATA(^FHPT(FHDFN,"SM",FHDAIN,0))
SET RM=$PIECE(^(0),U,13)
+26 IF $GET(RM)
IF $DATA(^DG(405.4,RM,0))
SET RM=$PIECE(^DG(405.4,RM,0),U,1)
+27 IF FHLSAV'=FHI
SET FHLSAV=FHI
DO HDR
+28 WRITE !!,$EXTRACT(RM,1,12),?13,$EXTRACT(FHPTNM,1,24),?38,FHBID,?67,FHSER
+29 IF $Y>(IOSL-6)
DO HDR
+30 IF $DATA(^FH(111,FHDIE,0))
SET FHDIET=$PIECE(^FH(111,FHDIE,0),U,7)
+31 SET FHTYP=$SELECT(FHCAT="OP":"Recurring",FHCAT="GM":"Guest",FHCAT="SM":"Special",1:"")
+32 SET DTP=FHK
DO DTP^FH
+33 WRITE !,?14,"Diet Order: ",FHDIET,?40,"Meal: ","(",FHMEAL,")"
+34 WRITE !,?14,"Service Type: ",FHTYP,?40,"Date: ",DTP
+35 ;S FHDAIN=$O(^FHPT(FHDFN,""_FHCAT_"","B",FHK,0))
+36 IF $GET(FHDAIN)
IF $DATA(^FHPT(FHDFN,""_FHCAT_"",FHDAIN,"TF"))
DO OUTF
+37 IF $GET(FHDAIN)
IF FHCAT="OP"
IF $DATA(^FHPT(FHDFN,"OP",FHDAIN,"SP"))
DO OSO
+38 IF $GET(FHDAIN)
IF FHCAT="OP"
IF $DATA(^FHPT(FHDFN,"OP",FHDAIN,"SF"))
DO OSF
+39 SET FHPLD=1
+40 if '$GET(FHL)
DO ^FHORD83
+41 QUIT
+42 ;
OSO ;process outpt SOs.
+1 ;
+2 KILL N
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"OP",FHDAIN,"SP",K))
if K'>0
QUIT
SET X=^(K,0)
if $PIECE(X,"^",6)
QUIT
Begin DoDot:1
+3 SET M=$PIECE(X,"^",3)
SET N(M,K)=$PIECE(X,"^",2,4)
SET $PIECE(N(M,K),"^",4,5)=$PIECE(X,"^",8,9)
End DoDot:1
+4 FOR M="B","N","E"
FOR K=0:0
SET K=$ORDER(N(M,K))
if K<1
QUIT
SET Z=+N(M,K)
IF Z
Begin DoDot:1
+5 IF ($Y>(IOSL-6))
DO HDR
DO FLNE^FHORD82
+6 SET M2=$SELECT(M="B":"Break",M="N":"Noon",1:"Even")
SET QTY=$PIECE(N(M,K),"^",4)
+7 WRITE !?13,"Stng. Order: ",M2,?38,$SELECT(QTY:QTY,1:1)," ",$PIECE($GET(^FH(118.3,Z,0)),"^",1),$SELECT($PIECE(N(M,K),"^",5)'="Y":" (I)",1:"")
+8 SET X=$PIECE(N(M,K),"^",3)
DO DT
WRITE ?72,X
QUIT
End DoDot:1
+9 QUIT
+10 ;
OSF ;process outpt SFs.
+1 SET NM=$PIECE($GET(^FHPT(FHDFN,"OP",FHDAIN,"SF",0)),U,3)
if '$GET(NM)
QUIT
+2 KILL L,N,M,M1,M2
if 'NM
QUIT
SET Y=^FHPT(FHDFN,"OP",FHDAIN,"SF",NM,0)
if $PIECE(Y,"^",32)
QUIT
+3 SET L=4
FOR K1=1:1:3
SET K=0
SET N(K1)=""
FOR K2=1:1:4
SET Z=$PIECE(Y,U,L+1)
SET Q=$PIECE(Y,U,L+2)
SET L=L+2
IF Z'=""
if 'Q
SET Q=1
if N(K1)'=""
SET N(K1)=N(K1)_"; "
SET N(K1)=N(K1)_Q_" "_$SELECT($DATA(C(Z)):C(Z),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:" ")
+4 SET LST=$PIECE(Y,"^",30)\1
SET X=LST
SET P1=0
DO DT
if LST<OLN
SET X=X_"*"
+5 FOR K1=1:1:3
IF N(K1)'=""
WRITE !?13,$PIECE("10AM; 2PM; 8PM",";",K1),?19,$EXTRACT(N(K1),1,52)
IF 'P1
SET P1=1
WRITE ?72,X
+6 QUIT
+7 ;
REC ;set/get recurring data
+1 FOR FHL=0:0
SET FHL=$ORDER(^TMP($JOB,"FH",FHI,FHJ,FHK,FHL))
if FHL'>0
QUIT
Begin DoDot:1
+2 SET FHDAT=^TMP($JOB,"FH",FHI,FHJ,FHK,FHL)
+3 DO PROC
End DoDot:1
+4 if $GET(FHPLD)
DO ^FHORD83
+5 QUIT
+6 ;
OUTF ;outpatient TF
+1 SET REC=1
+2 SET (FHTFPR,FHTFQU,FHTFST,FHTFCOM,FHTFTC,FHTFKD,FHTFCN)=""
+3 IF $GET(FHDAIN)
IF $DATA(^FHPT(FHDFN,"OP",FHDAIN,3))
Begin DoDot:1
+4 SET FHRDAT3=$GET(^FHPT(FHDFN,"OP",FHDAIN,3))
+5 SET FHTFCOM=$PIECE(FHRDAT3,U,1)
+6 SET FHTFTC=$PIECE(FHRDAT3,U,2)
+7 SET FHTFTKD=$PIECE(FHRDAT3,U,3)
+8 SET FHTFCN=$PIECE(FHRDAT3,U,5)
+9 if FHTFCN="C"
SET FHTFCN="Cancelled"
End DoDot:1
+10 FOR FHTFDA=0:0
SET FHTFDA=$ORDER(^FHPT(FHDFN,"OP",FHDAIN,"TF",FHTFDA))
if FHTFDA'>0
QUIT
Begin DoDot:1
+11 SET FHTFDAT=$GET(^FHPT(FHDFN,"OP",FHDAIN,"TF",FHTFDA,0))
+12 SET FHTFPR=$PIECE(FHTFDAT,U,1)
+13 IF $GET(FHTFPR)
IF $DATA(^FH(118.2,FHTFPR,0))
SET FHTFPR=$PIECE(^FH(118.2,FHTFPR,0),U,1)
+14 SET FHTFST=$PIECE(FHTFDAT,U,2)
+15 if $GET(FHTFST)
SET FHTFST=$SELECT(FHTFST=1:"1/4",FHTFST=2:"1/2",FHTFST=3:"3/4",FHTFST=4:"FULL",1:"")
+16 SET FHTFQU=$PIECE(FHTFDAT,U,3)
+17 SET FHTFCC=$PIECE(FHTFDAT,U,4)
+18 ;I FHAOT'="" S ZZ=" Additional Order: "_FHAOT_" "_FHAOCN_" By: "_FHAOC D LNE^FHORD82
+19 ;I FHELTT'="" S ZZ=" Early/Late Tray Time: "_FHELTT_" Bag Meal: "_FHELTBM D LNE^FHOR82
+20 IF $Y>(IOSL-6)
DO LNE^FHORD82
+21 WRITE !,?5,"Tubefeed.:"
+22 SET ZZ=FHTFCOM_" TF Total MLs: "_FHTFTC_" TF Total KCALS/Day: "_FHTFTKD_" "_FHTFCN
WRITE ZZ
+23 IF FHTFPR'=""
Begin DoDot:2
+24 IF $Y>(IOSL-6)
DO LNE^FHORD82
+25 WRITE !,?5
+26 SET ZZ="TF Product: "_FHTFPR_" TF Strength: "_FHTFST_" TF Quantity: "_FHTFQU
+27 WRITE ZZ
+28 IF $Y>(IOSL-6)
DO LNE^FHORD82
+29 WRITE !,?5
+30 SET ZZ="TF Product ML/Day: "_FHTFCC_" "_FHTFCN
+31 WRITE ZZ
End DoDot:2
End DoDot:1
+32 QUIT
F0 ;
+1 IF $PIECE(X,U,3)="O"
QUIT
+2 IF FHXX="C"
SET K1=$PIECE(X,"^",8)
IF WRD
IF K1'=WRD
QUIT
+3 IF FHXX="L"
SET K1=$PIECE(X,"^",1)
IF WRD
IF W1'=WRD
QUIT
+4 SET K1=$SELECT(FHXX="W":"",K1<1:99,K1<10:"0"_K1,1:K1)
SET P0=$PIECE(X,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+5 SET WRDN=$PIECE(^FH(119.6,W1,0),"^",1)
SET ^TMP("FH",$JOB,K1_P0_$EXTRACT(WRDN,1,26),W1)=""
QUIT
F2 SET WRDN=$PIECE(^FH(119.6,W1,0),"^",1)
+1 KILL ^TMP($JOB)
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
if FHDFN<1
QUIT
SET ADM=^(FHDFN)
DO RM
+2 if '$DATA(^TMP($JOB,"FHSRT"))
QUIT
SET NX=""
DO HDR
L2 SET NX=$ORDER(^TMP($JOB,"FHSRT",NX))
IF NX=""
WRITE !
QUIT
+1 SET FHDFN=""
L3 ; Get Next Patient data
+1 SET FHDFN=$ORDER(^TMP($JOB,"FHSRT",NX,FHDFN))
if FHDFN=""
GOTO L2
SET ADM=^(FHDFN)
+2 DO PATNAME^FHOMUTL
IF DFN=""
GOTO L3
+3 if ADM<1
GOTO L3
SET Y(0)=^DPT(DFN,0)
if '$DATA(^DGPM(ADM,0))
GOTO L3
+4 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
GOTO L3
SET LEN=0
DO CUR^FHORD7
SET MEAL=Y
SET X0=^FHPT(FHDFN,"A",ADM,0)
if $LENGTH(MEAL)>48
SET LEN=$LENGTH($EXTRACT(MEAL,1,48),",")
+5 IF SER'="A"
IF $PIECE(X0,"^",5)'=SER
GOTO L3
+6 if $Y>(IOSL-6)
DO HDR
SET DTP=$PIECE(^DGPM(ADM,0),"^",1)
DO DTP^FH
+7 SET RM=$SELECT(SRT="R":NX,$DATA(^DPT(DFN,.101)):^(.101),1:"")
DO PID^FHDPA
+8 WRITE !!,RM,?13,$EXTRACT($PIECE(Y(0),"^",1),1,24),?38,BID,?47,DTP
+9 SET Y=$PIECE(X0,"^",5)
IF Y'=""
WRITE ?67,Y
+10 DO GET
IF Y'=""
WRITE !?13,"Nut. Status: ",Y
SET X=+X5
DO DT
WRITE ?72,X
+11 DO ALG^FHCLN
IF ALG'=""
WRITE !?13,"Allergies: "
SET ZZ=ALG
DO LNE^FHORD82
+12 IF "NO ORDER"'[MEAL!'$PIECE(X0,"^",4)
WRITE !?13,"Diet Order: ",$SELECT(LEN:$PIECE(MEAL,",",1,LEN-1)_",",1:MEAL)
+13 IF $TEST
IF FHORD
SET X=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",9)
DO DT
WRITE ?72,X
if FHLD'=""
DO NPO
if LEN
WRITE !?24,$PIECE(MEAL,",",LEN,999)
DO COM
+14 GOTO ^FHORD82
GET SET Y=""
SET X5=$ORDER(^FHPT(FHDFN,"S",0))
if X5=""
QUIT
SET X5=^(X5,0)
+1 if $PIECE(X5,"^",1)<$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",1)
QUIT
+2 SET Y=$PIECE($GET(^FH(115.4,+$PIECE(X5,"^",2),0)),"^",2)
QUIT
NPO SET LST=0
FOR K1=0:0
SET K1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K1))
if K1<1!(K1>NOW)
QUIT
IF $PIECE(^(K1,0),"^",2)=FHORD
SET LST=K1
+1 if LST<OLD
WRITE "*"
QUIT
COM ; List comment if any
+1 SET COM=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
if COM=""
QUIT
IF $LENGTH(COM)<51
WRITE !?16,COM
QUIT
+2 FOR LEN=51:-1:1
if $EXTRACT(COM,LEN)=" "
QUIT
+3 WRITE !?16,$EXTRACT(COM,1,LEN-1)
SET COM=$EXTRACT(COM,LEN+1,999)
+4 if COM'=""
WRITE !?19,COM
QUIT
DT SET X=$JUSTIFY(+$EXTRACT(X,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(X,4,5))
QUIT
RM ;
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 IF SRT="R"
SET RM=$GET(^DPT(DFN,.101))
+3 IF '$TEST
SET RM=$PIECE($GET(^DPT(DFN,0)),"^",1)
+4 if RM=""
SET RM=" "
SET ^TMP($JOB,"FHSRT",RM,FHDFN)=ADM
QUIT
HDR ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH
+1 WRITE @IOF
SET PG=PG+1
SET DTP=NOW
DO DTP^FH
+2 WRITE !,DTP,?(67-$LENGTH(WRDN)\2),WRDN," DIET ORDERS",?72,"Page ",PG
+3 IF SER'="A"
SET X=$SELECT(SER="T":"TRAY",SER="C":"CAFETERIA",1:"DINING ROOM")_" Service Only"
WRITE !!?(79-$LENGTH(X)\2),X
+4 WRITE !!,"Room",?13,"Patient",?39,"ID#",?48,"Admission Date",?66,"Svc",?71,"Ord Date"
QUIT
