- 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
