Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHMADM2

FHMADM2.m

Go to the documentation of this file.
  1. FHMADM2 ; HISC/AAC - Multidivisional Enter/Edit Served Meals ;10/9/03 09:53
  1. ;;5.5;DIETETICS;;Jan 28, 2005
  1. EN1 ; Enter/Edit Served Meals
  1. D NOW^%DTC S DT=%\1 K %,%H,%I
  1. S (ZZOUT,COMM)=0,ZOUT=$P($G(^FH(119.6,0)),"^",4)
  1. ;
  1. E1 S %DT="AEPX",%DT("A")="SERVED MEALS Date: " W ! D ^%DT G KIL^FHMADM21:"^"[X!$D(DTOUT),E1:Y<1
  1. ;
  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
  1. ;
  1. ;Enter Communications Office
  1. 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)
  1. S DA=+Y I $G(^FH(117,DA,"I"))="Y" W !," ** INACTIVE COMM OFFICE **" Q
  1. S ^FH(117,DA,0)=DA
  1. S DR="[FHMADM2]" D ^DIE
  1. Q
  1. ;
  1. C1 ;
  1. K FHN W !!,"Calculating Census Values ...",!
  1. F W1=0:0 S W1=$O(^DG(41.9,W1)) Q:W1'>0 D C2
  1. W !,"Calculating Outpatient Values ...",! D CALCOP
  1. Q
  1. C2 ;
  1. I '$D(^DG(41.9,W1,"C",DA(1))) Q
  1. 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=""
  1. S FHCOM19=$P($G(^FH(119.6,FHWARD,0)),"^",8) Q:FHCOMM'=FHCOM19
  1. S TYP=$P(^DIC(42,W1,0),"^",3),TYP=$S(TYP="D":"D",TYP="NH":"N",1:"H")
  1. I '$D(FHN(TYP)) S FHN(TYP,0)=0,FHN(TYP,1)=0
  1. S Y0=$P(X0,"^",2),Y1=$P(X1,"^",5)
  1. S:Y0 FHN(TYP,0)=FHN(TYP,0)+Y0 S:Y1 FHN(TYP,1)=FHN(TYP,1)+Y1 Q
  1. Q
  1. DT ; Get From/To Dates
  1. 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
  1. I SDT'<DT W *7," [Must Start before Today!] " G D1
  1. D2 S %DT="AEPX",%DT("A")=" Ending Date: " D ^%DT S:$D(DTOUT) X="^" Q:U[X G:Y<1 D2 S EDT=+Y
  1. I EDT'<DT W *7," [Must End before Today!] " G D2
  1. I EDT<SDT W *7," [End before Start?] " G D1
  1. Q
  1. CALCOP ; Calculate Outpatient totals (Recurring and Special Meals) for the
  1. ; selected Communication Office
  1. ;
  1. K FHOPC S FHEND=FHRM_.9999,X1=FHRM,X2=-1 D C^%DTC S FHRM=X
  1. F IX="B","N","E" S FHOPC(IX)=0 F FC="E","G","O","P","V" S FHOPC(FC,IX)=0
  1. ; Count recurring meals totals in FHOPC(INDX)
  1. F FHRM=FHRM:0 S FHRM=$O(^FHPT("RM",FHRM)) Q:FHRM=""!(FHRM'<FHEND) D
  1. .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHRM,FHDFN)) Q:FHDFN="" D
  1. ..F FHRNUM=0:0 S FHRNUM=$O(^FHPT("RM",FHRM,FHDFN,FHRNUM)) Q:FHRNUM="" D
  1. ...S FHLOC=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3)
  1. ...I $P($G(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM Q
  1. ...S FHMEAL=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
  1. ...Q:"BNE"'[FHMEAL!(FHMEAL="")
  1. ...I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
  1. ...S FHOPC(FHMEAL)=FHOPC(FHMEAL)+1
  1. ; Add special meals to recurring meals totals in FHOPC(INDX)
  1. F FHSM=FHSM:0 S FHSM=$O(^FHPT("SM",FHSM)) Q:FHSM>FHEND!(FHSM="") D
  1. .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHSM,FHDFN)) Q:FHDFN'>0 D
  1. ..S FHLOC=$P($G(^FHPT(FHDFN,"SM",FHSM,0)),U,3)
  1. ..I $P($G(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM Q
  1. ..S FHMEAL=$P($G(^FHPT(FHDFN,"SM",FHSM,0)),U,9)
  1. ..Q:"BNE"'[FHMEAL!(FHMEAL="")
  1. ..S FHOPC(FHMEAL)=FHOPC(FHMEAL)+1
  1. ; Calculate Employee, Paid, OOD, Grat and Volunteer totals (Guest Meals)
  1. F FHGM=FHGM:0 S FHGM=$O(^FHPT("GM",FHGM)) Q:FHGM>FHEND!(FHGM="") D
  1. .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHGM,FHDFN)) Q:FHDFN'>0 D
  1. ..S FHLOC=$P($G(^FHPT(FHDFN,"GM",FHGM,0)),U,5)
  1. ..I $P($G(^FH(119.6,FHLOC,0)),U,8)'=FHCOMM Q
  1. ..S FHCLASS=$P($G(^FHPT(FHDFN,"GM",FHGM,0)),U,2)
  1. ..Q:"EGOPV"'[FHCLASS!(FHCLASS="")
  1. ..S FHMEAL=$P($G(^FHPT(FHDFN,"GM",FHGM,0)),U,3)
  1. ..Q:"BNE"'[FHMEAL!(FHMEAL="")
  1. ..S FHOPC(FHCLASS,FHMEAL)=FHOPC(FHCLASS,FHMEAL)+1
  1. Q