source: FOIAVistA/tag/r/DIETETICS-FH/FHORX1.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1FHORX1 ; HISC/REL/RVD - Diet Activity Report ;9/10/98 15:31
2 ;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
3 ;RVD patch #1 - get outpatient info from Nutrition Events file.
4 ;
5 D NOW^%DTC S NOW=%,TIM=""
6R0 D DIV^FHOMUTL G:'$D(FHSITE) KIL
7 S FHP=FHSITE
8R1 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
9 S LAB=X?1"Y".E
10 S:$G(FHP) TIM=$P($G(^FH(119.73,FHP,0)),"^",$S(LAB:3,1:2))
11 I 'TIM S TIM=DT
12 S FHLBFLG=1 I LAB D I FHLBFLG=0 Q
13 .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
14 .I $D(DIRUT) S FHLBFLG=0 Q
15 .S LABSTART=Y Q
16 S DTP=TIM D DTP^FH
17R3 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
18 W ! K IOP,%ZIS S %ZIS("A")="Select "_$S(LAB:"LABEL",1:"LIST")_" Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
19 I $D(IO("Q")) S FHPGM="Q1^FHORX1",FHLST="TIM^LAB^FHP^LABSTART^FHSITE^FHSITENM" D EN2^FH G KIL
20 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
21Q1 ; Print the Diet Activity Report
22 S FHTIM=TIM ;save date/time for recurring meal data.
23 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
24 F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D WRD
25 I LAB S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1
26 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
27 ;
28OUTP ;get outpatient data
29 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
30 .S FHPROR=99,(FHTC,FHCOMO)=""
31 .S Z=$G(^FH(119.8,DA,0)) Q:Z=""
32 .S FHDTIM=$P(Z,"^",2),FHDFN=$P(Z,"^",3),FHOUTP=$P(Z,"^",5)
33 .Q:FHOUTP'="Z"
34 .S FHACTI=$P(Z,"^",6)
35 .S FHDESC=$P(Z,"^",8),FHLOCN=$P(FHDESC,",",2)
36 .S FHLOCN=$E(FHLOCN,2,$L(FHLOCN))
37 .S:FHLOCN'="" FHLIEN=$O(^FH(119.6,"B",FHLOCN,0))
38 .I $G(FHLIEN) D
39 ..S FHPROR=$P($G(^FH(119.6,FHLIEN,0)),U,4)
40 ..S FHSERV1=$P($G(^FH(119.6,FHLIEN,0)),U,5)
41 ..I $G(FHSERV1),$D(^FH(119.72,FHSERV1,0)) S FHTC=FHTC_$P(^(0),U,2)
42 ..S FHSERV2=$P($G(^FH(119.6,FHLIEN,0)),U,6)
43 ..I $G(FHSERV2),$D(^FH(119.72,FHSERV2,0)) S FHTC=FHTC_$P(^(0),U,2)
44 ..S FHSERV3=$P($G(^FH(119.6,FHLIEN,0)),U,7)
45 ..I $G(FHSERV3) S FHTC=FHTC_"D"
46 ..S FHCOMO=$P($G(^FH(119.6,FHLIEN,0)),U,8)
47 .I $G(FHSITE),FHCOMO'=FHSITE Q
48 .S FHCLER=$P(Z,"^",9)
49 .S FHPTNM="***"
50 .S:FHLOCN="" FHLOCN="***"
51 .D PATNAME^FHOMUTL
52 .S FHLPAT=FHPROR_"~"_FHLOCN_"~~"_DFN_"~"_FHPTNM
53 .S DTP=FHDTIM D DTP^FH
54 .S ^TMP($J,"O",FHLPAT,DA)=FHACTI_"^"_DTP_"^"_FHBID_"^"_FHDESC_"^"_FHTC
55 ;
56 ;D PROSG ;print outpatient data
57 ;go to routines for printing report
58 G ^FHORX1A:'LAB,^FHORX1B
59WRD 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)
60 I $G(FHP),D2=FHP S ^TMP($J,"W",W1)=P0_"~"_WRDN
61 I '$G(FHP) S ^TMP($J,"W",W1)=P0_"~"_WRDN
62 Q
63Q3 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))
64 D PATNAME^FHOMUTL I DFN="" Q
65 S WARD=$G(^DPT(DFN,.1)) G:WARD="" Q5 ; Not an inpatient
66 I $G(^DPT("CN",WARD,DFN))'=ADM Q ; Not current admission
67 S X0=^FHPT(FHDFN,"A",ADM,0),W1=+$P(X0,"^",8) I '$D(^TMP($J,"W",W1)) Q ; Not in this Comm Office
68 S R1=$G(^DPT(DFN,.101))
69 S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
70 S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
71 S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
72 S ^TMP($J,"I",^TMP($J,"W",W1)_"~"_R0_"~"_R1_"~"_FHDFN,DA)=$P(Z,"^",4,9) Q
73Q5 ; process discharges
74 S W1=+$P(Z,"^",8) Q:'W1 Q:'$D(^TMP($J,"W",W1))
75 S ^TMP($J,"I",^TMP($J,"W",W1)_"~~***~"_FHDFN,DA)=$P(Z,"^",4,9)
76 Q
77 ;
78PROSG ;process recurring, special and guest meals.
79 S FHPLNM=""
80 S:$G(FHP) FHPLNM=$P($G(^FH(119.73,FHP,0)),U,1)
81REC ;for recurring meals
82 ;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
83 S FHTMPS="^TMP($J,""OP"",""R"")"
84 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
85 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
86 .S FHPROR="01",FHLOC=""
87 .S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
88 .S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
89 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW) D
90 ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
91 ..S $P(FHRDAT,U,3)=$P(FHIJKDAT,U,18)
92 ..S $P(FHRDAT,U,4)=$P(FHIJKDAT,U,3)
93 ..S $P(FHRDAT,U,9)=$P(FHIJKDAT,U,4)
94 ..S $P(FHRDAT,U,5)=$P(FHIJKDAT,U,8)
95 ..S $P(FHRDAT,U,8)=$P(FHIJKDAT,U,7)
96 ..S $P(FHRDAT,U,13)=$P(FHIJKDAT,U,17)
97 ..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
98 ..S ^TMP($J,"O",FHLPAT,FHK)="RECURRING"_"^"_FHJ_"^"_FHRDAT
99SPEC ;for special meals
100 ;S FHPLNM=$P($G(^FH(119.73,FHP,0)),U,1) Q:FHPLNM="" ;quit if no comm
101 ;S FHTMPS=$NA(^TMP($J,"OP","S"))
102 S FHTMPS="^TMP($J,""OP"",""S"")"
103 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
104 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
105 .S FHPROR="01",FHLOC=""
106 .S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
107 .S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
108 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW) D
109 ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
110 ..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
111 ..S ^TMP($J,"O",FHLPAT,FHK)="SPECIAL"_"^"_FHJ_"^"_FHIJKDAT
112 ;for guest meals
113GUEST ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
114 S FHTMPS="^TMP($J,""OP"",""G"")"
115 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
116 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
117 .S FHPROR="01",FHLOC=""
118 .S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
119 .S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
120 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW) D
121 ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
122 ..S FHGDIET=$P($G(^FH(119.9,1,0)),U,2)
123 ..S $P(FHIJKDAT,U,9)=$P(FHIJKDAT,U,3)
124 ..S $P(FHIJKDAT,U,14)=$P(FHIJKDAT,U,4)
125 ..S $P(FHIJKDAT,U,15)=$P(FHIJKDAT,U,5)
126 ..S FHGDIETN=$P(FHIJKDAT,U,6)
127 ..I $G(FHGDIETN),$D(^FH(111,FHGDIETN,0)) D
128 ...S FHGDTNM=$P(^FH(111,FHGDIETN,0),U,1)
129 ..E S:$G(FHGDIET) FHGDTNM=$P($G(^FH(111,FHGDIET,0)),U,1)
130 ..S $P(FHIJKDAT,U,4)=FHGDTNM
131 ..I $G(FHGDIET),$D(^FH(111,FHGDIET,0)) D
132 ...S $P(FHIJKDAT,U,4)=$P(^FH(111,FHGDIET,0),U,1)
133 ..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
134 ..S ^TMP($J,"O",FHLPAT,FHK)="GUEST"_"^"_FHJ_"^"_FHIJKDAT
135 Q
136 ;
137KIL K ^TMP($J) G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.