FHORD93 ; HISC/NCA/RVD - Diet Census Percentage (Cont.) ;1/23/98 16:09
;;5.5;DIETETICS;**3**;Jan 28, 2005
;RVD patch #3 7/20/05 remove dependency with FHPRO* routines.
;
Q1 ; Calculate Census
S X=D1 D DOW^%DTC S DOW=Y+1 D NOW^%DTC S NOW=% S PG=0
G:FHAN'="Y" GET
I MEAL'="A" G Q2
F MEAL="B","N","E" D Q2
Q
Q2 S K3=$F("BNE",MEAL)-1,FHX1=$P(FHDA,"^",K3+1) D CEN:FHP1["C",FOR:FHP1["F",LST
Q
CEN ;census
S X=D1_"@"_$S(MEAL="B":"7AM",MEAL="N":"11AM",1:"4PM"),%DT="TX" D ^%DT S TIM=Y
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),($P(X,U,8)'=FHSITE) Q
.S FHSER=$P(X,U,5) S:$G(FHSER) SP(FHSER)=""
.S FHSER=$P(X,U,6) S:$G(FHSER) SP(FHSER)=""
.I '$G(FHSITE) D WRD^FHORD9 Q
.I $G(FHSITE),$P(X,U,8)=FHSITE D WRD^FHORD9
;
OUT ;process outpatient data
REC S FHTIM=D1-.000001,FHDT299=D1+.99999
F FHIR=FHTIM:0 S FHIR=$O(^FHPT("RM",FHIR)) Q:(FHIR'>0)!(FHIR>(FHDT299)) F FHIDFN=0:0 S FHIDFN=$O(^FHPT("RM",FHIR,FHIDFN)) Q:FHIDFN'>0 D
.F FHIEN=0:0 S FHIEN=$O(^FHPT("RM",FHIR,FHIDFN,FHIEN)) Q:FHIEN'>0 D
..S FHREDAT=$G(^FHPT(FHIDFN,"OP",FHIEN,0))
..Q:$P(FHREDAT,U,4)'=MEAL
..Q:$P(FHREDAT,U,15)="C"
..S FHLOC=$P(FHREDAT,U,3) Q:'$G(FHLOC)
..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
..S FHRDIET=$P(FHREDAT,U,2) Q:'$G(FHRDIET)
..S FHPDIET=$P($G(^FH(111,FHRDIET,0)),U,5)
..I $G(FHLOC) D
...S FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5) S:$G(FHSER) SP(FHSER)=""
...I '$G(FHSER) S FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6) S:$G(FHSER) SP(FHSER)=""
...I '$G(FHSER) S FHSER=$O(^FH(119.72,0)) S:$G(FHSER) SP(FHSER)=""
..Q:'$G(FHSER)
..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
..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 and not cancelled, also count the TF data.
..I $D(^FHPT(FHIDFN,"OP",FHIEN,"TF")) D
...Q:$P(^FHPT(FHIDFN,"OP",FHIEN,3),U,5)="C"
...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
;
S FHDT=D1+.999999
D GETSM^FHOMRBLD(FHTIM,FHSITE,"","")
D SPEC^FHORD9
D GETGM^FHOMRBL1(FHTIM,FHSITE,"","")
D GUEST^FHORD9
;
COMB ;
K D,NP,T F LP=0:0 S LP=$O(P(.5,LP)) Q:LP<1 S:'$D(NP(.5,LP)) NP(.5,LP)=0 S NP(.5,LP)=NP(.5,LP)+P(.5,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.5,LP)
K P(.5) F LP=0:0 S LP=$O(P(.7,LP)) Q:LP<1 S:'$D(NP(.7,LP)) NP(.7,LP)=0 S NP(.7,LP)=NP(.7,LP)+P(.7,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.7,LP)
K P(.7) F LL=0:0 S LL=$O(P(.6,LL)) Q:LL<1 S:'$D(NP(.6,LL)) NP(.6,LL)=0 S NP(.6,LL)=NP(.6,LL)+P(.6,LL)
K P(.6) F LL=0:0 S LL=$O(P(.8,LL)) Q:LL<1 S:'$D(NP(.8,LL)) NP(.8,LL)=0 S NP(.8,LL)=NP(.8,LL)+P(.8,LL) S:'$D(D(LL)) D(LL)=0 S D(LL)=D(LL)+P(.8,LL)
K P(.8) F LL=0:0 S LL=$O(P(LL)) Q:LL<1 F P0=0:0 S P0=$O(P(LL,P0)) Q:P0<1 S:'$D(T(P0)) T(P0)=0 S T(P0)=T(P0)+P(LL,P0)
F LP=0:0 S LP=$O(NP(.6,LP)) Q:LP<1 S:$D(T(LP)) NP(.6,LP)=NP(.6,LP)-T(LP)-$G(D(LP)) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+NP(.6,LP)
F P0=0:0 S P0=$O(^FH(119.72,P0)) Q:P0<1 I $P(^(P0,0),"^",3)=FHP I $D(^FH(119.72,P0,"B")) D D0
K ^TMP($J) F LL=0:0 S LL=$O(P(LL)) Q:LL<1 S P(LL,0)=0 F P0=0:0 S P0=$O(P(LL,P0)) Q:P0<1 S ^TMP($J,P0,LL)=P(LL,P0) S:'$D(D(P0)) D(P0)="" S D(P0)=D(P0)+P(LL,P0),P(LL,0)=P(LL,0)+P(LL,P0)
F P0=0:0 S P0=$O(D(P0)) Q:P0<1 S ^TMP($J,P0)=D(P0)
F LL=0:0 S LL=$O(P(LL)) Q:LL<1 I $G(P(LL,0)) S ^TMP($J,0,LL)=P(LL,0)
K P,D Q
D0 ;
I '$D(SP(P0)) Q
I $G(^FH(119.72,P0,"I"))="Y" Q
F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 S Y=$P(^(LL,0),"^",3*DOW-2+K3) I Y>0 S:'$D(P(LL,P0)) P(LL,P0)=0 S P(LL,P0)=P(LL,P0)+Y
Q
;
FOR ;FORCAST
K ^TMP($J) F P0=0:0 S P0=$O(M2(P0)) Q:P0<1 S ^TMP($J,P0)=M2(P0)
K D F P0=0:0 S P0=$O(M2(P0)) Q:P0<1 S S1=M2(P0) D PER S ^TMP($J,P0)=S0
F P0=0:0 S P0=$O(^TMP($J,P0)) Q:P0<1 I $D(^FH(119.72,P0,"B")) D F1
F LL=0:0 S LL=$O(D(LL)) Q:LL<1 S ^TMP($J,0,LL)=D(LL)
K D Q
F1 F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 S Y=$P(^(LL,0),"^",3*DOW-2+K3) I Y>0 S D(LL)=$G(D(LL))+Y,^TMP($J,P0)=^TMP($J,P0)+Y,^TMP($J,P0,LL)=$G(^TMP($J,P0,LL))+Y
Q
PER S S0=0 F K=0:0 S K=$O(^FH(119.72,P0,"A",K)) Q:K<1 S Z=$P($G(^(K,0)),"^",DOW+1),Z=$J(Z*S1/100,0,0) I Z S ^TMP($J,P0,K)=Z,S0=S0+Z,D(K)=$G(D(K))+Z
Q
;
GET F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0),TIM=D1 I $P(X,U,8)=FHSITE D WRD^FHORD9
;get outpatient data
S FHTIM=D1-.000001
F FHIR=FHTIM:0 S FHIR=$O(^FHPT("RM",FHIR)) Q:(FHIR'>0)!(FHIR>(FHTIM+1)) F FHIDFN=0:0 S FHIDFN=$O(^FHPT("RM",FHIR,FHIDFN)) Q:FHIDFN'>0 D
.F FHIEN=0:0 S FHIEN=$O(^FHPT("RM",FHIR,FHIDFN,FHIEN)) Q:FHIEN'>0 D
..S FHREDAT=$G(^FHPT(FHIDFN,"OP",FHIEN,0))
..S FHLOC=$P(FHREDAT,U,3)
..Q:$P(FHREDAT,U,5)="C" ;quit if cancelled
..Q:$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
..S FHRDIET=$P(FHREDAT,U,2),FHPDIET=$P($G(^FH(111,FHRDIET,0)),U,5)
..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
..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
..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 and not cancelled, count the TF data.
..I $D(^FHPT(FHIDFN,"OP",FHIEN,"TF")) D
...Q:$P(^FHPT(FHIDFN,"OP",FHIEN,3),U,5)="C"
...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
S FHPLNM=$P($G(^FH(119.73,FHSITE,0)),U,1)
S FHDT=D1+.999999
D GETSM^FHOMRBLD(FHTIM,FHSITE,"","")
D SPEC^FHORD9
D GETGM^FHOMRBL1(FHTIM,FHSITE,"","")
D GUEST^FHORD9
;
K D,NP F LP=0:0 S LP=$O(P(.5,LP)) Q:LP<1 S:'$D(NP(.5,LP)) NP(.5,LP)=0 S NP(.5,LP)=NP(.5,LP)+P(.5,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.5,LP)
K P(.5) F LP=0:0 S LP=$O(P(.7,LP)) Q:LP<1 S:'$D(NP(.7,LP)) NP(.7,LP)=0 S NP(.7,LP)=NP(.7,LP)+P(.7,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.7,LP)
K P(.7) F LP=0:0 S LP=$O(P(.6,LP)) Q:LP<1 S:'$D(NP(.6,LP)) NP(.6,LP)=0 S NP(.6,LP)=NP(.6,LP)+P(.6,LP)
K P(.6) F LP=0:0 S LP=$O(P(.8,LP)) Q:LP<1 S:'$D(NP(.8,LP)) NP(.8,LP)=0 S NP(.8,LP)=NP(.8,LP)+P(.8,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.8,LP)
K P(.8),^TMP($J) F LL=0:0 S LL=$O(P(LL)) Q:LL<1 S P(LL,0)=0 F P0=0:0 S P0=$O(P(LL,P0)) Q:P0<1 S ^TMP($J,P0,LL)=P(LL,P0) S:'$D(D(P0)) D(P0)="" S D(P0)=D(P0)+P(LL,P0),P(LL,0)=P(LL,0)+P(LL,P0)
F LP=0:0 S LP=$O(NP(.6,LP)) Q:LP<1 S:$D(D(LP)) NP(.6,LP)=NP(.6,LP)-D(LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+NP(.6,LP)
F P0=0:0 S P0=$O(D(P0)) Q:P0<1 S ^TMP($J,P0)=D(P0)
F LL=0:0 S LL=$O(P(LL)) Q:LL<1 I $G(P(LL,0)) S ^TMP($J,0,LL)=P(LL,0)
K P,D
;
LST K S S L1=30
F P0=0:0 S P0=$O(^TMP($J,P0)) Q:P0="" S X=^FH(119.72,P0,0),N1=$P(X,"^",1),N2=$P(X,"^",2),N3=$P(X,"^",4) S:N3="" N3=$E(N1,1,6) S S(N3,P0)=$J(N3,8)_"^"_N2,L1=L1+10
S:L1<80 L1=80 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
S Z=$S(FHP1["F":"F O R E C A S T E D",1:"A C T U A L")_" D I E T C E N S U S"
S DTP=NOW D DTP^FH W !,DTP,?(L1-$L(Z)\2),Z,?(L1-7),"Page ",PG,!?(L1-21\2),"P E R C E N T A G E S"
W !,$G(FHSITENM)
S Z=$P(^FH(119.71,FHP,0),"^",1),DTP=D1 D DTP^FH
S X=D1\1 D DOW^%DTC S DOW=Y+1,X=$P("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",DOW)_"day "_DTP I FHAN="Y" S X=X_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
S DTP=D1\1 D DTP^FH W !!?(L1-$L(Z)\2),Z,!!?(L1-$L(X)\2),X
W !!?(L1-31\2),"P R O D U C T I O N D I E T S",!!?29
S X="" F S X=$O(S(X)) Q:X="" F K=0:0 S K=$O(S(X,K)) Q:K="" W $P(S(X,K),"^",1)_" %"
W !
F P1=0:0 S P1=$O(^FH(116.2,"AP",P1)) Q:P1<1 F K=0:0 S K=$O(^FH(116.2,"AP",P1,K)) Q:K<1 I $D(^TMP($J,0,K)) D PRO
I FHP1'["F" W !?3,"N P O",?31 S K=.5 D P1 K NP(.5)
I FHP1'["F" W !?3,"P A S S",?31 S K=.8 D P1 K NP(.8)
I FHP1'["F" W !?3,"TF Only",?31 S K=.7 D P1 K NP(.7)
I FHP1'["F" W !?3,"No Order",?31 S K=.6 D P1 K NP(.6)
W !
Q
PRO W !,$P($G(^FH(116.2,K,0)),"^",1),?31
P1 F S X=$O(S(X)) Q:X="" F K1=0:0 S K1=$O(S(X,K1)) Q:K1="" S Z=$S(K>.9:$G(^TMP($J,K1,K)),1:$G(NP(K,K1))),Z=$S($G(^TMP($J,K1)):Z/$G(^TMP($J,K1))*100,1:"") W $J(Z,8,1)," "
Q
FHORD93 ; HISC/NCA/RVD - Diet Census Percentage (Cont.) ;1/23/98 16:09
+1 ;;5.5;DIETETICS;**3**;Jan 28, 2005
+2 ;RVD patch #3 7/20/05 remove dependency with FHPRO* routines.
+3 ;
Q1 ; Calculate Census
+1 SET X=D1
DO DOW^%DTC
SET DOW=Y+1
DO NOW^%DTC
SET NOW=%
SET PG=0
+2 IF FHAN'="Y"
GOTO GET
+3 IF MEAL'="A"
GOTO Q2
+4 FOR MEAL="B","N","E"
DO Q2
+5 QUIT
Q2 SET K3=$FIND("BNE",MEAL)-1
SET FHX1=$PIECE(FHDA,"^",K3+1)
IF FHP1["C"
DO CEN
IF FHP1["F"
DO FOR
DO LST
+1 QUIT
CEN ;census
+1 SET X=D1_"@"_$SELECT(MEAL="B":"7AM",MEAL="N":"11AM",1:"4PM")
SET %DT="TX"
DO ^%DT
SET TIM=Y
+2 KILL D,P
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)
IF ($PIECE(X,U,8)'=FHSITE)
QUIT
+4 SET FHSER=$PIECE(X,U,5)
IF $GET(FHSER)
SET SP(FHSER)=""
+5 SET FHSER=$PIECE(X,U,6)
IF $GET(FHSER)
SET SP(FHSER)=""
+6 IF '$GET(FHSITE)
DO WRD^FHORD9
QUIT
+7 IF $GET(FHSITE)
IF $PIECE(X,U,8)=FHSITE
DO WRD^FHORD9
End DoDot:1
+8 ;
OUT ;process outpatient data
REC SET FHTIM=D1-.000001
SET FHDT299=D1+.99999
+1 FOR FHIR=FHTIM:0
SET FHIR=$ORDER(^FHPT("RM",FHIR))
IF (FHIR'>0)!(FHIR>(FHDT299))
QUIT
FOR FHIDFN=0:0
SET FHIDFN=$ORDER(^FHPT("RM",FHIR,FHIDFN))
IF FHIDFN'>0
QUIT
Begin DoDot:1
+2 FOR FHIEN=0:0
SET FHIEN=$ORDER(^FHPT("RM",FHIR,FHIDFN,FHIEN))
IF FHIEN'>0
QUIT
Begin DoDot:2
+3 SET FHREDAT=$GET(^FHPT(FHIDFN,"OP",FHIEN,0))
+4 IF $PIECE(FHREDAT,U,4)'=MEAL
QUIT
+5 IF $PIECE(FHREDAT,U,15)="C"
QUIT
+6 SET FHLOC=$PIECE(FHREDAT,U,3)
IF '$GET(FHLOC)
QUIT
+7 IF $GET(FHSITE)
IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
QUIT
+8 SET FHRDIET=$PIECE(FHREDAT,U,2)
IF '$GET(FHRDIET)
QUIT
+9 SET FHPDIET=$PIECE($GET(^FH(111,FHRDIET,0)),U,5)
+10 IF $GET(FHLOC)
Begin DoDot:3
+11 SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
IF $GET(FHSER)
SET SP(FHSER)=""
+12 IF '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
IF $GET(FHSER)
SET SP(FHSER)=""
+13 IF '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
IF $GET(FHSER)
SET SP(FHSER)=""
End DoDot:3
+14 IF '$GET(FHSER)
QUIT
+15 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+16 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
+17 IF '$DATA(P(FHPDIET,FHSER))
SET P(FHPDIET,FHSER)=0
+18 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
+19 IF '$DATA(P(.6,FHSER))
SET P(.6,FHSER)=0
SET P(.6,FHSER)=P(.6,FHSER)+1
+20 ;if tubefeeding and not cancelled, also count the TF data.
+21 IF $DATA(^FHPT(FHIDFN,"OP",FHIEN,"TF"))
Begin DoDot:3
+22 IF $PIECE(^FHPT(FHIDFN,"OP",FHIEN,3),U,5)="C"
QUIT
+23 IF '$DATA(P(.7,FHSER))
SET P(.7,FHSER)=1
+24 IF '$TEST
SET P(.7,FHSER)=P(.7,FHSER)+1
+25 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
+26 ;
+27 SET FHDT=D1+.999999
+28 DO GETSM^FHOMRBLD(FHTIM,FHSITE,"","")
+29 DO SPEC^FHORD9
+30 DO GETGM^FHOMRBL1(FHTIM,FHSITE,"","")
+31 DO GUEST^FHORD9
+32 ;
COMB ;
+1 KILL D,NP,T
FOR LP=0:0
SET LP=$ORDER(P(.5,LP))
IF LP<1
QUIT
IF '$DATA(NP(.5,LP))
SET NP(.5,LP)=0
SET NP(.5,LP)=NP(.5,LP)+P(.5,LP)
IF '$DATA(D(LP))
SET D(LP)=0
SET D(LP)=D(LP)+P(.5,LP)
+2 KILL P(.5)
FOR LP=0:0
SET LP=$ORDER(P(.7,LP))
IF LP<1
QUIT
IF '$DATA(NP(.7,LP))
SET NP(.7,LP)=0
SET NP(.7,LP)=NP(.7,LP)+P(.7,LP)
IF '$DATA(D(LP))
SET D(LP)=0
SET D(LP)=D(LP)+P(.7,LP)
+3 KILL P(.7)
FOR LL=0:0
SET LL=$ORDER(P(.6,LL))
IF LL<1
QUIT
IF '$DATA(NP(.6,LL))
SET NP(.6,LL)=0
SET NP(.6,LL)=NP(.6,LL)+P(.6,LL)
+4 KILL P(.6)
FOR LL=0:0
SET LL=$ORDER(P(.8,LL))
IF LL<1
QUIT
IF '$DATA(NP(.8,LL))
SET NP(.8,LL)=0
SET NP(.8,LL)=NP(.8,LL)+P(.8,LL)
IF '$DATA(D(LL))
SET D(LL)=0
SET D(LL)=D(LL)+P(.8,LL)
+5 KILL P(.8)
FOR LL=0:0
SET LL=$ORDER(P(LL))
IF LL<1
QUIT
FOR P0=0:0
SET P0=$ORDER(P(LL,P0))
IF P0<1
QUIT
IF '$DATA(T(P0))
SET T(P0)=0
SET T(P0)=T(P0)+P(LL,P0)
+6 FOR LP=0:0
SET LP=$ORDER(NP(.6,LP))
IF LP<1
QUIT
IF $DATA(T(LP))
SET NP(.6,LP)=NP(.6,LP)-T(LP)-$GET(D(LP))
IF '$DATA(D(LP))
SET D(LP)=0
SET D(LP)=D(LP)+NP(.6,LP)
+7 FOR P0=0:0
SET P0=$ORDER(^FH(119.72,P0))
IF P0<1
QUIT
IF $PIECE(^(P0,0),"^",3)=FHP
IF $DATA(^FH(119.72,P0,"B"))
DO D0
+8 KILL ^TMP($JOB)
FOR LL=0:0
SET LL=$ORDER(P(LL))
IF LL<1
QUIT
SET P(LL,0)=0
FOR P0=0:0
SET P0=$ORDER(P(LL,P0))
IF P0<1
QUIT
SET ^TMP($JOB,P0,LL)=P(LL,P0)
IF '$DATA(D(P0))
SET D(P0)=""
SET D(P0)=D(P0)+P(LL,P0)
SET P(LL,0)=P(LL,0)+P(LL,P0)
+9 FOR P0=0:0
SET P0=$ORDER(D(P0))
IF P0<1
QUIT
SET ^TMP($JOB,P0)=D(P0)
+10 FOR LL=0:0
SET LL=$ORDER(P(LL))
IF LL<1
QUIT
IF $GET(P(LL,0))
SET ^TMP($JOB,0,LL)=P(LL,0)
+11 KILL P,D
QUIT
D0 ;
+1 IF '$DATA(SP(P0))
QUIT
+2 IF $GET(^FH(119.72,P0,"I"))="Y"
QUIT
+3 FOR LL=0:0
SET LL=$ORDER(^FH(119.72,P0,"B",LL))
IF LL<1
QUIT
SET Y=$PIECE(^(LL,0),"^",3*DOW-2+K3)
IF Y>0
IF '$DATA(P(LL,P0))
SET P(LL,P0)=0
SET P(LL,P0)=P(LL,P0)+Y
+4 QUIT
+5 ;
FOR ;FORCAST
+1 KILL ^TMP($JOB)
FOR P0=0:0
SET P0=$ORDER(M2(P0))
IF P0<1
QUIT
SET ^TMP($JOB,P0)=M2(P0)
+2 KILL D
FOR P0=0:0
SET P0=$ORDER(M2(P0))
IF P0<1
QUIT
SET S1=M2(P0)
DO PER
SET ^TMP($JOB,P0)=S0
+3 FOR P0=0:0
SET P0=$ORDER(^TMP($JOB,P0))
IF P0<1
QUIT
IF $DATA(^FH(119.72,P0,"B"))
DO F1
+4 FOR LL=0:0
SET LL=$ORDER(D(LL))
IF LL<1
QUIT
SET ^TMP($JOB,0,LL)=D(LL)
+5 KILL D
QUIT
F1 FOR LL=0:0
SET LL=$ORDER(^FH(119.72,P0,"B",LL))
IF LL<1
QUIT
SET Y=$PIECE(^(LL,0),"^",3*DOW-2+K3)
IF Y>0
SET D(LL)=$GET(D(LL))+Y
SET ^TMP($JOB,P0)=^TMP($JOB,P0)+Y
SET ^TMP($JOB,P0,LL)=$GET(^TMP($JOB,P0,LL))+Y
+1 QUIT
PER SET S0=0
FOR K=0:0
SET K=$ORDER(^FH(119.72,P0,"A",K))
IF K<1
QUIT
SET Z=$PIECE($GET(^(K,0)),"^",DOW+1)
SET Z=$JUSTIFY(Z*S1/100,0,0)
IF Z
SET ^TMP($JOB,P0,K)=Z
SET S0=S0+Z
SET D(K)=$GET(D(K))+Z
+1 QUIT
+2 ;
GET FOR WRD=0:0
SET WRD=$ORDER(^FH(119.6,WRD))
IF WRD<1
QUIT
SET X=^(WRD,0)
SET TIM=D1
IF $PIECE(X,U,8)=FHSITE
DO WRD^FHORD9
+1 ;get outpatient data
+2 SET FHTIM=D1-.000001
+3 FOR FHIR=FHTIM:0
SET FHIR=$ORDER(^FHPT("RM",FHIR))
IF (FHIR'>0)!(FHIR>(FHTIM+1))
QUIT
FOR FHIDFN=0:0
SET FHIDFN=$ORDER(^FHPT("RM",FHIR,FHIDFN))
IF FHIDFN'>0
QUIT
Begin DoDot:1
+4 FOR FHIEN=0:0
SET FHIEN=$ORDER(^FHPT("RM",FHIR,FHIDFN,FHIEN))
IF FHIEN'>0
QUIT
Begin DoDot:2
+5 SET FHREDAT=$GET(^FHPT(FHIDFN,"OP",FHIEN,0))
+6 SET FHLOC=$PIECE(FHREDAT,U,3)
+7 ;quit if cancelled
IF $PIECE(FHREDAT,U,5)="C"
QUIT
+8 IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
QUIT
+9 SET FHRDIET=$PIECE(FHREDAT,U,2)
SET FHPDIET=$PIECE($GET(^FH(111,FHRDIET,0)),U,5)
+10 IF $GET(FHLOC)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
+11 IF '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
+12 IF '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
+13 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+14 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
+15 IF '$DATA(P(FHPDIET,FHSER))
SET P(FHPDIET,FHSER)=0
+16 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
+17 IF '$DATA(P(.6,FHSER))
SET P(.6,FHSER)=0
SET P(.6,FHSER)=P(.6,FHSER)+1
+18 ;if tubefeeding and not cancelled, count the TF data.
+19 IF $DATA(^FHPT(FHIDFN,"OP",FHIEN,"TF"))
Begin DoDot:3
+20 IF $PIECE(^FHPT(FHIDFN,"OP",FHIEN,3),U,5)="C"
QUIT
+21 IF '$DATA(P(.7,FHSER))
SET P(.7,FHSER)=1
+22 IF '$TEST
SET P(.7,FHSER)=P(.7,FHSER)+1
+23 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
+24 SET FHPLNM=$PIECE($GET(^FH(119.73,FHSITE,0)),U,1)
+25 SET FHDT=D1+.999999
+26 DO GETSM^FHOMRBLD(FHTIM,FHSITE,"","")
+27 DO SPEC^FHORD9
+28 DO GETGM^FHOMRBL1(FHTIM,FHSITE,"","")
+29 DO GUEST^FHORD9
+30 ;
+31 KILL D,NP
FOR LP=0:0
SET LP=$ORDER(P(.5,LP))
IF LP<1
QUIT
IF '$DATA(NP(.5,LP))
SET NP(.5,LP)=0
SET NP(.5,LP)=NP(.5,LP)+P(.5,LP)
IF '$DATA(D(LP))
SET D(LP)=0
SET D(LP)=D(LP)+P(.5,LP)
+32 KILL P(.5)
FOR LP=0:0
SET LP=$ORDER(P(.7,LP))
IF LP<1
QUIT
IF '$DATA(NP(.7,LP))
SET NP(.7,LP)=0
SET NP(.7,LP)=NP(.7,LP)+P(.7,LP)
IF '$DATA(D(LP))
SET D(LP)=0
SET D(LP)=D(LP)+P(.7,LP)
+33 KILL P(.7)
FOR LP=0:0
SET LP=$ORDER(P(.6,LP))
IF LP<1
QUIT
IF '$DATA(NP(.6,LP))
SET NP(.6,LP)=0
SET NP(.6,LP)=NP(.6,LP)+P(.6,LP)
+34 KILL P(.6)
FOR LP=0:0
SET LP=$ORDER(P(.8,LP))
IF LP<1
QUIT
IF '$DATA(NP(.8,LP))
SET NP(.8,LP)=0
SET NP(.8,LP)=NP(.8,LP)+P(.8,LP)
IF '$DATA(D(LP))
SET D(LP)=0
SET D(LP)=D(LP)+P(.8,LP)
+35 KILL P(.8),^TMP($JOB)
FOR LL=0:0
SET LL=$ORDER(P(LL))
IF LL<1
QUIT
SET P(LL,0)=0
FOR P0=0:0
SET P0=$ORDER(P(LL,P0))
IF P0<1
QUIT
SET ^TMP($JOB,P0,LL)=P(LL,P0)
IF '$DATA(D(P0))
SET D(P0)=""
SET D(P0)=D(P0)+P(LL,P0)
SET P(LL,0)=P(LL,0)+P(LL,P0)
+36 FOR LP=0:0
SET LP=$ORDER(NP(.6,LP))
IF LP<1
QUIT
IF $DATA(D(LP))
SET NP(.6,LP)=NP(.6,LP)-D(LP)
IF '$DATA(D(LP))
SET D(LP)=0
SET D(LP)=D(LP)+NP(.6,LP)
+37 FOR P0=0:0
SET P0=$ORDER(D(P0))
IF P0<1
QUIT
SET ^TMP($JOB,P0)=D(P0)
+38 FOR LL=0:0
SET LL=$ORDER(P(LL))
IF LL<1
QUIT
IF $GET(P(LL,0))
SET ^TMP($JOB,0,LL)=P(LL,0)
+39 KILL P,D
+40 ;
LST KILL S
SET L1=30
+1 FOR P0=0:0
SET P0=$ORDER(^TMP($JOB,P0))
IF P0=""
QUIT
SET X=^FH(119.72,P0,0)
SET N1=$PIECE(X,"^",1)
SET N2=$PIECE(X,"^",2)
SET N3=$PIECE(X,"^",4)
IF N3=""
SET N3=$EXTRACT(N1,1,6)
SET S(N3,P0)=$JUSTIFY(N3,8)_"^"_N2
SET L1=L1+10
+2 IF L1<80
SET L1=80
IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
+3 SET Z=$SELECT(FHP1["F":"F O R E C A S T E D",1:"A C T U A L")_" D I E T C E N S U S"
+4 SET DTP=NOW
DO DTP^FH
WRITE !,DTP,?(L1-$LENGTH(Z)\2),Z,?(L1-7),"Page ",PG,!?(L1-21\2),"P E R C E N T A G E S"
+5 WRITE !,$GET(FHSITENM)
+6 SET Z=$PIECE(^FH(119.71,FHP,0),"^",1)
SET DTP=D1
DO DTP^FH
+7 SET X=D1\1
DO DOW^%DTC
SET DOW=Y+1
SET X=$PIECE("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",DOW)_"day "_DTP
IF FHAN="Y"
SET X=X_" "_$PIECE("BREAKFAST^NOON^EVENING","^",K3)
+8 SET DTP=D1\1
DO DTP^FH
WRITE !!?(L1-$LENGTH(Z)\2),Z,!!?(L1-$LENGTH(X)\2),X
+9 WRITE !!?(L1-31\2),"P R O D U C T I O N D I E T S",!!?29
+10 SET X=""
FOR
SET X=$ORDER(S(X))
IF X=""
QUIT
FOR K=0:0
SET K=$ORDER(S(X,K))
IF K=""
QUIT
WRITE $PIECE(S(X,K),"^",1)_" %"
+11 WRITE !
+12 FOR P1=0:0
SET P1=$ORDER(^FH(116.2,"AP",P1))
IF P1<1
QUIT
FOR K=0:0
SET K=$ORDER(^FH(116.2,"AP",P1,K))
IF K<1
QUIT
IF $DATA(^TMP($JOB,0,K))
DO PRO
+13 IF FHP1'["F"
WRITE !?3,"N P O",?31
SET K=.5
DO P1
KILL NP(.5)
+14 IF FHP1'["F"
WRITE !?3,"P A S S",?31
SET K=.8
DO P1
KILL NP(.8)
+15 IF FHP1'["F"
WRITE !?3,"TF Only",?31
SET K=.7
DO P1
KILL NP(.7)
+16 IF FHP1'["F"
WRITE !?3,"No Order",?31
SET K=.6
DO P1
KILL NP(.6)
+17 WRITE !
+18 QUIT
PRO WRITE !,$PIECE($GET(^FH(116.2,K,0)),"^",1),?31
P1 FOR
SET X=$ORDER(S(X))
IF X=""
QUIT
FOR K1=0:0
SET K1=$ORDER(S(X,K1))
IF K1=""
QUIT
SET Z=$SELECT(K>.9:$GET">GET(^TMP($JOB,K1,K)),1:$GET">GET(NP(K,K1)))
SET Z=$SELECT($GET">GET(^TMP($JOB,K1)):Z/$GET">GET(^TMP($JOB,K1))*100,1:"")
WRITE $JUSTIFY(Z,8,1)," "
+1 QUIT
