FHMADM2A.m

FHMADM2A ; HISC/RTK - Calculate Multidiv NPO/Trays for Served Meals ;10/15/03  14:03

 ;;5.5;DIETETICS;;Jan 28, 2005

EN1 ; Calculate NPO/Trays

 F FHCOMM=0:0 S FHCOMM=$O(^FH(119.73,FHCOMM)) Q:FHCOMM'>0  D FHMULT

 Q

FHMULT ;

 D NOW^%DTC S NOW=%,DT=NOW\1,(TP,TC,TE,N,R)=0 F K=1:1:5 S S(K)=0

 I $G(^FH(119.73,FHCOMM,"I"))="Y" Q

 S FHZZ=$O(^FH(117,DT,2,"B",FHCOMM,"")) I FHZZ="" D

 .S Y=FHCOMM K DIC,DO S DA(1)=DT,DIC="^FH(117,"_DA(1)_",2,"

 .S DIC(0)="L",DIC("P")=$P(^DD(117,6,0),U,2),X=+Y

 .D FILE^DICN I Y=-1 Q

 S FHZZ=$O(^FH(117,DT,2,"B",FHCOMM,"")) I FHZZ="" Q

 F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD'>0  S FHWRDCM=$P($G(^FH(119.6,WRD,0)),U,8) Q:FHWRDCM'=FHCOMM  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,2,FHZZ,0),"^",20,28)=(3*TC)_"^"_(TP-TE*3)_"^"_S(1)_"^"_S(2)_"^"_S(3)_"^"_S(4)_"^"_S(5)_"^"_MD_"^"_N

 K %,%H,%I,A1,ADM,FHDFN,DFN,FHORD,K,MD,N,NOW,R,S,TC,TE,TP,TYP,WRD

 K 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

FHMADM2A  ; HISC/RTK - Calculate Multidiv NPO/Trays for Served Meals ;10/15/03  14:03

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

EN1       ; Calculate NPO/Trays

 +1        FOR FHCOMM=0:0

               SET FHCOMM=$ORDER(^FH(119.73,FHCOMM))

               IF FHCOMM'>0

                   QUIT 

               DO FHMULT

 +2        QUIT 

FHMULT    ;

 +1        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

 +2        IF $GET(^FH(119.73,FHCOMM,"I"))="Y"

               QUIT 

 +3        SET FHZZ=$ORDER(^FH(117,DT,2,"B",FHCOMM,""))

           IF FHZZ=""

               Begin DoDot:1

 +4                SET Y=FHCOMM

                   KILL DIC,DO

                   SET DA(1)=DT

                   SET DIC="^FH(117,"_DA(1)_",2,"

 +5                SET DIC(0)="L"

                   SET DIC("P")=$PIECE(^DD(117,6,0),U,2)

                   SET X=+Y

 +6                DO FILE^DICN

                   IF Y=-1

                       QUIT 

               End DoDot:1

 +7        SET FHZZ=$ORDER(^FH(117,DT,2,"B",FHCOMM,""))

           IF FHZZ=""

               QUIT 

 +8        FOR WRD=0:0

               SET WRD=$ORDER(^FH(119.6,WRD))

               IF WRD'>0

                   QUIT 

               SET FHWRDCM=$PIECE($GET(^FH(119.6,WRD,0)),U,8)

               IF FHWRDCM'=FHCOMM

                   QUIT 

               FOR FHDFN=0:0

                   SET FHDFN=$ORDER(^FHPT("AW",WRD,FHDFN))

                   IF FHDFN=""

                       QUIT 

                   SET ADM=^FHPT("AW",WRD,FHDFN)

                   DO CNT

 +9        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)

 +10       SET MD=N-R

 +11       SET $PIECE(^FH(117,DT,2,FHZZ,0),"^",20,28)=(3*TC)_"^"_(TP-TE*3)_"^"_S(1)_"^"_S(2)_"^"_S(3)_"^"_S(4)_"^"_S(5)_"^"_MD_"^"_N

 +12       KILL %,%H,%I,A1,ADM,FHDFN,DFN,FHORD,K,MD,N,NOW,R,S,TC,TE,TP,TYP,WRD

 +13       KILL X0,X1,Y0,ZZ

           QUIT 

CNT       ;

 +1        IF 'ADM

               QUIT 

           SET TP=TP+1

           IF '$DATA(^FHPT(FHDFN,"A",ADM,0))

               QUIT 

 +2        SET X5=$ORDER(^FHPT(FHDFN,"S",0))

           IF X5

               SET X5=$GET(^(X5,0))

 +3       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

 +4        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