source: FOIAVistA/tag/r/DIETETICS-FH/FHORD9.m@ 1251

Last change on this file since 1251 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1FHORD9 ; HISC/REL/NCA/RVD - Diet Order Census ;7/1/94 14:24
2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
3 ;
4 ;patch #5 - added screen for cancelled guest meals.
5 ;
6 D NOW^%DTC S DT=%\1 K %,^TMP($J)
7 D DIV^FHOMUTL G:'$D(FHSITE) KIL
8 S FHP=$O(^FH(119.71,0)) I FHP'<1,$O(^FH(119.71,FHP))<1 G F0
9D0 R !!,"Select PRODUCTION FACILITY: ",X:DTIME G:'$T!("^"[X) KIL
10 K DIC S DIC="^FH(119.71,",DIC(0)="EMQ" D ^DIC G:Y<1 D0 S FHP=+Y
11F0 R !!,"Effective Date/Time: ",X:DTIME G:'$T!("^"[X) KIL S %DT="ETSX" D ^%DT G:Y<1 F0 S TIM=Y
12 I (TIM\1)<DT W *7," Cannot be before TODAY!" G F0
13 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
14 I $D(IO("Q")) S FHPGM="Q1^FHORD9",FHLST="FHP^TIM^FHSITE^FHSITENM" D EN2^FH G KIL
15 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
16Q1 ; Calculate census
17 K ^TMP($J) S CT=0 D NOW^%DTC S NOW=% K %,D,P
18 F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0) D
19 .I '$G(FHSITE) D WRD
20 .I ($G(FHSITE)),($P(X,U,8)=FHSITE) D WRD
21 ;
22 ;get outpatient data
23 S:'$G(FHSITE) FHSITE=""
24 S:'$D(FHSITENM) FHSITENM="CONSOLIDATED"
25 D GETSM^FHOMRBLD(TIM,FHSITE,"","")
26 D GETGM^FHOMRBL1(TIM,FHSITE,"","")
27 S FHTIM=$P(TIM,".",1),FHTIM=FHTIM-.000001
28 D GETRM^FHOMRBLD(FHTIM,FHSITE,"","")
29 D PROSG ;process recurring, special and guest meal from "OP" node
30 G ^FHORD91
31WRD ; Calculate census for ward
32 K S S X1="" F D2=5,6 S N1=$P(X,"^",D2) Q:$G(^FH(119.72,+N1,"I"))="Y" S N2=$P($G(^FH(119.72,+N1,0)),"^",3) I N2=FHP S S($E("TC",D2-4))=N1,D(N1)="",X1=X1_$E("TC",D2-4)
33 Q:'$D(S)
34 S:$L(X1)>1 X1=$E(X1,1) Q:'$D(S(X1)) S SP=S(X1)
35 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",WRD,FHDFN)) I ADM>0 S K=SP D W3
36 Q
37W3 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
38 S X0=^FHPT(FHDFN,"A",ADM,0)
39 S FHORD=$P(X0,"^",2),X1=$P(X0,"^",3),TF=$P(X0,"^",4),N1=$P(X0,"^",5) S:N1="" N1="T"
40 I FHORD<1 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",0)) G:A1=""!(A1>TIM) W4 D U1 G:'FHORD W4 S X1=""
41 I X1>1,X1'>TIM D U1 G:'FHORD W4
42 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) D U1 G:'FHORD W4
43 S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),X1=$P(X,"^",8)
44 S:X1="" X1=N1 S:X1="D" X1="T" Q:'$D(S(X1)) S K=S(X1) D CNT
45 I FHLD="" S Z=$P(X,"^",13) S:Z="" FHLD="X" I Z S:'$D(P(Z,K)) P(Z,K)=0 S P(Z,K)=P(Z,K)+1 Q
46 I FHLD="P" S:'$D(P(.8,K)) P(.8,K)=0 S P(.8,K)=P(.8,K)+1 Q
47 I FHLD="N" D Q
48 .I TF="" S:'$D(P(.5,K)) P(.5,K)=0 S P(.5,K)=P(.5,K)+1 Q
49 .S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1 Q
50 Q:'TF S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1 Q
51W4 G:'TF CNT S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1
52CNT S:'$D(P(.6,K)) P(.6,K)=0 S P(.6,K)=P(.6,K)+1 Q
53U1 S (A1,FHORD)=0 F K1=0:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"AC",K1)) Q:K1<1!(K1>TIM) S A1=K1
54 Q:'A1 S X1=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G U2:X1<1,U2:'$D(^FHPT(FHDFN,"A",ADM,"DI",X1,0)) S FHORD=X1 Q
55U2 S X1="",A1=0
56U3 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) G:A1="" U1 S X2=$P(^(A1,0),"^",2)
57 I X2<1 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G U3
58 I '$D(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) K ^FHPT(FHDFN,"A",ADM,"AC",A1) G U3
59 G U3
60PROSG ;process outpatient data from ^tmp($j global.
61 S FHPLNM=""
62 S:$G(FHSITE) FHPLNM=$P($G(^FH(119.73,FHSITE,0)),U,1)
63REC ;for recurring meals
64 S FHDT=TIM+.999999
65 ;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
66 S FHTMPS="^TMP($J,""OP"",""R"")"
67 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
68 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
69 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
70 ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
71 ..Q:$P(FHRDAT,U,19)="C" ;quit if status is cancelled.
72 ..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
73 ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
74 ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
75 ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
76 ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
77 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
78 ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
79 ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
80 ..S FHREIEN=$P(FHIJKDAT,U,1)
81 ..S FHDIETN=$P(FHIJKDAT,U,3)
82 ..S:$D(^FH(111,"B",FHDIETN)) FHDIET=$O(^FH(111,"B",FHDIETN,0))
83 ..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
84 ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
85 ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
86 ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
87 ..;if tubefeeding, also count the TF data.
88 ..I $D(^FHPT(FHREIEN,"OP",FHK,"TF")) D
89 ...I '$D(P(.7,FHSER)) S P(.7,FHSER)=1
90 ...E S P(.7,FHSER)=P(.7,FHSER)+1
91 ...S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
92 ;
93SPEC ;for special meals
94 S FHTMPS="^TMP($J,""OP"",""S"")" I '$D(FHPLNM) S FHPLNM=""
95 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
96 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
97 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
98 ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
99 ..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
100 ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
101 ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
102 ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
103 ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
104 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
105 ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
106 ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
107 ..S FHSTAT=$P(FHIJKDAT,U,3)
108 ..Q:FHSTAT'="A" ;quit if status is not Authorized
109 ..S FHDIETN=$P(FHIJKDAT,U,4)
110 ..S:$D(^FH(111,"B",FHDIETN)) FHDIET=$O(^FH(111,"B",FHDIETN,0))
111 ..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
112 ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
113 ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
114 ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
115 ;
116GUEST ;for guest meals.
117 ;If no diet, use default outpatient diet in file #119.9.
118 ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
119 S FHTMPS="^TMP($J,""OP"",""G"")" I '$D(FHPLNM) S FHPLNM=""
120 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
121 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
122 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
123 ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
124 ..I $P(FHRDAT,U,7)="C" Q
125 ..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
126 ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
127 ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
128 ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
129 ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
130 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
131 ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
132 ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
133 ..S FHDIETN=$P(FHIJKDAT,U,6)
134 ..S:$D(^FH(111,FHDIETN,0)) FHPDIET=$P(^FH(111,FHDIETN,0),U,5)
135 ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
136 ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
137 ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
138 ;
139 Q
140 ;
141KIL K ^TMP($J) G KILL^XUSCLEAN
142 ;K %,%H,%I,%T,%DT,%ZIS,A1,ADM,CHK,CT,D,D1,D2,FHDFN,DFN,DIC,DOW,DTP,FHLD,FHOR,FHP,FHPAR,K,K1,KK,L1,LP,N,N1,N2,N3,NOW,NXW,FHORD,P,P1,POP,S,SP,TF,TIM,TOT,TYP,WRD,WRDN,X,X0,X1,X2,Y,Z K ^TMP($J) Q
Note: See TracBrowser for help on using the repository browser.