FHCMS1 ; HISC/NCA/RVD - Calculate Meals ;3/22/93 12:28
;;5.5;DIETETICS;;Jan 28, 2005
S FHTOT=0 F LL=SDT:0 S LL=$O(^FH(117,LL)) Q:LL<1!($E(LL,1,5)>$E(EDT,1,5)) D N1
Q
N1 S Y0=$G(^FH(117,LL,0)) Q:Y0=""
I $P($G(^FH(119.9,1,0)),U,20)'="N" G ALL ;multidivisional
S Y1=$G(^FH(117,LL,1))
S K=1 F L=1,2,4,5,7,8 S K=K+1,N(L)=$P(Y0,"^",K)
S K=10 F L=1:3:16 S K=K+1,N(K)=$P(Y1,"^",L)+$P(Y1,"^",L+1)+$P(Y1,"^",L+2)
S N(3)=N(1)-N(2)*3,N(6)=N(4)-N(5)*3,N(9)=N(7)-N(8)*3
S N(10)=N(3)+N(6)+N(9)
S N(16)=N(14)+N(15)+N(16),N(13)=N(12)+N(13),N(17)=N(11)+N(13)+N(16),N(18)=N(10)+N(17)
S FHTOT=FHTOT+N(18) Q
;
ALL ;get all comm.
S K=1 F L=1,2,4,5,7,8 S K=K+1,N(L)=$P(Y0,"^",K)
F FHCOI=0:0 S FHCOI=$O(^FH(117,LL,2,FHCOI)) Q:FHCOI'>0 D
.S Y0=$G(^FH(117,LL,2,FHCOI,1)) Q:Y0=""
.S K=1 F L=1,2,4,5,7,8 S K=K+1,N(L)=$P(Y0,"^",K)
.S Y1=$G(^FH(117,LL,2,FHCOI,0)) Q:Y1=""
.S K=10 F L=2:4:17 S K=K+1,N(K)=$P(Y1,"^",L)+$P(Y1,"^",L+1)+$P(Y1,"^",L+2)
.S N(3)=N(1)-N(4)*3,N(6)=N(6)-N(7)*3,N(9)=N(7)-N(8)*3
.S N(10)=N(3)+N(6)+N(9)
.S N(16)=N(14)+N(15)+N(16),N(13)=N(12)+N(13),N(17)=N(11)+N(13)+N(16),N(18)=N(10)+N(17)
.S FHTOT=FHTOT+N(18)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHCMS1 1160 printed Apr 09, 2024@20:54:58 Page 2
FHCMS1 ; HISC/NCA/RVD - Calculate Meals ;3/22/93 12:28
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET FHTOT=0
FOR LL=SDT:0
SET LL=$ORDER(^FH(117,LL))
if LL<1!($EXTRACT(LL,1,5)>$EXTRACT(EDT,1,5))
QUIT
DO N1
+3 QUIT
N1 SET Y0=$GET(^FH(117,LL,0))
if Y0=""
QUIT
+1 ;multidivisional
IF $PIECE($GET(^FH(119.9,1,0)),U,20)'="N"
GOTO ALL
+2 SET Y1=$GET(^FH(117,LL,1))
+3 SET K=1
FOR L=1,2,4,5,7,8
SET K=K+1
SET N(L)=$PIECE(Y0,"^",K)
+4 SET K=10
FOR L=1:3:16
SET K=K+1
SET N(K)=$PIECE(Y1,"^",L)+$PIECE(Y1,"^",L+1)+$PIECE(Y1,"^",L+2)
+5 SET N(3)=N(1)-N(2)*3
SET N(6)=N(4)-N(5)*3
SET N(9)=N(7)-N(8)*3
+6 SET N(10)=N(3)+N(6)+N(9)
+7 SET N(16)=N(14)+N(15)+N(16)
SET N(13)=N(12)+N(13)
SET N(17)=N(11)+N(13)+N(16)
SET N(18)=N(10)+N(17)
+8 SET FHTOT=FHTOT+N(18)
QUIT
+9 ;
ALL ;get all comm.
+1 SET K=1
FOR L=1,2,4,5,7,8
SET K=K+1
SET N(L)=$PIECE(Y0,"^",K)
+2 FOR FHCOI=0:0
SET FHCOI=$ORDER(^FH(117,LL,2,FHCOI))
if FHCOI'>0
QUIT
Begin DoDot:1
+3 SET Y0=$GET(^FH(117,LL,2,FHCOI,1))
if Y0=""
QUIT
+4 SET K=1
FOR L=1,2,4,5,7,8
SET K=K+1
SET N(L)=$PIECE(Y0,"^",K)
+5 SET Y1=$GET(^FH(117,LL,2,FHCOI,0))
if Y1=""
QUIT
+6 SET K=10
FOR L=2:4:17
SET K=K+1
SET N(K)=$PIECE(Y1,"^",L)+$PIECE(Y1,"^",L+1)+$PIECE(Y1,"^",L+2)
+7 SET N(3)=N(1)-N(4)*3
SET N(6)=N(6)-N(7)*3
SET N(9)=N(7)-N(8)*3
+8 SET N(10)=N(3)+N(6)+N(9)
+9 SET N(16)=N(14)+N(15)+N(16)
SET N(13)=N(12)+N(13)
SET N(17)=N(11)+N(13)+N(16)
SET N(18)=N(10)+N(17)
+10 SET FHTOT=FHTOT+N(18)
End DoDot:1
+11 QUIT
