FHADM2A ; HISC/REL/NCA - Calculate NPO/Trays for Served Meals ;6/18/93 14:03
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Calculate NPO/Trays
; Check for multidivisional site
I $P($G(^FH(119.9,1,0)),U,20)'="N" D ^FHMADM2A Q
D NOW^%DTC S NOW=%,DT=NOW\1,(TP,TC,TE,N,R)=0 F K=1:1:5 S S(K)=0
F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD'>0 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN="" S ADM=^FHPT("AW",WRD,FHDFN) D CNT
I '$D(^FH(117,DT,0)) S ^FH(117,DT,0)=DT,^FH(117,"B",DT,DT)="",X0=^FH(117,0),$P(^FH(117,0),"^",3,4)=DT_"^"_($P(X0,"^",4)+1)
S MD=N-R
S $P(^FH(117,DT,1),"^",19,27)=(3*TC)_"^"_(TP-TE*3)_"^"_S(1)_"^"_S(2)_"^"_S(3)_"^"_S(4)_"^"_S(5)_"^"_MD_"^"_N
K %,%H,%I,A1,ADM,FHDFN,FHORD,K,MD,N,NOW,R,S,TC,TE,TP,TYP,WRD,X0,X1,Y0,ZZ Q
CNT Q:'ADM S TP=TP+1 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
S X5=$O(^FHPT(FHDFN,"S",0)) I X5 S X5=$G(^(X5,0))
I I $P(X5,"^",1)<$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",1) S X5=5,S(X5)=S(X5)+1 G C1
S X5=$P(X5,"^",2) S:X5=""!(X5>4) X5=5 S S(X5)=S(X5)+1
C1 S X0=^FHPT(FHDFN,"A",ADM,0)
S FHORD=$P(X0,"^",2),X1=$P(X0,"^",3),ZZ=$P(X0,"^",5) Q:'FHORD
S Y0=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) Q:Y0=""
S FHOR=$P(Y0,"^",2,6),FHLD=$P(Y0,"^",7)
I FHLD'="" Q:ZZ="" S N=N+1 Q
S Z=$P(Y0,"^",13) Q:Z="" S TE=TE+1,TYP=$P(Y0,"^",8) S:TYP="C" TC=TC+1 S N=N+1
I "1^^^^"[FHOR S R=R+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADM2A 1330 printed Nov 22, 2024@16:56:33 Page 2
FHADM2A ; HISC/REL/NCA - Calculate NPO/Trays for Served Meals ;6/18/93 14:03
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Calculate NPO/Trays
+1 ; Check for multidivisional site
+2 IF $PIECE($GET(^FH(119.9,1,0)),U,20)'="N"
DO ^FHMADM2A
QUIT
+3 DO NOW^%DTC
SET NOW=%
SET DT=NOW\1
SET (TP,TC,TE,N,R)=0
FOR K=1:1:5
SET S(K)=0
+4 FOR WRD=0:0
SET WRD=$ORDER(^FH(119.6,WRD))
if WRD'>0
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",WRD,FHDFN))
if FHDFN=""
QUIT
SET ADM=^FHPT("AW",WRD,FHDFN)
DO CNT
+5 IF '$DATA(^FH(117,DT,0))
SET ^FH(117,DT,0)=DT
SET ^FH(117,"B",DT,DT)=""
SET X0=^FH(117,0)
SET $PIECE(^FH(117,0),"^",3,4)=DT_"^"_($PIECE(X0,"^",4)+1)
+6 SET MD=N-R
+7 SET $PIECE(^FH(117,DT,1),"^",19,27)=(3*TC)_"^"_(TP-TE*3)_"^"_S(1)_"^"_S(2)_"^"_S(3)_"^"_S(4)_"^"_S(5)_"^"_MD_"^"_N
+8 KILL %,%H,%I,A1,ADM,FHDFN,FHORD,K,MD,N,NOW,R,S,TC,TE,TP,TYP,WRD,X0,X1,Y0,ZZ
QUIT
CNT if 'ADM
QUIT
SET TP=TP+1
if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
+1 SET X5=$ORDER(^FHPT(FHDFN,"S",0))
IF X5
SET X5=$GET(^(X5,0))
+2 IF $TEST
IF $PIECE(X5,"^",1)<$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",1)
SET X5=5
SET S(X5)=S(X5)+1
GOTO C1
+3 SET X5=$PIECE(X5,"^",2)
if X5=""!(X5>4)
SET X5=5
SET S(X5)=S(X5)+1
C1 SET X0=^FHPT(FHDFN,"A",ADM,0)
+1 SET FHORD=$PIECE(X0,"^",2)
SET X1=$PIECE(X0,"^",3)
SET ZZ=$PIECE(X0,"^",5)
if 'FHORD
QUIT
+2 SET Y0=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
if Y0=""
QUIT
+3 SET FHOR=$PIECE(Y0,"^",2,6)
SET FHLD=$PIECE(Y0,"^",7)
+4 IF FHLD'=""
if ZZ=""
QUIT
SET N=N+1
QUIT
+5 SET Z=$PIECE(Y0,"^",13)
if Z=""
QUIT
SET TE=TE+1
SET TYP=$PIECE(Y0,"^",8)
if TYP="C"
SET TC=TC+1
SET N=N+1
+6 IF "1^^^^"[FHOR
SET R=R+1
+7 QUIT
