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

FHORX1.m

Go to the documentation of this file. 
  1. FHORX1 ; HISC/REL/RVD - Diet Activity Report ;9/10/98  15:31
  1.  ;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
  1.  ;RVD patch #1 - get outpatient info from Nutrition Events file.
  1.  ;
  1.  D NOW^%DTC S NOW=%,TIM=""
  1. R0 D DIV^FHOMUTL G:'$D(FHSITE) KIL
  1.  S FHP=FHSITE
  1. R1 R !!,"Do you want labels? N// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,"  Enter YES or NO" G R1
  1.  S LAB=X?1"Y".E
  1.  S:$G(FHP) TIM=$P($G(^FH(119.73,FHP,0)),"^",$S(LAB:3,1:2))
  1.  I 'TIM S TIM=DT
  1.  S FHLBFLG=1 I LAB D  I FHLBFLG=0 Q
  1.  .W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR
  1.  .I $D(DIRUT) S FHLBFLG=0 Q
  1.  .S LABSTART=Y Q
  1.  S DTP=TIM D DTP^FH
  1. R3 W !!,"Changes since Date/Time: ",DTP," // " R X:DTIME G:'$T!(X["^") KIL I X'="" S %DT="EXTS" D ^%DT K %DT G:Y<1 R3 S TIM=Y
  1.  W ! K IOP,%ZIS S %ZIS("A")="Select "_$S(LAB:"LABEL",1:"LIST")_" Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
  1.  I $D(IO("Q")) S FHPGM="Q1^FHORX1",FHLST="TIM^LAB^FHP^LABSTART^FHSITE^FHSITENM" D EN2^FH G KIL
  1.  U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
  1. Q1 ; Print the Diet Activity Report
  1.  S FHTIM=TIM    ;save date/time for recurring meal data.
  1.  K ^TMP($J) D NOW^%DTC S NOW=%,DTP=TIM,TIM=TIM-.000001 D DTP^FH S H1=DTP_" - " S DTP=NOW D DTP^FH S H1=H1_DTP D ^FHDEV
  1.  F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1  D WRD
  1.  I LAB S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1
  1.  F LLL=TIM:0 S LLL=$O(^FH(119.8,"AD",LLL)) Q:LLL<1  F DA=0:0 S DA=$O(^FH(119.8,"AD",LLL,DA)) Q:DA<1  D Q3
  1.  ;
  1. OUTP ;get outpatient data
  1.  F LLL=TIM:0 S LLL=$O(^FH(119.8,"AD",LLL)) Q:LLL<1  F DA=0:0 S DA=$O(^FH(119.8,"AD",LLL,DA)) Q:DA<1  D
  1.  .S FHPROR=99,(FHTC,FHCOMO)=""
  1.  .S Z=$G(^FH(119.8,DA,0)) Q:Z=""
  1.  .S FHDTIM=$P(Z,"^",2),FHDFN=$P(Z,"^",3),FHOUTP=$P(Z,"^",5)
  1.  .Q:FHOUTP'="Z"
  1.  .S FHACTI=$P(Z,"^",6)
  1.  .S FHDESC=$P(Z,"^",8),FHLOCN=$P(FHDESC,",",2)
  1.  .S FHLOCN=$E(FHLOCN,2,$L(FHLOCN))
  1.  .S:FHLOCN'="" FHLIEN=$O(^FH(119.6,"B",FHLOCN,0))
  1.  .I $G(FHLIEN) D
  1.  ..S FHPROR=$P($G(^FH(119.6,FHLIEN,0)),U,4)
  1.  ..S FHSERV1=$P($G(^FH(119.6,FHLIEN,0)),U,5)
  1.  ..I $G(FHSERV1),$D(^FH(119.72,FHSERV1,0)) S FHTC=FHTC_$P(^(0),U,2)
  1.  ..S FHSERV2=$P($G(^FH(119.6,FHLIEN,0)),U,6)
  1.  ..I $G(FHSERV2),$D(^FH(119.72,FHSERV2,0)) S FHTC=FHTC_$P(^(0),U,2)
  1.  ..S FHSERV3=$P($G(^FH(119.6,FHLIEN,0)),U,7)
  1.  ..I $G(FHSERV3) S FHTC=FHTC_"D"
  1.  ..S FHCOMO=$P($G(^FH(119.6,FHLIEN,0)),U,8)
  1.  .I $G(FHSITE),FHCOMO'=FHSITE Q
  1.  .S FHCLER=$P(Z,"^",9)
  1.  .S FHPTNM="***"
  1.  .S:FHLOCN="" FHLOCN="***"
  1.  .D PATNAME^FHOMUTL
  1.  .S FHLPAT=FHPROR_"~"_FHLOCN_"~~"_DFN_"~"_FHPTNM
  1.  .S DTP=FHDTIM D DTP^FH
  1.  .S ^TMP($J,"O",FHLPAT,DA)=FHACTI_"^"_DTP_"^"_FHBID_"^"_FHDESC_"^"_FHTC
  1.  ;
  1.  ;D PROSG   ;print outpatient data
  1.  ;go to routines for printing report
  1.  G ^FHORX1A:'LAB,^FHORX1B
  1. WRD S P0=$G(^FH(119.6,W1,0)),WRDN=$P(P0,"^",1),D2=$P(P0,"^",8),P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
  1.  I $G(FHP),D2=FHP S ^TMP($J,"W",W1)=P0_"~"_WRDN
  1.  I '$G(FHP) S ^TMP($J,"W",W1)=P0_"~"_WRDN
  1.  Q
  1. Q3 S Z=$G(^FH(119.8,DA,0)) Q:Z=""  S TM1=($P(Z,"^",2)\1),FHDFN=$P(Z,"^",3),ADM=$P(Z,"^",4) Q:'$G(ADM)  Q:'$D(^FHPT(FHDFN,"A",ADM,0))
  1.  D PATNAME^FHOMUTL I DFN="" Q
  1.  S WARD=$G(^DPT(DFN,.1)) G:WARD="" Q5 ; Not an inpatient
  1.  I $G(^DPT("CN",WARD,DFN))'=ADM Q  ; Not current admission
  1.  S X0=^FHPT(FHDFN,"A",ADM,0),W1=+$P(X0,"^",8) I '$D(^TMP($J,"W",W1)) Q  ; Not in this Comm Office
  1.  S R1=$G(^DPT(DFN,.101))
  1.  S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
  1.  S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
  1.  S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
  1.  S ^TMP($J,"I",^TMP($J,"W",W1)_"~"_R0_"~"_R1_"~"_FHDFN,DA)=$P(Z,"^",4,9) Q
  1. Q5 ; process discharges
  1.  S W1=+$P(Z,"^",8) Q:'W1  Q:'$D(^TMP($J,"W",W1))
  1.  S ^TMP($J,"I",^TMP($J,"W",W1)_"~~***~"_FHDFN,DA)=$P(Z,"^",4,9)
  1.  Q
  1.  ;
  1. PROSG ;process recurring, special and guest meals.
  1.  S FHPLNM=""
  1.  S:$G(FHP) FHPLNM=$P($G(^FH(119.73,FHP,0)),U,1)
  1. REC ;for recurring meals
  1.  ;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
  1.  S FHTMPS="^TMP($J,""OP"",""R"")"
  1.  S FHN="" F  S FHN=$O(@FHTMPS@(FHN)) Q:FHN=""  S FHI="" F  S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI=""  S FHJ="" F  S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ=""  D
  1.  .I (FHPLNM'=""),(FHN'=FHPLNM) Q
  1.  .S FHPROR="01",FHLOC=""
  1.  .S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
  1.  .S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
  1.  .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW)  D
  1.  ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
  1.  ..S $P(FHRDAT,U,3)=$P(FHIJKDAT,U,18)
  1.  ..S $P(FHRDAT,U,4)=$P(FHIJKDAT,U,3)
  1.  ..S $P(FHRDAT,U,9)=$P(FHIJKDAT,U,4)
  1.  ..S $P(FHRDAT,U,5)=$P(FHIJKDAT,U,8)
  1.  ..S $P(FHRDAT,U,8)=$P(FHIJKDAT,U,7)
  1.  ..S $P(FHRDAT,U,13)=$P(FHIJKDAT,U,17)
  1.  ..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
  1.  ..S ^TMP($J,"O",FHLPAT,FHK)="RECURRING"_"^"_FHJ_"^"_FHRDAT
  1. SPEC ;for special meals
  1.  ;S FHPLNM=$P($G(^FH(119.73,FHP,0)),U,1) Q:FHPLNM=""    ;quit if no comm
  1.  ;S FHTMPS=$NA(^TMP($J,"OP","S"))
  1.  S FHTMPS="^TMP($J,""OP"",""S"")"
  1.  S FHN="" F  S FHN=$O(@FHTMPS@(FHN)) Q:FHN=""  S FHI="" F  S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI=""  S FHJ="" F  S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ=""  D
  1.  .I (FHPLNM'=""),(FHN'=FHPLNM) Q
  1.  .S FHPROR="01",FHLOC=""
  1.  .S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
  1.  .S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
  1.  .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW)  D
  1.  ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
  1.  ..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
  1.  ..S ^TMP($J,"O",FHLPAT,FHK)="SPECIAL"_"^"_FHJ_"^"_FHIJKDAT
  1.  ;for guest meals
  1. GUEST ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
  1.  S FHTMPS="^TMP($J,""OP"",""G"")"
  1.  S FHN="" F  S FHN=$O(@FHTMPS@(FHN)) Q:FHN=""  S FHI="" F  S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI=""  S FHJ="" F  S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ=""  D
  1.  .I (FHPLNM'=""),(FHN'=FHPLNM) Q
  1.  .S FHPROR="01",FHLOC=""
  1.  .S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
  1.  .S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
  1.  .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW)  D
  1.  ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
  1.  ..S FHGDIET=$P($G(^FH(119.9,1,0)),U,2)
  1.  ..S $P(FHIJKDAT,U,9)=$P(FHIJKDAT,U,3)
  1.  ..S $P(FHIJKDAT,U,14)=$P(FHIJKDAT,U,4)
  1.  ..S $P(FHIJKDAT,U,15)=$P(FHIJKDAT,U,5)
  1.  ..S FHGDIETN=$P(FHIJKDAT,U,6)
  1.  ..I $G(FHGDIETN),$D(^FH(111,FHGDIETN,0)) D
  1.  ...S FHGDTNM=$P(^FH(111,FHGDIETN,0),U,1)
  1.  ..E  S:$G(FHGDIET) FHGDTNM=$P($G(^FH(111,FHGDIET,0)),U,1)
  1.  ..S $P(FHIJKDAT,U,4)=FHGDTNM
  1.  ..I $G(FHGDIET),$D(^FH(111,FHGDIET,0)) D
  1.  ...S $P(FHIJKDAT,U,4)=$P(^FH(111,FHGDIET,0),U,1)
  1.  ..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
  1.  ..S ^TMP($J,"O",FHLPAT,FHK)="GUEST"_"^"_FHJ_"^"_FHIJKDAT
  1.  Q
  1.  ;
  1. KIL K ^TMP($J) G KILL^XUSCLEAN