Routine: FHADR4

FHADR4 ; HISC/NCA - Annual Nutrition Status Summary ;9/10/93  14:44

 ;;5.5;DIETETICS;;Jan 28, 2005

Q1 ; Process Screening

 K M,N,S,T1 S (TD,XX)=0

 F K=1:1:5 S S(K)=0,T1(K)=""

 F QR=1:1:4 S QTR=QR,PRE=FHYR_"0"_QTR_"00" D Q2^FHADRPT,Q11

 G EN2

Q11 ; T1(1-4) have tabulated statuses for the quarters

 ; T1(5) is final Total

 Q:'SDT!('EDT)

 S D1=SDT,(FIN,ND)=0,(M,N)="" F L1=0:0 D Q2 S X1=D1,X2=1 D C^%DTC Q:X>EDT  S D1=X

 Q:'FIN

 F K=1:1:5 S $P(T1(QTR),"^",K)=$J($S(ND:$P(N,"^",K)/ND,1:0),0,0),$P(T1(5),"^",QTR)=$P(T1(5),"^",QTR)+$P(T1(QTR),"^",K)

 F K=1:1:5 S $P(T1(QTR),"^",K+5)=$J($S($P(T1(5),"^",QTR):$P(T1(QTR),"^",K)/$P(T1(5),"^",QTR)*100,1:0),0,1)

 S:ND TD=TD+1

Q2 ; Tabulate status

 S TOT=0

 S X4=$G(^FH(117,D1,0)) Q:X4=""  S X5=$G(^(1))

 Q:X5=""

 S K=20 F L=1:1:5 S K=K+1,S(L)=$P(X5,"^",K),TOT=TOT+$S(S(L):S(L),1:0) S:'$D(N) N="" S $P(N,"^",L)=$P(N,"^",L)+$S(S(L):S(L),1:0)

 Q:'TOT  S ND=ND+1

 S X=$S(TOT:TOT,1:0),FIN=FIN+X

 F K=1:1:5 S X=S(K) S:'$D(M) M="" S $P(M,"^",K)=$P(M,"^",K)+$S(X:X,1:0)

EN2 ; Print Summary

 D HDR

 F K=1:1:5 F J=1:1:4 S $P(T1(K),"^",11)=$P(T1(K),"^",11)+$S($P(T1(J),"^",K):$P(T1(J),"^",K),1:0)

 F J=1:1:5 S XX=XX+$S($P(T1(J),"^",11):$P(T1(J),"^",11),1:0)

 F K=1:1:5 S TIT=$P("I,II,III,IV,UNC",",",K)_" "_$S(K<5:$P($G(^FH(115.4,K,0)),"^",3),1:"UNCLASSIFIED") D LP

 W !,?13,"TOTAL",?67 F I=1:1:4 W $J($S($P(T1(5),"^",I):$P(T1(5),"^",I),1:""),5)_$J("",7)

 W ?117,$J($S(XX:XX,1:""),5)

 K M,N,S,T1 Q

LP W !,?13,TIT,?67

 F I=1:1:4 W $S($P(T1(I),"^",K):$J($P(T1(I),"^",K),5),1:$J("",5))_$J("",7)

 W ?117,$S($P(T1(K),"^",11):$J($P(T1(K),"^",11),5,0),1:$J("",5))

 W !,?13,"%",?67 F I=1:1:4 W $S($P(T1(I),"^",K+5):$J($P(T1(I),"^",K+5),5,1),1:$J("",5))_$J("",7)

 S X6=$S(XX:$P(T1(K),"^",11)/XX*100,1:"")

 W ?117,$S(X6:$J(X6,5,1),1:$J("",5)),!

HDR ; Print Heading for Nutrition Statuses Summary

 D:$Y'<(LIN-22) HDR^FHADRPT,HDR2^FHADR3A

 W !!!,?14,"NUTRITION STATUS SUMMARY"

 W !!,?67,"Avg",?79,"Avg",?91,"Avg",?103,"Avg",?117,"YTD"

 W !?13,"Status",?65,"1st Qtr     2nd Qtr     3rd Qtr     4th Qtr       Tot Avg",! Q

FHADR4    ; HISC/NCA - Annual Nutrition Status Summary ;9/10/93  14:44

 +1       ;;5.5;DIETETICS;;Jan 28, 2005

Q1        ; Process Screening

 +1        KILL M,N,S,T1

           SET (TD,XX)=0

 +2        FOR K=1:1:5

               SET S(K)=0

               SET T1(K)=""

 +3        FOR QR=1:1:4

               SET QTR=QR

               SET PRE=FHYR_"0"_QTR_"00"

               DO Q2^FHADRPT

               DO Q11

 +4        GOTO EN2

Q11       ; T1(1-4) have tabulated statuses for the quarters

 +1       ; T1(5) is final Total

 +2        IF 'SDT!('EDT)

               QUIT

 +3        SET D1=SDT

           SET (FIN,ND)=0

           SET (M,N)=""

           FOR L1=0:0

               DO Q2

               SET X1=D1

               SET X2=1

               DO C^%DTC

               IF X>EDT

                   QUIT

               SET D1=X

 +4        IF 'FIN

               QUIT

 +5        FOR K=1:1:5

               SET $PIECE(T1(QTR),"^",K)=$JUSTIFY($SELECT(ND:$PIECE(N,"^",K)/ND,1:0),0,0)

               SET $PIECE(T1(5),"^",QTR)=$PIECE(T1(5),"^",QTR)+$PIECE(T1(QTR),"^",K)

 +6        FOR K=1:1:5

               SET $PIECE(T1(QTR),"^",K+5)=$JUSTIFY($SELECT($PIECE(T1(5),"^",QTR):$PIECE(T1(QTR),"^",K)/$PIECE(T1(5),"^",QTR)*100,1:0),0,1)

 +7        IF ND

               SET TD=TD+1

 +8        QUIT

Q2        ; Tabulate status

 +1        SET TOT=0

 +2        SET X4=$GET(^FH(117,D1,0))

           IF X4=""

               QUIT

           SET X5=$GET(^(1))

 +3        IF X5=""

               QUIT

 +4        SET K=20

           FOR L=1:1:5

               SET K=K+1

               SET S(L)=$PIECE(X5,"^",K)

               SET TOT=TOT+$SELECT(S(L):S(L),1:0)

               IF '$DATA(N)

                   SET N=""

               SET $PIECE(N,"^",L)=$PIECE(N,"^",L)+$SELECT(S(L):S(L),1:0)

 +5        IF 'TOT

               QUIT

           SET ND=ND+1

 +6        SET X=$SELECT(TOT:TOT,1:0)

           SET FIN=FIN+X

 +7        FOR K=1:1:5

               SET X=S(K)

               IF '$DATA(M)

                   SET M=""

               SET $PIECE(M,"^",K)=$PIECE(M,"^",K)+$SELECT(X:X,1:0)

 +8        QUIT

EN2       ; Print Summary

 +1        DO HDR

 +2        FOR K=1:1:5

               FOR J=1:1:4

                   SET $PIECE(T1(K),"^",11)=$PIECE(T1(K),"^",11)+$SELECT($PIECE(T1(J),"^",K):$PIECE(T1(J),"^",K),1:0)

 +3        FOR J=1:1:5

               SET XX=XX+$SELECT($PIECE(T1(J),"^",11):$PIECE(T1(J),"^",11),1:0)

 +4        FOR K=1:1:5

               SET TIT=$PIECE("I,II,III,IV,UNC",",",K)_" "_$SELECT(K<5:$PIECE($GET(^FH(115.4,K,0)),"^",3),1:"UNCLASSIFIED")

               DO LP

 +5        WRITE !,?13,"TOTAL",?67

           FOR I=1:1:4

               WRITE $JUSTIFY($SELECT($PIECE(T1(5),"^",I):$PIECE(T1(5),"^",I),1:""),5)_$JUSTIFY("",7)

 +6        WRITE ?117,$JUSTIFY($SELECT(XX:XX,1:""),5)

 +7        KILL M,N,S,T1

           QUIT

LP         WRITE !,?13,TIT,?67

 +1        FOR I=1:1:4

               WRITE $SELECT($PIECE(T1(I),"^",K):$JUSTIFY($PIECE(T1(I),"^",K),5),1:$JUSTIFY("",5))_$JUSTIFY("",7)

 +2        WRITE ?117,$SELECT($PIECE(T1(K),"^",11):$JUSTIFY($PIECE(T1(K),"^",11),5,0),1:$JUSTIFY("",5))

 +3        WRITE !,?13,"%",?67

           FOR I=1:1:4

               WRITE $SELECT($PIECE(T1(I),"^",K+5):$JUSTIFY($PIECE(T1(I),"^",K+5),5,1),1:$JUSTIFY("",5))_$JUSTIFY("",7)

 +4        SET X6=$SELECT(XX:$PIECE(T1(K),"^",11)/XX*100,1:"")

 +5        WRITE ?117,$SELECT(X6:$JUSTIFY(X6,5,1),1:$JUSTIFY("",5)),!

 +6        QUIT

HDR       ; Print Heading for Nutrition Statuses Summary

 +1        IF $Y'<(LIN-22)

               DO HDR^FHADRPT

               DO HDR2^FHADR3A

 +2        WRITE !!!,?14,"NUTRITION STATUS SUMMARY"

 +3        WRITE !!,?67,"Avg",?79,"Avg",?91,"Avg",?103,"Avg",?117,"YTD"

 +4        WRITE !?13,"Status",?65,"1st Qtr     2nd Qtr     3rd Qtr     4th Qtr       Tot Avg",!

           QUIT

FHADR4.m