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

FHPRO3.m

Go to the documentation of this file.
  1. FHPRO3 ; HISC/REL/RVD - Recipe Calculations ;4/14/95 08:05
  1. ;;5.5;DIETETICS;**3,5**;Jan 28, 2005;Build 53
  1. ;RVD 5/20/05 - as part of AFP project.
  1. ;patch #5 -added a screen for cancelled quest meals.
  1. K ^TMP($J,"FH","T"),P,T
  1. I '$G(FHAFLG) K ^TMP($J,"AFP","T")
  1. ;S K3=$F("BNE",MEAL)-1,FHX1=$P(FHDA,"^",K3+1) Q:'FHX1
  1. F L1=0:0 S L1=$O(^FH(116.2,L1)) Q:L1<1 S Z=$P($G(^(L1,0)),"^",2) I Z'="" S P(Z)=L1
  1. F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0<1 S Z=$P($G(^FH(119.72,P0,0)),"^",2) I Z'="" S T(P0)=Z
  1. D P1
  1. S FHAFLG=1
  1. G ^FHPRO4
  1. P1 F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 S (D1,X1)=FHDODAY(FHI) D FHD,P12
  1. K M,P,T,Y,Z,Z1 Q
  1. P12 S K3=$F("BNE",MEAL)-1,FHX1=$P(FHDA,"^",K3+1) Q:'FHX1
  1. Q:'$D(^FH(116.1,FHX1))
  1. F M=0:0 S M=$O(^FH(116.1,FHX1,"RE",M)) Q:M<1 S L1=^(M,0),L1=+L1 D P2
  1. Q
  1. P2 S N1=0,X=$G(^FH(114,L1,0)),K4=$P(X,"^",12),K4=$S($D(^FH(114.2,+K4,0)):$P(^(0),"^",3),1:99)
  1. ;S MCA=$O(^FH(116.1,FHX1,"RE",M,"R",0)),LL=$S(MCA:+$G(^FH(116.1,FHX1,"RE",M,"R",MCA,0)),1:99)
  1. ;S FHPD=$P(LL,"^",2),LL=+LL
  1. ;S LL=$S($D(^FH(114.1,+LL,0)):$P(^(0),"^",3),1:99)
  1. ;
  1. S LL=$P(X,"^",7)
  1. I $G(LL) S LL=$S($D(^FH(114.1,+LL,0)):$P(^(0),"^",3),1:99)
  1. S K4=$S(K4<1:99,K4<10:"0"_K4,1:K4)_$S(LL<1:99,LL<10:"0"_LL,1:LL)_$E($P(X,"^",1),1,26)
  1. F P0=0:0 S P0=$O(^TMP($J,"FHD",D1,P0)) Q:P0<1 D R1 ;I N2 S ^TMP($J,"FH","T",K4,L1,P0)=N2,^TMP($J,"AFP","T",K4,L1,P0)=N2
  1. Q:'N1 S:'$G(^TMP($J,"FH","T",K4,L1)) ^TMP($J,"FH","T",K4,L1)=0 S ^(L1)=^(L1)+N1
  1. S:'$G(^TMP($J,"AFP","T",K4,L1)) ^TMP($J,"AFP","T",K4,L1)=0 S ^(L1)=^(L1)+N1
  1. Q
  1. R1 S Z1=$P($G(^FH(116.1,FHX1,"RE",M,"D",P0,0)),"^",2),N2=0
  1. F CAT=0:0 S CAT=$O(^FH(116.1,FHX1,"RE",M,"R",CAT)) Q:CAT<1 S FHPD=$P($G(^(CAT,0)),"^",2) D
  1. .F LL=1:1 S FHX2=$P(FHPD," ",LL) Q:FHX2="" S X=$P(FHX2,";",1) I X'="",$D(P(X)) D P3
  1. .Q
  1. Q
  1. P3 S FHPX1=$G(^TMP($J,"FHD",D1,P0,P(X))) Q:'FHPX1
  1. S Y=$P(FHX2,";",2) I Y="" S:Z1'="" FHPX1=$J(Z1*FHPX1/100,0,0) G P4
  1. D P5 S Y=$P(FHX2,";",3) D:Y'="" P5
  1. P4 S N1=N1+FHPX1,N2=N2+FHPX1 ;S:FHPX1 ^TMP($J,"FH","T",K4,L1,P0)=FHPX1 Q
  1. I FHPX1 S:'$D(^TMP($J,"FH","T",K4,L1,P0)) ^TMP($J,"FH","T",K4,L1,P0)=0 S ^TMP($J,"FH","T",K4,L1,P0)=^TMP($J,"FH","T",K4,L1,P0)+FHPX1
  1. Q
  1. P5 S:$E(Y,1)=T(P0) FHPX1=$J($E(Y,2,99)*FHPX1/100,0,0) Q
  1. ;
  1. FHD ;get FHDA
  1. S:$D(FHDA) FHDASV=FHDA
  1. D E1^FHPRC1
  1. I '$G(FHCY)!'$G(FHDA) S FHDA=FHDASV Q
  1. S FHDA=^FH(116,FHCY,"DA",FHDA,0)
  1. I $D(^FH(116.3,D1,0)) S X=^(0) F LL=2:1:4 I $P(X,"^",LL) S $P(FHDA,"^",LL)=$P(X,"^",LL)
  1. Q
  1. ;
  1. OUT ;process outpatient data
  1. REC S FHTIM=D1-.000001,FHDT299=FHDT2+.99999
  1. F FHIR=FHTIM:0 S FHIR=$O(^FHPT("RM",FHIR)) Q:(FHIR'>0)!(FHIR>(FHDT299)) F FHIDFN=0:0 S FHIDFN=$O(^FHPT("RM",FHIR,FHIDFN)) Q:FHIDFN'>0 D
  1. .F FHIEN=0:0 S FHIEN=$O(^FHPT("RM",FHIR,FHIDFN,FHIEN)) Q:FHIEN'>0 D
  1. ..S FHPX1=FHIR\1
  1. ..S FHREDAT=$G(^FHPT(FHIDFN,"OP",FHIEN,0))
  1. ..Q:$P(FHREDAT,U,4)'=MEAL
  1. ..Q:$P(FHREDAT,U,15)="C"
  1. ..S FHLOC=$P(FHREDAT,U,3) Q:'$G(FHLOC)
  1. ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
  1. ..S FHRDIET=$P(FHREDAT,U,2) Q:'$G(FHRDIET)
  1. ..S FHPDIET=$P($G(^FH(111,FHRDIET,0)),U,5)
  1. ..I $G(FHLOC) D
  1. ...S FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5) S:$G(FHSER) SP(FHSER)=""
  1. ...I '$G(FHSER) S FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6) S:$G(FHSER) SP(FHSER)=""
  1. ...I '$G(FHSER) S FHSER=$O(^FH(119.72,0)) S:$G(FHSER) SP(FHSER)=""
  1. ..Q:'$G(FHSER)
  1. ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
  1. ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
  1. ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
  1. ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
  1. ..S:'$D(^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)) ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=0
  1. ..S ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)+1
  1. ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
  1. ..;if tubefeeding and not cancelled, also count the TF data.
  1. ..I $D(^FHPT(FHIDFN,"OP",FHIEN,"TF")) D
  1. ...Q:$P(^FHPT(FHIDFN,"OP",FHIEN,3),U,5)="C"
  1. ...I '$D(P(.7,FHSER)) S P(.7,FHSER)=1
  1. ...E S P(.7,FHSER)=P(.7,FHSER)+1
  1. ...S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
  1. ;
  1. SPEC ;process special meal
  1. S FHITIM=D1-.00001
  1. F FHI=FHITIM:0 S FHI=$O(^FHPT("SM",FHI)) Q:(FHI'>0)!(FHI>FHDT299) D
  1. .F FHJ=0:0 S FHJ=$O(^FHPT("SM",FHI,FHJ)) Q:FHJ'>0 D
  1. ..S FHPX1=FHI\1
  1. ..S FHNODE=$G(^FHPT(FHJ,"SM",FHI,0))
  1. ..S FHSTAT=$P(FHNODE,U,2)
  1. ..I FHSTAT'="A",(FHSTAT'="P") Q
  1. ..S FHLPT=$P(FHNODE,U,3)
  1. ..S FHDIET=$P(FHNODE,U,4)
  1. ..S:'$G(FHDIET) FHDIET=$P($G(^FH(119.9,1,0)),U,2)
  1. ..I $G(FHDIET),$D(^FH(111,FHDIET,0)) S FHPDIET=$P(^FH(111,FHDIET,0),U,5)
  1. ..Q:'$G(FHPDIET)
  1. ..I $G(FHSITE) S FHCOM=$P(^FH(119.6,FHLPT,0),U,8) Q:FHSITE'=FHCOM
  1. ..S FHSER=""
  1. ..I $G(FHLPT) D
  1. ...S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,5) S:$G(FHSER) SP(FHSER)=""
  1. ...I '$G(FHSER) S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,6) S:$G(FHSER) SP(FHSER)=""
  1. ...I '$G(FHSER) S FHSER=$O(^FH(119.72,0)) S:$G(FHSER) SP(FHSER)=""
  1. ..Q:FHSER=""
  1. ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
  1. ..S FHMEAL=$P(FHNODE,U,9)
  1. ..Q:FHMEAL'=MEAL
  1. ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
  1. ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
  1. ..S:'$D(^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)) ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=0
  1. ..S ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)+1
  1. ..;S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
  1. ;
  1. GUEST ;process GUEST meal
  1. F FHI=FHITIM:0 S FHI=$O(^FHPT("GM",FHI)) Q:(FHI'>0)!(FHI>FHDT299) D
  1. .F FHJ=0:0 S FHJ=$O(^FHPT("GM",FHI,FHJ)) Q:FHJ'>0 D
  1. ..S FHPX1=FHI\1
  1. ..S FHNODE=$G(^FHPT(FHJ,"GM",FHI,0))
  1. ..S FHMEAL=$P(FHNODE,U,3)
  1. ..Q:FHMEAL'=MEAL
  1. ..Q:$P(FHNODE,U,9)="C"
  1. ..S FHLPT=$P(FHNODE,U,5)
  1. ..S FHDIET=$P(FHNODE,U,6)
  1. ..S:'$G(FHDIET) FHDIET=$P($G(^FH(119.9,1,0)),U,2)
  1. ..I $G(FHDIET),$D(^FH(111,FHDIET,0)) S FHPDIET=$P(^FH(111,FHDIET,0),U,5)
  1. ..Q:'$G(FHPDIET)
  1. ..I $G(FHSITE) S FHCOM=$P(^FH(119.6,FHLPT,0),U,8) Q:FHSITE'=FHCOM
  1. ..S FHSER=""
  1. ..I $G(FHLPT) D
  1. ...S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,5) S:$G(FHSER) SP(FHSER)=""
  1. ...I '$G(FHSER) S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,6) S:$G(FHSER) SP(FHSER)=""
  1. ...I '$G(FHSER) S FHSER=$O(^FH(119.72,0)) S:$G(FHSER) SP(FHSER)=""
  1. ..Q:FHSER=""
  1. ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
  1. ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
  1. ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
  1. ..S:'$D(^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)) ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=0
  1. ..S ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)+1
  1. ..;S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
  1. Q