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 Dec 13, 2024@01:47:47 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
