source: FOIAVistA/tag/r/DIETETICS-FH/FHDCR1A.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: 7.1 KB
Line 
1FHDCR1A ; HISC/REL/NCA/RVD - Build Diet Cards ;1/21/99 14:04
2 ;;5.5;DIETETICS;**1,5**;Jan 28, 2005;Build 53
3 ;patch #5 - added the screen for cancelled Guest meal.
4B1 ; Store wards
5 K ^TMP($J),NN,N,P S MFLG=0 D Q1^FHDCR1B D NOW^%DTC S (DTP,TIM)=% D DTP^FH S HD=DTP S:MEAL="A" MFLG=1
6 S DTP=D1 D DTP^FH S (MDT,MEALDT)=DTP,MEALDT=$J("",62-$L(MEALDT)\2)_MEALDT
7 S FHBOT=$P($G(^FH(119.9,1,4)),"^",1)
8 S FHD1=D1-.00001,FHD2=D1+.99999
9 S FHDFNSAV="",FHW1SAV=W1,FHFHPSAV=FHP,FHMEALSA=MEAL
10 S:$G(FHDFN) FHDFNSAV=FHDFN
11 I $G(DFN),'$D(^DPT(DFN,.1)) G OUTALL
12 I '$G(DFN),$G(FHDFN) G OUTALL
13 ;next process inpatient data
14DFN I $G(DFN),$G(FHDFN) D Q
15 .S ADM=+$G(^DPT(DFN,.105)),W1=+$P($G(^FHPT(FHDFN,"A",+ADM,0)),"^",8)
16 .S K1=$G(^FH(119.6,+W1,0)),WRDN=$P(K1,"^",1),SP=$P(K1,"^",5),SP1=$P(K1,"^",6),FHPAR=$P(K1,"^",24),RM=$G(^DPT(DFN,.101))
17 .I 'SP Q:FHPAR'="Y" S SP=SP1 Q:'SP
18 .K PP,S,MM S NBR=0
19 .I 'TPP D BLD^FHDCR11 D:NBR UPD,PRT^FHDCR1C Q
20 .I 'MFLG D BLD^FHDCR1D D:NBR UPD,PRT^FHMTK1C Q
21 .F MEAL="B","N","E" D BLD^FHDCR1D
22 .D UPD
23 .D:NBR PRT^FHMTK1C
24 ;if ward, do specific ward/location;otherwise, do all entry for all
25 ;wards/locations and all communication offices.
26WARD I W1 S ^TMP($J,"W","01"_$P($G(^FH(119.6,+W1,0)),"^",1))=W1_"^"_$P($G(^FH(119.6,+W1,0)),"^",5,6)_"^"_$P($G(^FH(119.6,+W1,0)),"^",24)
27 E F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D
28 .S P0=$G(^FH(119.6,W1,0)),WRDN=$P(P0,"^",1),SP=$P(P0,"^",5,6),D2=$P(P0,"^",8),FHPAR=$P(P0,"^",24),P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
29 .I FHP,D2'=FHP Q
30 .S ^TMP($J,"W",P0_WRDN)=W1_"^"_SP_"^"_FHPAR Q
31 S NX="" F S NX=$O(^TMP($J,"W",NX)) Q:NX="" S X1=$G(^(NX)),W1=+X1,FHS=$P(X1,"^",2),SP1=$P(X1,"^",3),FHPAR=$P(X1,"^",4),WRDN=$E(NX,3,99) S:'FHS&(FHPAR="Y") FHS=SP1 I FHS K ^TMP($J,"D") D
32 .F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 D
33 ..D PATNAME^FHOMUTL Q:'$G(DFN)
34 ..S ADM=$G(^FHPT("AW",W1,FHDFN))
35 ..I SORT="A" S RM=$P($G(^DPT(DFN,0)),"^",1),DL=0,RMB=$G(^DPT(DFN,.101)) S:RMB="" RMB="***"
36 ..E S RI=$G(^DPT(DFN,.108)),RM=$G(^DPT(DFN,.101)) S:RM="" RM="***" S:RI RE=$O(^FH(119.6,"AR",+RI,W1,0)) S:'RI RE="" S DL=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:""),RMB=""
37 ..S DL=$S(DL<1:99,DL<10:"0"_DL,1:DL)
38 ..S ^TMP($J,"D",DL_"~"_RM_"~"_$S(SORT="R":DFN,1:RMB))=DFN_"^"_ADM_"^"_FHDFN Q
39 .;
40 .K ^TMP($J,"MP"),^TMP($J,0),MM,PP,S S X9="",NBR=0 F S X9=$O(^TMP($J,"D",X9)) Q:X9="" S FHX6=$G(^(X9)) S DFN=$P(FHX6,"^",1),ADM=$P(FHX6,"^",2) D
41 ..S FHDFN=$P(FHX6,"^",3)
42 ..S RM=$S(SORT="R":$P(X9,"~",2),1:$P(X9,"~",3)) S SP=FHS
43 ..I TPP D Q
44 ...I 'MFLG D BLD^FHDCR1D,UPD Q
45 ...F MEAL="B","N","E" D BLD^FHDCR1D
46 ...D UPD
47 ...Q
48 ..I 'TPP D BLD^FHDCR11 D UPD Q
49 .I NBR,TPP D PRT^FHMTK1C Q
50 .D:NBR PRT^FHDCR1C
51 ;
52OUTALL K ^TMP($J,"D") ;reset/clean-up tmp global outpatient process.
53 ;process outpatient data
54 ;next recurring
55 F FHK1=FHD1:0 S FHK1=$O(^FHPT("RM",FHK1)) Q:(FHK1'>0)!(FHK1>FHD2) D
56 .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHK1,FHDFN)) Q:FHDFN'>0 D
57 ..F FHKD=0:0 S FHKD=$O(^FHPT("RM",FHK1,FHDFN,FHKD)) Q:FHKD'>0 D
58 ...S FHKDAT=^FHPT(FHDFN,"OP",FHKD,0)
59 ...S (W1,FHW1)=$P(FHKDAT,U,3)
60 ...S FHRMB=$P(FHKDAT,U,18)
61 ...S FHDIET=$P(FHKDAT,U,2),FHMEAL=$P(FHKDAT,U,4),FHSTAT=$P(FHKDAT,U,15)
62 ...S:FHDIET="" FHDIET=$E(FHKDAT,7,11)
63 ...I (FHMEALSA'="A"),(FHMEAL'=FHMEALSA) Q
64 ...I FHSTAT="C" Q
65 ...I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
66 ...I $G(FHDFNSAV),(FHDFN'=FHDFNSAV) Q
67 ...S FHLOC="",FHRGS="OP"
68 ...Q:'$G(FHW1)
69 ...S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
70 ...I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
71 ...S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
72 ...I $G(FHW1SAV)!($G(FHFHPSAV)) D OUTW Q
73 ...I $G(FHDFNSAV) D OUTP Q
74 ...D OUTW
75 ;next guest
76 F FHKD=FHD1:0 S FHKD=$O(^FHPT("GM",FHKD)) Q:(FHKD'>0)!(FHKD>FHD2) D
77 .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHKD,FHDFN)) Q:FHDFN'>0 D
78 ..S FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
79 ..S (W1,FHW1)=$P(FHKDAT,U,5)
80 ..S FHSTAT=$P(FHKDAT,U,9)
81 ..Q:FHSTAT="C"
82 ..S FHRMB=$P(FHKDAT,U,11)
83 ..S FHDIET=$P(FHKDAT,U,6),FHMEAL=$P(FHKDAT,U,3)
84 ..I (FHMEALSA'="A"),(FHMEAL'=FHMEALSA) Q
85 ..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
86 ..I $G(FHDFNSAV),(FHDFN'=FHDFNSAV) Q
87 ..S FHLOC="",FHRGS="GM"
88 ..Q:'$G(FHW1)
89 ..S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
90 ..I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
91 ..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
92 ..I $G(FHW1SAV)!($G(FHFHPSAV)) D OUTW Q
93 ..I $G(FHDFNSAV) D OUTP Q
94 ..D OUTW
95 ;next SPECIAL
96 F FHKD=FHD1:0 S FHKD=$O(^FHPT("SM",FHKD)) Q:(FHKD'>0)!(FHKD>FHD2) D
97 .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHKD,FHDFN)) Q:FHDFN'>0 D
98 ..S FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
99 ..S (W1,FHW1)=$P(FHKDAT,U,3)
100 ..S FHRMB=$P(FHKDAT,U,13)
101 ..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
102 ..S FHDIET=$P(FHKDAT,U,4),FHMEAL=$P(FHKDAT,U,9),FHSTAT=$P(FHKDAT,U,2)
103 ..I (FHMEALSA'="A"),(FHMEAL'=FHMEALSA) Q
104 ..I (FHSTAT="C")!(FHSTAT="D") Q
105 ..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
106 ..I $G(FHDFNSAV),(FHDFN'=FHDFNSAV) Q
107 ..S FHLOC="",FHRGS="SM"
108 ..Q:'$G(FHW1)
109 ..S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
110 ..I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
111 ..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
112 ..I $G(FHW1SAV)!($G(FHFHPSAV)) D OUTW Q
113 ..I $G(FHDFNSAV) D OUTP Q
114 ..D OUTW
115 ;
116 K ^TMP($J,"MP"),^TMP($J,0),MM,PP,S S X9="",NBR=0 F S X9=$O(^TMP($J,"D",X9)) Q:X9="" S FHX6=$G(^(X9)) S FHDFN=$P(FHX6,"^",1),ADM=$P(FHX6,"^",2) D
117 .S RM=$S(SORT="R":$P(X9,"~",2),1:$P(X9,"~",3)) S SP=FHS
118 .S FHDFN=$P(FHX6,"^",1),FHRGS=$P(FHX6,"^",2)
119 .D PATNAME^FHOMUTL
120 .S FHKD=$P(FHX6,"^",3),W1=$P(FHX6,"^",4)
121 .Q:$G(FHRGS)!('$G(FHKD))
122 .S FHSTAT="",FHADM=FHKD
123 .S FHKDAT=$G(^FHPT(FHDFN,""_FHRGS_"",FHKD,0))
124 .I FHRGS="GM" S W1=$P(FHKDAT,U,5),FHDIET=$P(FHKDAT,U,6),FHMEAL=$P(FHKDAT,U,3)
125 .I FHRGS="OP" S W1=$P(FHKDAT,U,3),FHDIET=$P(FHKDAT,U,2),FHMEAL=$P(FHKDAT,U,4),FHSTAT=$P(FHKDAT,U,15)
126 .I FHRGS="SM" S W1=$P(FHKDAT,U,3),FHDIET=$P(FHKDAT,U,4),FHMEAL=$P(FHKDAT,U,9),FHSTAT=$P(FHKDAT,U,2)
127 .;don't process IF STATUS IS cancelled or denied
128 .I (FHSTAT="C")!(FHSTAT="D") Q
129 .S K1=$G(^FH(119.6,+W1,0)),WRDN=$P(K1,"^",1),SP=$P(K1,"^",5),SP1=$P(K1,"^",6),FHPAR=$P(K1,"^",24)
130 .I 'SP Q:FHPAR'="Y" S SP=SP1 Q:'SP
131 .I TPP D Q
132 ..I 'MFLG,'ADM D OUT^FHDCR1D,@FHRGS Q
133 ..F MEAL="B","N","E" D:'ADM OUT^FHDCR1D
134 ..D:'ADM @FHRGS
135 .I 'TPP,'ADM D OUT^FHDCR11 D @FHRGS Q
136 I NBR,TPP D PRT^FHMTK1C Q
137 D:NBR PRT^FHDCR1C
138 Q
139 ;
140UPD ; Update Date/Time Diet Card was Printed
141 S $P(^FHPT(FHDFN,"A",ADM,0),"^",16)=TIM Q
142OUTP ;process outpatient using patient
143 S RM="***"
144 S K1=$G(^FH(119.6,+W1,0)),WRDN=$P(K1,"^",1),SP=$P(K1,"^",5),SP1=$P(K1,"^",6),FHPAR=$P(K1,"^",24)
145 I 'SP Q:FHPAR'="Y" S SP=SP1 Q:'SP
146 K PP,S,MM S NBR=0,FHADM=FHKD I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S RM=$P(^DG(405.4,FHRMB,0),U,1)
147 I 'TPP D OUT^FHDCR11 D:NBR @FHRGS,PRT^FHDCR1C K ^TMP($J,"MP"),^TMP($J,0),PP,S,TT,SRT Q
148 I 'MFLG D OUT^FHDCR1D D:NBR @FHRGS,PRT^FHMTK1C Q
149 F MEAL="B","N","E" D OUT^FHDCR1D
150 D @FHRGS
151 D:NBR PRT^FHMTK1C
152 Q
153OP S $P(^FHPT(FHDFN,"OP",FHKD,0),"^",14)=TIM Q
154GM S $P(^FHPT(FHDFN,"GM",FHKD,0),"^",8)=TIM Q
155SM S $P(^FHPT(FHDFN,"SM",FHKD,0),"^",11)=TIM Q
156 ;
157OUTW ;process outpatient using all and ward.
158 ;F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 D
159 D PATNAME^FHOMUTL
160 S (RM,RMB)="***"
161 I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S RMB=$P(^DG(405.4,FHRMB,0),U,1)
162 I SORT="A" S RM=FHPTNM,DL=0
163 E S (RI,RE,DL)="***",RM=RMB
164 S ^TMP($J,"D",DL_"~"_RM_"~"_$S(SORT="R":FHDFN,1:RMB)_FHMEAL)=FHDFN_"^"_FHRGS_"^"_FHKD_"^"_W1
165 Q
Note: See TracBrowser for help on using the repository browser.