- FHMADM2 ; HISC/AAC - Multidivisional Enter/Edit Served Meals ;10/9/03 09:53
- ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Served Meals
- D NOW^%DTC S DT=%\1 K %,%H,%I
- S (ZZOUT,COMM)=0,ZOUT=$P($G(^FH(119.6,0)),"^",4)
- ;
- E1 S %DT="AEPX",%DT("A")="SERVED MEALS Date: " W ! D ^%DT G KIL^FHMADM21:"^"[X!$D(DTOUT),E1:Y<1
- ;
- S DA=+Y,(FHRM,FHSM,FHGM)=DA I DA'<DT W *7,!!,"** Input must be for a date before today in order to collect ADT data!",! G E1
- ;
- ;Enter Communications Office
- K DIC,DIE S DIE="^FH(117," I '$D(^FH(117,DA,0)) S ^FH(117,DA,0)=DA,^FH(117,"B",DA,DA)="",X0=^FH(117,0),$P(^FH(117,0),"^",3,4)=DA_"^"_($P(X0,"^",4)+1)
- S DA=+Y I $G(^FH(117,DA,"I"))="Y" W !," ** INACTIVE COMM OFFICE **" Q
- S ^FH(117,DA,0)=DA
- S DR="[FHMADM2]" D ^DIE
- Q
- ;
- C1 ;
- K FHN W !!,"Calculating Census Values ...",!
- F W1=0:0 S W1=$O(^DG(41.9,W1)) Q:W1'>0 D C2
- W !,"Calculating Outpatient Values ...",! D CALCOP
- Q
- C2 ;
- I '$D(^DG(41.9,W1,"C",DA(1))) Q
- S X0=^DG(41.9,W1,"C",DA(1),0),X1=$G(^(1)) I $D(^DIC(42,W1,0)) S FHWARD=$O(^FH(119.6,"AW",W1,"")) Q:FHWARD=""
- S FHCOM19=$P($G(^FH(119.6,FHWARD,0)),"^",8) Q:FHCOMM'=FHCOM19
- S TYP=$P(^DIC(42,W1,0),"^",3),TYP=$S(TYP="D":"D",TYP="NH":"N",1:"H")
- I '$D(FHN(TYP)) S FHN(TYP,0)=0,FHN(TYP,1)=0
- S Y0=$P(X0,"^",2),Y1=$P(X1,"^",5)
- S:Y0 FHN(TYP,0)=FHN(TYP,0)+Y0 S:Y1 FHN(TYP,1)=FHN(TYP,1)+Y1 Q
- Q
- DT ; Get From/To Dates
- D1 S %DT="AEPX",%DT("A")="Starting Date: " W ! D ^%DT S:$D(DTOUT) X="^" Q:U[X G:Y<1 D1 S SDT=+Y
- I SDT'<DT W *7," [Must Start before Today!] " G D1
- D2 S %DT="AEPX",%DT("A")=" Ending Date: " D ^%DT S:$D(DTOUT) X="^" Q:U[X G:Y<1 D2 S EDT=+Y
- I EDT'<DT W *7," [Must End before Today!] " G D2
- I EDT<SDT W *7," [End before Start?] " G D1
- Q
- CALCOP ; Calculate Outpatient totals (Recurring and Special Meals) for the
- ; selected Communication Office
- ;
- K FHOPC S FHEND=FHRM_.9999,X1=FHRM,X2=-1 D C^%DTC S FHRM=X
- F IX="B","N","E" S FHOPC(IX)=0 F FC="E","G","O","P","V" S FHOPC(FC,IX)=0
- ; Count recurring meals totals in FHOPC(INDX)
- F FHRM=FHRM:0 S FHRM=$O(^FHPT("RM",FHRM)) Q:FHRM=""!(FHRM'<FHEND) D
- .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHRM,FHDFN)) Q:FHDFN="" D
- ..F FHRNUM=0:0 S FHRNUM=$O(^FHPT("RM",FHRM,FHDFN,FHRNUM)) Q:FHRNUM="" D
- ...S FHLOC=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3)
- ...I $P($G(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM Q
- ...S FHMEAL=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
- ...Q:"BNE"'[FHMEAL!(FHMEAL="")
- ...I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
- ...S FHOPC(FHMEAL)=FHOPC(FHMEAL)+1
- ; Add special meals to recurring meals totals in FHOPC(INDX)
- F FHSM=FHSM:0 S FHSM=$O(^FHPT("SM",FHSM)) Q:FHSM>FHEND!(FHSM="") D
- .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHSM,FHDFN)) Q:FHDFN'>0 D
- ..S FHLOC=$P($G(^FHPT(FHDFN,"SM",FHSM,0)),U,3)
- ..I $P($G(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM Q
- ..S FHMEAL=$P($G(^FHPT(FHDFN,"SM",FHSM,0)),U,9)
- ..Q:"BNE"'[FHMEAL!(FHMEAL="")
- ..S FHOPC(FHMEAL)=FHOPC(FHMEAL)+1
- ; Calculate Employee, Paid, OOD, Grat and Volunteer totals (Guest Meals)
- F FHGM=FHGM:0 S FHGM=$O(^FHPT("GM",FHGM)) Q:FHGM>FHEND!(FHGM="") D
- .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHGM,FHDFN)) Q:FHDFN'>0 D
- ..S FHLOC=$P($G(^FHPT(FHDFN,"GM",FHGM,0)),U,5)
- ..I $P($G(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM Q
- ..S FHCLASS=$P($G(^FHPT(FHDFN,"GM",FHGM,0)),U,2)
- ..Q:"EGOPV"'[FHCLASS!(FHCLASS="")
- ..S FHMEAL=$P($G(^FHPT(FHDFN,"GM",FHGM,0)),U,3)
- ..Q:"BNE"'[FHMEAL!(FHMEAL="")
- ..S FHOPC(FHCLASS,FHMEAL)=FHOPC(FHCLASS,FHMEAL)+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMADM2 3468 printed Feb 18, 2025@23:14:10 Page 2
- FHMADM2 ; HISC/AAC - Multidivisional Enter/Edit Served Meals ;10/9/03 09:53
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Served Meals
- +1 DO NOW^%DTC
- SET DT=%\1
- KILL %,%H,%I
- +2 SET (ZZOUT,COMM)=0
- SET ZOUT=$PIECE($GET(^FH(119.6,0)),"^",4)
- +3 ;
- E1 SET %DT="AEPX"
- SET %DT("A")="SERVED MEALS Date: "
- WRITE !
- DO ^%DT
- if "^"[X!$DATA(DTOUT)
- GOTO KIL^FHMADM21
- if Y<1
- GOTO E1
- +1 ;
- +2 SET DA=+Y
- SET (FHRM,FHSM,FHGM)=DA
- IF DA'<DT
- WRITE *7,!!,"** Input must be for a date before today in order to collect ADT data!",!
- GOTO E1
- +3 ;
- +4 ;Enter Communications Office
- +5 KILL DIC,DIE
- SET DIE="^FH(117,"
- IF '$DATA(^FH(117,DA,0))
- SET ^FH(117,DA,0)=DA
- SET ^FH(117,"B",DA,DA)=""
- SET X0=^FH(117,0)
- SET $PIECE(^FH(117,0),"^",3,4)=DA_"^"_($PIECE(X0,"^",4)+1)
- +6 SET DA=+Y
- IF $GET(^FH(117,DA,"I"))="Y"
- WRITE !," ** INACTIVE COMM OFFICE **"
- QUIT
- +7 SET ^FH(117,DA,0)=DA
- +8 SET DR="[FHMADM2]"
- DO ^DIE
- +9 QUIT
- +10 ;
- C1 ;
- +1 KILL FHN
- WRITE !!,"Calculating Census Values ...",!
- +2 FOR W1=0:0
- SET W1=$ORDER(^DG(41.9,W1))
- if W1'>0
- QUIT
- DO C2
- +3 WRITE !,"Calculating Outpatient Values ...",!
- DO CALCOP
- +4 QUIT
- C2 ;
- +1 IF '$DATA(^DG(41.9,W1,"C",DA(1)))
- QUIT
- +2 SET X0=^DG(41.9,W1,"C",DA(1),0)
- SET X1=$GET(^(1))
- IF $DATA(^DIC(42,W1,0))
- SET FHWARD=$ORDER(^FH(119.6,"AW",W1,""))
- if FHWARD=""
- QUIT
- +3 SET FHCOM19=$PIECE($GET(^FH(119.6,FHWARD,0)),"^",8)
- if FHCOMM'=FHCOM19
- QUIT
- +4 SET TYP=$PIECE(^DIC(42,W1,0),"^",3)
- SET TYP=$SELECT(TYP="D":"D",TYP="NH":"N",1:"H")
- +5 IF '$DATA(FHN(TYP))
- SET FHN(TYP,0)=0
- SET FHN(TYP,1)=0
- +6 SET Y0=$PIECE(X0,"^",2)
- SET Y1=$PIECE(X1,"^",5)
- +7 if Y0
- SET FHN(TYP,0)=FHN(TYP,0)+Y0
- if Y1
- SET FHN(TYP,1)=FHN(TYP,1)+Y1
- QUIT
- +8 QUIT
- DT ; Get From/To Dates
- D1 SET %DT="AEPX"
- SET %DT("A")="Starting Date: "
- WRITE !
- DO ^%DT
- if $DATA(DTOUT)
- SET X="^"
- if U[X
- QUIT
- if Y<1
- GOTO D1
- SET SDT=+Y
- +1 IF SDT'<DT
- WRITE *7," [Must Start before Today!] "
- GOTO D1
- D2 SET %DT="AEPX"
- SET %DT("A")=" Ending Date: "
- DO ^%DT
- if $DATA(DTOUT)
- SET X="^"
- if U[X
- QUIT
- if Y<1
- GOTO D2
- SET EDT=+Y
- +1 IF EDT'<DT
- WRITE *7," [Must End before Today!] "
- GOTO D2
- +2 IF EDT<SDT
- WRITE *7," [End before Start?] "
- GOTO D1
- +3 QUIT
- CALCOP ; Calculate Outpatient totals (Recurring and Special Meals) for the
- +1 ; selected Communication Office
- +2 ;
- +3 KILL FHOPC
- SET FHEND=FHRM_.9999
- SET X1=FHRM
- SET X2=-1
- DO C^%DTC
- SET FHRM=X
- +4 FOR IX="B","N","E"
- SET FHOPC(IX)=0
- FOR FC="E","G","O","P","V"
- SET FHOPC(FC,IX)=0
- +5 ; Count recurring meals totals in FHOPC(INDX)
- +6 FOR FHRM=FHRM:0
- SET FHRM=$ORDER(^FHPT("RM",FHRM))
- if FHRM=""!(FHRM'<FHEND)
- QUIT
- Begin DoDot:1
- +7 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("RM",FHRM,FHDFN))
- if FHDFN=""
- QUIT
- Begin DoDot:2
- +8 FOR FHRNUM=0:0
- SET FHRNUM=$ORDER(^FHPT("RM",FHRM,FHDFN,FHRNUM))
- if FHRNUM=""
- QUIT
- Begin DoDot:3
- +9 SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3)
- +10 IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM
- QUIT
- +11 SET FHMEAL=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
- +12 if "BNE"'[FHMEAL!(FHMEAL="")
- QUIT
- +13 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
- QUIT
- +14 SET FHOPC(FHMEAL)=FHOPC(FHMEAL)+1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 ; Add special meals to recurring meals totals in FHOPC(INDX)
- +16 FOR FHSM=FHSM:0
- SET FHSM=$ORDER(^FHPT("SM",FHSM))
- if FHSM>FHEND!(FHSM="")
- QUIT
- Begin DoDot:1
- +17 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("SM",FHSM,FHDFN))
- if FHDFN'>0
- QUIT
- Begin DoDot:2
- +18 SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"SM",FHSM,0)),U,3)
- +19 IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM
- QUIT
- +20 SET FHMEAL=$PIECE($GET(^FHPT(FHDFN,"SM",FHSM,0)),U,9)
- +21 if "BNE"'[FHMEAL!(FHMEAL="")
- QUIT
- +22 SET FHOPC(FHMEAL)=FHOPC(FHMEAL)+1
- End DoDot:2
- End DoDot:1
- +23 ; Calculate Employee, Paid, OOD, Grat and Volunteer totals (Guest Meals)
- +24 FOR FHGM=FHGM:0
- SET FHGM=$ORDER(^FHPT("GM",FHGM))
- if FHGM>FHEND!(FHGM="")
- QUIT
- Begin DoDot:1
- +25 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("GM",FHGM,FHDFN))
- if FHDFN'>0
- QUIT
- Begin DoDot:2
- +26 SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"GM",FHGM,0)),U,5)
- +27 IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM
- QUIT
- +28 SET FHCLASS=$PIECE($GET(^FHPT(FHDFN,"GM",FHGM,0)),U,2)
- +29 if "EGOPV"'[FHCLASS!(FHCLASS="")
- QUIT
- +30 SET FHMEAL=$PIECE($GET(^FHPT(FHDFN,"GM",FHGM,0)),U,3)
- +31 if "BNE"'[FHMEAL!(FHMEAL="")
- QUIT
- +32 SET FHOPC(FHCLASS,FHMEAL)=FHOPC(FHCLASS,FHMEAL)+1
- End DoDot:2
- End DoDot:1
- +33 QUIT