FHORD9 ; HISC/REL/NCA/RVD - Diet Order Census ;7/1/94 14:24
;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
;
;patch #5 - added screen for cancelled guest meals.
;
D NOW^%DTC S DT=%\1 K %,^TMP($J)
D DIV^FHOMUTL G:'$D(FHSITE) KIL
S FHP=$O(^FH(119.71,0)) I FHP'<1,$O(^FH(119.71,FHP))<1 G F0
D0 R !!,"Select PRODUCTION FACILITY: ",X:DTIME G:'$T!("^"[X) KIL
K DIC S DIC="^FH(119.71,",DIC(0)="EMQ" D ^DIC G:Y<1 D0 S FHP=+Y
F0 R !!,"Effective Date/Time: ",X:DTIME G:'$T!("^"[X) KIL S %DT="ETSX" D ^%DT G:Y<1 F0 S TIM=Y
I (TIM\1)<DT W *7," Cannot be before TODAY!" G F0
W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHORD9",FHLST="FHP^TIM^FHSITE^FHSITENM" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Calculate census
K ^TMP($J) S CT=0 D NOW^%DTC S NOW=% K %,D,P
F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0) D
.I '$G(FHSITE) D WRD
.I ($G(FHSITE)),($P(X,U,8)=FHSITE) D WRD
;
;get outpatient data
S:'$G(FHSITE) FHSITE=""
S:'$D(FHSITENM) FHSITENM="CONSOLIDATED"
D GETSM^FHOMRBLD(TIM,FHSITE,"","")
D GETGM^FHOMRBL1(TIM,FHSITE,"","")
S FHTIM=$P(TIM,".",1),FHTIM=FHTIM-.000001
D GETRM^FHOMRBLD(FHTIM,FHSITE,"","")
D PROSG ;process recurring, special and guest meal from "OP" node
G ^FHORD91
WRD ; Calculate census for ward
K S S X1="" F D2=5,6 S N1=$P(X,"^",D2) Q:$G(^FH(119.72,+N1,"I"))="Y" S N2=$P($G(^FH(119.72,+N1,0)),"^",3) I N2=FHP S S($E("TC",D2-4))=N1,D(N1)="",X1=X1_$E("TC",D2-4)
Q:'$D(S)
S:$L(X1)>1 X1=$E(X1,1) Q:'$D(S(X1)) S SP=S(X1)
F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",WRD,FHDFN)) I ADM>0 S K=SP D W3
Q
W3 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
S X0=^FHPT(FHDFN,"A",ADM,0)
S FHORD=$P(X0,"^",2),X1=$P(X0,"^",3),TF=$P(X0,"^",4),N1=$P(X0,"^",5) S:N1="" N1="T"
I FHORD<1 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",0)) G:A1=""!(A1>TIM) W4 D U1 G:'FHORD W4 S X1=""
I X1>1,X1'>TIM D U1 G:'FHORD W4
I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) D U1 G:'FHORD W4
S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),X1=$P(X,"^",8)
S:X1="" X1=N1 S:X1="D" X1="T" Q:'$D(S(X1)) S K=S(X1) D CNT
I FHLD="" S Z=$P(X,"^",13) S:Z="" FHLD="X" I Z S:'$D(P(Z,K)) P(Z,K)=0 S P(Z,K)=P(Z,K)+1 Q
I FHLD="P" S:'$D(P(.8,K)) P(.8,K)=0 S P(.8,K)=P(.8,K)+1 Q
I FHLD="N" D Q
.I TF="" S:'$D(P(.5,K)) P(.5,K)=0 S P(.5,K)=P(.5,K)+1 Q
.S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1 Q
Q:'TF S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1 Q
W4 G:'TF CNT S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1
CNT S:'$D(P(.6,K)) P(.6,K)=0 S P(.6,K)=P(.6,K)+1 Q
U1 S (A1,FHORD)=0 F K1=0:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"AC",K1)) Q:K1<1!(K1>TIM) S A1=K1
Q:'A1 S X1=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G U2:X1<1,U2:'$D(^FHPT(FHDFN,"A",ADM,"DI",X1,0)) S FHORD=X1 Q
U2 S X1="",A1=0
U3 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) G:A1="" U1 S X2=$P(^(A1,0),"^",2)
I X2<1 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G U3
I '$D(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) K ^FHPT(FHDFN,"A",ADM,"AC",A1) G U3
G U3
PROSG ;process outpatient data from ^tmp($j global.
S FHPLNM=""
S:$G(FHSITE) FHPLNM=$P($G(^FH(119.73,FHSITE,0)),U,1)
REC ;for recurring meals
S FHDT=TIM+.999999
;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
S FHTMPS="^TMP($J,""OP"",""R"")"
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
..Q:$P(FHRDAT,U,19)="C" ;quit if status is cancelled.
..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
..S FHREIEN=$P(FHIJKDAT,U,1)
..S FHDIETN=$P(FHIJKDAT,U,3)
..S:$D(^FH(111,"B",FHDIETN)) FHDIET=$O(^FH(111,"B",FHDIETN,0))
..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
..;if tubefeeding, also count the TF data.
..I $D(^FHPT(FHREIEN,"OP",FHK,"TF")) D
...I '$D(P(.7,FHSER)) S P(.7,FHSER)=1
...E S P(.7,FHSER)=P(.7,FHSER)+1
...S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
;
SPEC ;for special meals
S FHTMPS="^TMP($J,""OP"",""S"")" I '$D(FHPLNM) S FHPLNM=""
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
..S FHSTAT=$P(FHIJKDAT,U,3)
..Q:FHSTAT'="A" ;quit if status is not Authorized
..S FHDIETN=$P(FHIJKDAT,U,4)
..S:$D(^FH(111,"B",FHDIETN)) FHDIET=$O(^FH(111,"B",FHDIETN,0))
..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
;
GUEST ;for guest meals.
;If no diet, use default outpatient diet in file #119.9.
;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
S FHTMPS="^TMP($J,""OP"",""G"")" I '$D(FHPLNM) S FHPLNM=""
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
..I $P(FHRDAT,U,7)="C" Q
..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
..S FHDIETN=$P(FHIJKDAT,U,6)
..S:$D(^FH(111,FHDIETN,0)) FHPDIET=$P(^FH(111,FHDIETN,0),U,5)
..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
;
Q
;
KIL K ^TMP($J) G KILL^XUSCLEAN
;K %,%H,%I,%T,%DT,%ZIS,A1,ADM,CHK,CT,D,D1,D2,FHDFN,DFN,DIC,DOW,DTP,FHLD,FHOR,FHP,FHPAR,K,K1,KK,L1,LP,N,N1,N2,N3,NOW,NXW,FHORD,P,P1,POP,S,SP,TF,TIM,TOT,TYP,WRD,WRDN,X,X0,X1,X2,Y,Z K ^TMP($J) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD9 7311 printed Oct 16, 2024@17:54:30 Page 2
FHORD9 ; HISC/REL/NCA/RVD - Diet Order Census ;7/1/94 14:24
+1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
+2 ;
+3 ;patch #5 - added screen for cancelled guest meals.
+4 ;
+5 DO NOW^%DTC
SET DT=%\1
KILL %,^TMP($JOB)
+6 DO DIV^FHOMUTL
if '$DATA(FHSITE)
GOTO KIL
+7 SET FHP=$ORDER(^FH(119.71,0))
IF FHP'<1
IF $ORDER(^FH(119.71,FHP))<1
GOTO F0
D0 READ !!,"Select PRODUCTION FACILITY: ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
+1 KILL DIC
SET DIC="^FH(119.71,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO D0
SET FHP=+Y
F0 READ !!,"Effective Date/Time: ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
SET %DT="ETSX"
DO ^%DT
if Y<1
GOTO F0
SET TIM=Y
+1 IF (TIM\1)<DT
WRITE *7," Cannot be before TODAY!"
GOTO F0
+2 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+3 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHORD9"
SET FHLST="FHP^TIM^FHSITE^FHSITENM"
DO EN2^FH
GOTO KIL
+4 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Calculate census
+1 KILL ^TMP($JOB)
SET CT=0
DO NOW^%DTC
SET NOW=%
KILL %,D,P
+2 FOR WRD=0:0
SET WRD=$ORDER(^FH(119.6,WRD))
if WRD<1
QUIT
SET X=^(WRD,0)
Begin DoDot:1
+3 IF '$GET(FHSITE)
DO WRD
+4 IF ($GET(FHSITE))
IF ($PIECE(X,U,8)=FHSITE)
DO WRD
End DoDot:1
+5 ;
+6 ;get outpatient data
+7 if '$GET(FHSITE)
SET FHSITE=""
+8 if '$DATA(FHSITENM)
SET FHSITENM="CONSOLIDATED"
+9 DO GETSM^FHOMRBLD(TIM,FHSITE,"","")
+10 DO GETGM^FHOMRBL1(TIM,FHSITE,"","")
+11 SET FHTIM=$PIECE(TIM,".",1)
SET FHTIM=FHTIM-.000001
+12 DO GETRM^FHOMRBLD(FHTIM,FHSITE,"","")
+13 ;process recurring, special and guest meal from "OP" node
DO PROSG
+14 GOTO ^FHORD91
WRD ; Calculate census for ward
+1 KILL S
SET X1=""
FOR D2=5,6
SET N1=$PIECE(X,"^",D2)
if $GET(^FH(119.72,+N1,"I"))="Y"
QUIT
SET N2=$PIECE($GET(^FH(119.72,+N1,0)),"^",3)
IF N2=FHP
SET S($EXTRACT("TC",D2-4))=N1
SET D(N1)=""
SET X1=X1_$EXTRACT("TC",D2-4)
+2 if '$DATA(S)
QUIT
+3 if $LENGTH(X1)>1
SET X1=$EXTRACT(X1,1)
if '$DATA(S(X1))
QUIT
SET SP=S(X1)
+4 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",WRD,FHDFN))
if FHDFN<1
QUIT
SET ADM=$GET(^FHPT("AW",WRD,FHDFN))
IF ADM>0
SET K=SP
DO W3
+5 QUIT
W3 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
+1 SET X0=^FHPT(FHDFN,"A",ADM,0)
+2 SET FHORD=$PIECE(X0,"^",2)
SET X1=$PIECE(X0,"^",3)
SET TF=$PIECE(X0,"^",4)
SET N1=$PIECE(X0,"^",5)
if N1=""
SET N1="T"
+3 IF FHORD<1
SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",0))
if A1=""!(A1>TIM)
GOTO W4
DO U1
if 'FHORD
GOTO W4
SET X1=""
+4 IF X1>1
IF X1'>TIM
DO U1
if 'FHORD
GOTO W4
+5 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
DO U1
if 'FHORD
GOTO W4
+6 SET X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
SET FHOR=$PIECE(X,"^",2,6)
SET FHLD=$PIECE(X,"^",7)
SET X1=$PIECE(X,"^",8)
+7 if X1=""
SET X1=N1
if X1="D"
SET X1="T"
if '$DATA(S(X1))
QUIT
SET K=S(X1)
DO CNT
+8 IF FHLD=""
SET Z=$PIECE(X,"^",13)
if Z=""
SET FHLD="X"
IF Z
if '$DATA(P(Z,K))
SET P(Z,K)=0
SET P(Z,K)=P(Z,K)+1
QUIT
+9 IF FHLD="P"
if '$DATA(P(.8,K))
SET P(.8,K)=0
SET P(.8,K)=P(.8,K)+1
QUIT
+10 IF FHLD="N"
Begin DoDot:1
+11 IF TF=""
if '$DATA(P(.5,K))
SET P(.5,K)=0
SET P(.5,K)=P(.5,K)+1
QUIT
+12 if '$DATA(P(.7,K))
SET P(.7,K)=0
SET P(.7,K)=P(.7,K)+1
QUIT
End DoDot:1
QUIT
+13 if 'TF
QUIT
if '$DATA(P(.7,K))
SET P(.7,K)=0
SET P(.7,K)=P(.7,K)+1
QUIT
W4 if 'TF
GOTO CNT
if '$DATA(P(.7,K))
SET P(.7,K)=0
SET P(.7,K)=P(.7,K)+1
CNT if '$DATA(P(.6,K))
SET P(.6,K)=0
SET P(.6,K)=P(.6,K)+1
QUIT
U1 SET (A1,FHORD)=0
FOR K1=0:0
SET K1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K1))
if K1<1!(K1>TIM)
QUIT
SET A1=K1
+1 if 'A1
QUIT
SET X1=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
if X1<1
GOTO U2
if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",X1,0))
GOTO U2
SET FHORD=X1
QUIT
U2 SET X1=""
SET A1=0
U3 SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
if A1=""
GOTO U1
SET X2=$PIECE(^(A1,0),"^",2)
+1 IF X2<1
KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
GOTO U3
+2 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",X2,0))
KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
GOTO U3
+3 GOTO U3
PROSG ;process outpatient data from ^tmp($j global.
+1 SET FHPLNM=""
+2 if $GET(FHSITE)
SET FHPLNM=$PIECE($GET(^FH(119.73,FHSITE,0)),U,1)
REC ;for recurring meals
+1 SET FHDT=TIM+.999999
+2 ;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
+3 SET FHTMPS="^TMP($J,""OP"",""R"")"
+4 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+5 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+6 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>FHDT)
QUIT
Begin DoDot:2
+7 SET (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
+8 ;quit if status is cancelled.
if $PIECE(FHRDAT,U,19)="C"
QUIT
+9 SET (FHPDIET,FHDIET,FHSER,FHLOC)="***"
+10 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+11 if $GET(FHLOC)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
+12 if '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
+13 if '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
+14 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+15 IF $GET(FHSITE)
IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
QUIT
+16 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
+17 SET FHREIEN=$PIECE(FHIJKDAT,U,1)
+18 SET FHDIETN=$PIECE(FHIJKDAT,U,3)
+19 if $DATA(^FH(111,"B",FHDIETN))
SET FHDIET=$ORDER(^FH(111,"B",FHDIETN,0))
+20 if $DATA(^FH(111,FHDIET,0))
SET FHPDIET=$PIECE(^FH(111,FHDIET,0),U,5)
+21 if '$DATA(P(FHPDIET,FHSER))
SET P(FHPDIET,FHSER)=0
+22 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
+23 if '$DATA(P(.6,FHSER))
SET P(.6,FHSER)=0
SET P(.6,FHSER)=P(.6,FHSER)+1
+24 ;if tubefeeding, also count the TF data.
+25 IF $DATA(^FHPT(FHREIEN,"OP",FHK,"TF"))
Begin DoDot:3
+26 IF '$DATA(P(.7,FHSER))
SET P(.7,FHSER)=1
+27 IF '$TEST
SET P(.7,FHSER)=P(.7,FHSER)+1
+28 if '$DATA(P(.6,FHSER))
SET P(.6,FHSER)=0
SET P(.6,FHSER)=P(.6,FHSER)+1
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
SPEC ;for special meals
+1 SET FHTMPS="^TMP($J,""OP"",""S"")"
IF '$DATA(FHPLNM)
SET FHPLNM=""
+2 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+3 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+4 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>FHDT)
QUIT
Begin DoDot:2
+5 SET (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
+6 SET (FHPDIET,FHDIET,FHSER,FHLOC)="***"
+7 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+8 if $GET(FHLOC)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
+9 if '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
+10 if '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
+11 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+12 IF $GET(FHSITE)
IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
QUIT
+13 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
+14 SET FHSTAT=$PIECE(FHIJKDAT,U,3)
+15 ;quit if status is not Authorized
if FHSTAT'="A"
QUIT
+16 SET FHDIETN=$PIECE(FHIJKDAT,U,4)
+17 if $DATA(^FH(111,"B",FHDIETN))
SET FHDIET=$ORDER(^FH(111,"B",FHDIETN,0))
+18 if $DATA(^FH(111,FHDIET,0))
SET FHPDIET=$PIECE(^FH(111,FHDIET,0),U,5)
+19 if '$DATA(P(FHPDIET,FHSER))
SET P(FHPDIET,FHSER)=0
+20 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
+21 if '$DATA(P(.6,FHSER))
SET P(.6,FHSER)=0
SET P(.6,FHSER)=P(.6,FHSER)+1
End DoDot:2
End DoDot:1
+22 ;
GUEST ;for guest meals.
+1 ;If no diet, use default outpatient diet in file #119.9.
+2 ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
+3 SET FHTMPS="^TMP($J,""OP"",""G"")"
IF '$DATA(FHPLNM)
SET FHPLNM=""
+4 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+5 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+6 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>FHDT)
QUIT
Begin DoDot:2
+7 SET (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
+8 IF $PIECE(FHRDAT,U,7)="C"
QUIT
+9 SET (FHPDIET,FHDIET,FHSER,FHLOC)="***"
+10 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+11 if $GET(FHLOC)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
+12 if '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
+13 if '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
+14 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+15 IF $GET(FHSITE)
IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
QUIT
+16 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
+17 SET FHDIETN=$PIECE(FHIJKDAT,U,6)
+18 if $DATA(^FH(111,FHDIETN,0))
SET FHPDIET=$PIECE(^FH(111,FHDIETN,0),U,5)
+19 if '$DATA(P(FHPDIET,FHSER))
SET P(FHPDIET,FHSER)=0
+20 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
+21 if '$DATA(P(.6,FHSER))
SET P(.6,FHSER)=0
SET P(.6,FHSER)=P(.6,FHSER)+1
End DoDot:2
End DoDot:1
+22 ;
+23 QUIT
+24 ;
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
+1 ;K %,%H,%I,%T,%DT,%ZIS,A1,ADM,CHK,CT,D,D1,D2,FHDFN,DFN,DIC,DOW,DTP,FHLD,FHOR,FHP,FHPAR,K,K1,KK,L1,LP,N,N1,N2,N3,NOW,NXW,FHORD,P,P1,POP,S,SP,TF,TIM,TOT,TYP,WRD,WRDN,X,X0,X1,X2,Y,Z K ^TMP($J) Q
