source: FOIAVistA/trunk/r/DIETETICS-FH/FHORD13.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1FHORD13 ; HISC/REL/NCA/RVD - Reprint Diet Label ;2/26/96 11:57
2 ;;5.5;DIETETICS;**1,5,8**;Jan 28, 2005;Build 28
3 W @IOF,!!?21,"R E P R I N T D I E T L A B E L S"
4F0 R !!,"Reprint by COMMUNICATION OFFICE, PATIENT, LOCATION or ALL? PATIENT// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="P" D TR^FH
5 I $P("COMMUNICATION OFFICE",X,1)'="",$P("PATIENT",X,1)'="",$P("LOCATION",X,1)'="",$P("ALL",X,1)'="" W *7,!!," Answer with C, L, P or A" G F0
6 S FHPR=$E(X,1),ALL=0,(FHX1,FHX2)="" G P0:FHPR?1"P",D2:FHPR?1"C",P1:FHPR?1"A"
7W0 K DIC S DIC("A")="Select LOCATION: ",DIC="^FH(119.6,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),W0:Y<1 S FHX1=-Y G P1
8D2 K DIC S DIC("A")="Select COMMUNICATION OFFICE: ",DIC="^FH(119.73,",DIC(0)="AEMQ" W ! D ^DIC G KIL:"^"[X!$D(DTOUT),D2:Y<1 S FHX1=-Y G P1
9P0 S FHALL=1 D ^FHOMDPA I '$G(FHDFN),FHX1'="" G P1
10 Q:'FHDFN
11 S ADM="*"
12 I 'DFN,$G(FHDFN) G PPT
13 I $D(^DPT(DFN,.1)) S WARD=$G(^DPT(DFN,.1)) D
14 .I $G(^DPT("CN",WARD,DFN)) S ADM=$G(^DPT("CN",WARD,DFN))
15PPT S FHX1=$G(FHX1)_FHDFN_"^",FHX2=$G(FHX2)_ADM_"^" I $L(FHX1)<231,$L(FHX2)<231 G P0
16 G:FHX1="" KIL
17P1 ;
18 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
19 Q:$D(DIRUT) S LABSTART=Y
20 W ! K IOP,%ZIS S %ZIS("A")="Select LABEL Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
21 I $D(IO("Q")) S FHPGM="Q1^FHORD13",FHLST="FHX1^FHX2^FHPR^LABSTART" D EN2^FH G KIL
22 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
23Q1 ; Reprint the Diet Labels
24 S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 S S2=LAB=2*5+36 D NOW^%DTC S NOW=%
25 S COUNT=0,LINE=1
26 S DTP=NOW D DTP^FH,^FHDEV G:FHX1>0 Q2
27 S WRD=-FHX1 K ^TMP($J)
28 F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=^(K1,0) D F1
29 S RM="" F S RM=$O(^TMP($J,"DL",RM)) Q:RM="" F DFN=0:0 S DFN=$O(^TMP($J,"DL",RM,DFN)) Q:DFN<1 S ADM=^(DFN) S FHZ115="P"_DFN D CHECK^FHOMDPA Q:FHDFN="" D:ADM LST
30 ;process outpatient
31 D OUTP
32 D PROUT
33 I LAB>2 D DPLL^FHLABEL G KIL
34 I LAB<3 F K7=1:1:18 W !
35 G KIL
36 ;
37F1 I FHPR="C" S KK=$P(X,"^",8) I WRD,KK'=WRD Q
38 I FHPR="L" S KK=$P(X,"^",1) I WRD,K1'=WRD Q
39 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
40 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",K1,FHDFN)) Q:FHDFN<1 D
41 .D PATNAME^FHOMUTL Q:DFN=""
42 .S ADM=$G(^FHPT("AW",K1,FHDFN))
43 .S RM=$G(^DPT(DFN,.101))
44 .S:RM="" RM="***"
45 .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,K1,0)),1:"")
46 .S R0=$S(RE:$P($G(^FH(119.6,K1,"R",+RE,0)),"^",2),1:"")
47 .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
48 .S ^TMP($J,"DL",P0_"~"_R0_"~"_RM,DFN)=ADM Q
49 Q
50 ;
51Q2 F K7=1:1 S FHDFN=$P(FHX1,"^",K7) Q:FHDFN<1 D PATNAME^FHOMUTL S ADM=$P(FHX2,"^",K7) D:$G(ADM) LST I '$G(ADM) S FHDFNSAV(FHDFN)=FHDFN
52 ;process outpatient
53 D OUTP
54 D PROUT
55 I LAB>2 D DPLL^FHLABEL G KIL
56Q3 I LAB<3 F K7=1:1:18 W !
57 G KIL
58 ;
59LST ;
60 Q:'$D(^FHPT(FHDFN,"A",ADM,0)) S X0=^(0)
61 S FHORD=$P(X0,"^",2),X1=$P(X0,"^",5) Q:FHORD<1
62 S W1=$P(X0,"^",8),W1=$P($G(^FH(119.6,+W1,0)),"^",1),R1=$G(^DPT(DFN,.101))
63 Q:'$D(^DPT(DFN,0)) S Y0=^(0) D PID^FHDPA
64 S W1=$E(W1,1,15),N1=$E($P(Y0,"^",1),1,22)
65 S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
66 S (Y,X1)="" G:X="" L1 S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7)
67 I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") G:%<1 L1 S Y=$P($E(FHDU,%,999),";",1) G L1
68 F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
69 S IS=$P(X0,"^",10),X1=$P(X,"^",8) I IS S IS=^FH(119.4,IS,0),X1=X1_"-"_$P(IS,"^",2)_$P(IS,"^",3)
70 ;
71L1 S ALG="" D ALG^FHCLN
72 I LAB>2 D LL Q
73 W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W @FHIO("EON") W ?(S2-3\2),X1 W @FHIO("EOF") W ?(S2-3-$L(R1)),R1 W @FHIO("EON") I $L(Y)<S2 W:LAB=2 ! W !,$S(ALG="":"",1:"*ALG"),!,Y,!!
74 E S L=$S($L($P(Y,",",1,3))<S2:3,1:2) W !!,$P(Y,",",1,L) W:LAB=2 ! W !,$E($P(Y,",",L+1,5),2,99),!
75 W @FHIO("EOF") W:LAB=2 ?(S2-20),DTP,!! Q
76 ;
77OUTP ;process outpatient dat
78 S (R1,FHW1SAV,FHFHPSAV)=""
79 I FHPR="L" S FHW1SAV=-FHX1
80 I FHPR="C" S FHFHPSAV=-FHX1
81 S FHD1=DT-.00001,FHD2=DT+.99999
82 ;next recurring
83 F FHK1=FHD1:0 S FHK1=$O(^FHPT("RM",FHK1)) Q:(FHK1'>0)!(FHK1>FHD2) D
84 .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHK1,FHDFN)) Q:FHDFN'>0 D
85 ..F FHKD=0:0 S FHKD=$O(^FHPT("RM",FHK1,FHDFN,FHKD)) Q:FHKD'>0 D
86 ...S FHKDAT=^FHPT(FHDFN,"OP",FHKD,0)
87 ...S (W1,FHW1)=$P(FHKDAT,U,3)
88 ...S FHDIET=$P(FHKDAT,U,2),FHMEAL=$P(FHKDAT,U,4),FHSTAT=$P(FHKDAT,U,15)
89 ...I FHSTAT="C" Q
90 ...S FHDIET1=$P(FHKDAT,U,7)
91 ...S FHDIET2=$P(FHKDAT,U,8)
92 ...S FHDIET3=$P(FHKDAT,U,9)
93 ...S FHDIET4=$P(FHKDAT,U,10)
94 ...S FHDIET5=$P(FHKDAT,U,11)
95 ...I FHPR="P",'$D(FHDFNSAV(FHDFN)) Q
96 ...I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
97 ...I $D(FHDFNSAV(FHDFN)),(FHDFN'=FHDFNSAV(FHDFN)) Q
98 ...S FHLOC="",FHRGS="OP"
99 ...S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
100 ...I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
101 ...S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
102 ...S FHRMB=$P(FHKDAT,U,18)
103 ...D OUTW
104 ;next guest
105 K FHDIET1,FHDIET2,FHDIET3,FHDIET4,FHDIET5
106 F FHKD=FHD1:0 S FHKD=$O(^FHPT("GM",FHKD)) Q:(FHKD'>0)!(FHKD>FHD2) D
107 .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHKD,FHDFN)) Q:FHDFN'>0 D
108 ..I FHPR="P",'$D(FHDFNSAV(FHDFN)) Q
109 ..S FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
110 ..I $P(FHKDAT,U,9)="C" Q
111 ..S (W1,FHW1)=$P(FHKDAT,U,5)
112 ..S FHDIET=$P(FHKDAT,U,6),FHMEAL=$P(FHKDAT,U,3)
113 ..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
114 ..I $D(FHDFNSAV(FHDFN)),(FHDFN'=FHDFNSAV(FHDFN)) Q
115 ..S FHLOC=""
116 ..S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
117 ..I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
118 ..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
119 ..S FHRMB=$P(FHKDAT,U,11)
120 ..D OUTW
121 ;next SPECIAL
122 F FHKD=FHD1:0 S FHKD=$O(^FHPT("SM",FHKD)) Q:(FHKD'>0)!(FHKD>FHD2) D
123 .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHKD,FHDFN)) Q:FHDFN'>0 D
124 ..I FHPR="P",'$D(FHDFNSAV(FHDFN)) Q
125 ..S FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
126 ..S (W1,FHW1)=$P(FHKDAT,U,3)
127 ..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
128 ..S FHDIET=$P(FHKDAT,U,4),FHMEAL=$P(FHKDAT,U,9),FHSTAT=$P(FHKDAT,U,2)
129 ..I (FHSTAT="C")!(FHSTAT="D") Q
130 ..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
131 ..I $D(FHDFNSAV(FHDFN)),(FHDFN'=FHDFNSAV(FHDFN)) Q
132 ..S FHLOC=""
133 ..S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
134 ..I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
135 ..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
136 ..S FHRMB=$P(FHKDAT,U,13)
137 ..D OUTW
138 Q
139 ;
140OUTW ;set all outpt data for printing
141 D PATNAME^FHOMUTL
142 S FHTC=""
143 Q:'$D(^FH(119.6,FHW1,0))
144 S P0=$P(^FH(119.6,FHW1,0),U,4)
145 S P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
146 S FHW1N=$P(^FH(119.6,FHW1,0),U,1)
147 S FHTC5=$P(^FH(119.6,FHW1,0),U,5)
148 S FHTC6=$P(^FH(119.6,FHW1,0),U,6)
149 I $G(FHTC5),$D(^FH(119.72,FHTC5,0)) S FHTC=FHTC_$P(^FH(119.72,FHTC5,0),U,2)
150 I $G(FHTC6),$D(^FH(119.72,FHTC6,0)) S FHTC=FHTC_$P(^FH(119.72,FHTC6,0),U,2)
151 S:$G(FHDIET) FHDIET=$P(^FH(111,FHDIET,0),U,7)
152 I $G(FHDIET1) S FHDIET1=$P(^FH(111,FHDIET1,0),U,7) D
153 .I FHDIET="" S FHDIET=FHDIET_FHDIET1 Q
154 .I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET1
155 I $G(FHDIET2) S FHDIET2=$P(^FH(111,FHDIET2,0),U,7) D
156 .I FHDIET="" S FHDIET=FHDIET_FHDIET2 Q
157 .I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET2
158 I $G(FHDIET3) S FHDIET3=$P(^FH(111,FHDIET3,0),U,7) D
159 .I FHDIET="" S FHDIET=FHDIET_FHDIET3 Q
160 .I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET3
161 I $G(FHDIET4) S FHDIET4=$P(^FH(111,FHDIET4,0),U,7) D
162 .I FHDIET="" S FHDIET=FHDIET_FHDIET4 Q
163 .I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET4
164 I $G(FHDIET5) S FHDIET5=$P(^FH(111,FHDIET5,0),U,7) D
165 .I FHDIET="" S FHDIET=FHDIET_FHDIET5 Q
166 .I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET5
167 S FHRM=""
168 I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S FHRM=$P(^DG(405.4,FHRMB,0),U,1)
169 S:FHRM'="" FHRM=$E(FHRM,1,12)
170 S ^TMP($J,"OUT",P0_"~"_$E(FHW1N,1,20)_"~"_$E(FHPTNM,1,26),FHDFN)=FHPTNM_"^"_FHW1N_"^"_FHBID_"^"_FHDIET_"^"_FHTC_"^"_FHRM
171 Q
172 ;
173PROUT ;print outptlabels
174 S (X1,RM)=""
175 F S RM=$O(^TMP($J,"OUT",RM)) Q:RM="" D
176 .F FHDFN=0:0 S FHDFN=$O(^TMP($J,"OUT",RM,FHDFN)) Q:FHDFN'>0 D
177 ..S FHOU=^TMP($J,"OUT",RM,FHDFN)
178 ..S N1=$P(FHOU,U,1)
179 ..S W1=$E($P(FHOU,U,2),1,12)
180 ..S BID=$P(FHOU,U,3)
181 ..S (Y,FHDIET)=$P(FHOU,U,4)
182 ..S X1=$P(FHOU,U,5)
183 ..S R1=$P(FHOU,U,6)
184 ..D L1
185 Q
186 ;
187KIL K ^TMP($J) G KILL^XUSCLEAN
188 Q
189LL D LAB^FHLABEL Q
Note: See TracBrowser for help on using the repository browser.