source: FOIAVistA/tag/r/DIETETICS-FH/FHNO5.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: 8.9 KB
Line 
1FHNO5 ; HISC/REL - Enter/Edit Supplemental Fdgs. ;7/27/94 14:45
2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
3 ;patch #5 - add SF to outpatient.
4 D NOW^%DTC S NOW=%
5ASK K DIC,X,DFN,FHDFN,FHPTNM,Y S (FHMEAL,ADM,FHIDFLG,FHPNNSV)="",FHALL=1 D ^FHOMDPA
6 G:'FHDFN KIL
7 S WARD="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1))
8 I WARD="" D SFOUT G ASK
9 K ADM
10A0 W !!,"Return for OUTPATIENT or 'C' for CURRENT Admission: " R X:DTIME G:X["^" KIL D:X="c" TR^FH
11 I (X="")&'($D(^FHPT(FHDFN,"OP"))) G ASK
12 I (X="") D SFOUT G ASK
13 I WARD'="",X="C" S ADM=$G(^DPT("CN",WARD,DFN)) G:$G(ADM) S0
14 S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
15 G:'$G(ADM) ASK
16 D S0
17 G ASK
18S0 D LIS^FHNO7 S PNO=Y
19SFA K DIC S FHNNSV="",DIC="^FH(118.1,",DIC(0)="EQM",OLD=$S('NM:"",1:$P(^FH(118.1,NM,0),"^",1))
20 W !!,"Supplemental Feeding Menu: " W:NM OLD," // " R X:DTIME
21 G KIL:'$T Q:X["^"
22 S FHNMSAV=NM
23 S FHXSAV=X
24 I X="" Q:'NM G S1
25 I X="@" D CAN W " .. cancelled" Q
26 D ^DIC K DIC G SFA:Y<1 S NM=+Y
27 S FHNMSAV=NM
28S1 Q:'NM
29 S KK=1,PNN="^"_NOW_"^"_DUZ_"^"_NM_"^"_$S(NM=1:$P(PNO,"^",5,29),1:^FH(118.1,NM,1))
30 I WARD="" D ;if outpatient, only allow SF for specific meal.
31 .S T1=$S(FHMEAL="B":"10am",FHMEAL="N":"2pm",1:"8pm")
32 .S KK=$S(FHMEAL="B":1,FHMEAL="N":5,1:9)
33 .S FHKK9=$S(FHMEAL="B":5,FHMEAL="N":14,1:23)
34 I NM=1,WARD="" D OIS^FHNO7,CAN S FHSFQT9=$P(FHPNNSV,"^",FHKK9,FHKK9+6),PNN=FHPNNSV G:"^^^^^^^^"'[FHSFQT9 ADD
35 I NM'=1 G UPD:$P(PNO,"^",4,29)=$P(PNN,"^",4,29) D CAN G ADD
36 S DIC="^FH(118,",DIC(0)="EQM",DIC("S")="I $P(^(0),U,3)'=""Y"""
37G1 G:KK>12 G5
38 I ((WARD="")&(FHMEAL="B")&(KK>4))!((WARD="")&(FHMEAL="N")&(KK>8)) G G5
39 I WARD'="" S T1=$P("10am^2pm^8pm","^",KK-1\4+1)
40 S T2="#"_(KK-1#4+1),P1=KK*2+3
41 S DIC("A")=T1_" Feeding "_T2_": "
42 S OLD=$P(PNN,"^",P1) I OLD S DIC("A")=DIC("A")_$P(^FH(118,+OLD,0),"^",1)_"// "
43G2 W !!,DIC("A") R X:DTIME G:'$T!(X["^") G5
44 I X="" G:OLD G3 S KK=$S(KK<5:5,KK<9:9,1:13) G G1
45 I OLD,X="@" S $P(PNN,"^",P1)="",$P(PNN,"^",P1+1)="" S KK=KK+1 G G1
46 D ^DIC G:Y<1 G2 S Y=+Y,K1=$S(KK<5:1,KK<9:5,1:9)
47 F L=K1:1:K1+3 I L'=KK,$P(PNN,"^",L*2+3)=Y W *7," .. DUPLICATE OF EXISTING ITEM!" G G2
48 S:OLD'=Y $P(PNN,"^",P1)=Y
49G3 S OLD=$P(PNN,"^",P1+1)
50G4 W !,T1," ",T2," Qty: ",$S(OLD="":1,1:OLD),"// " R X:DTIME G:'$T!(X["^") G5
51 S:X="@" X=0 I X="" S:OLD="" $P(PNN,"^",P1+1)=1 S KK=KK+1 G G1
52 I X'?1N.N!(X>20) W *7," ??" S X="?"
53 I X["?" W !?5,"Enter a whole number between 1 and 20" G G4
54 I 'X S $P(PNN,"^",P1)="",$P(PNN,"^",P1+1)="" S KK=KK+1 G G1
55 S $P(PNN,"^",P1+1)=X,KK=KK+1 G G1
56G5 S KK=3,X="" F T1=0:1:2 S P1=T1*8-1 F T2=1:1:4 S KK=KK+2 I $P(PNN,"^",KK) S P1=P1+2,$P(X,"^",P1,P1+1)=$P(PNN,"^",KK,KK+1)
57 I X="" D CAN Q
58G6 Q:WARD=""
59 S P1=$P(PNN,"^",29) S:P1="" P1="D" W !!,"Dietary or Therapeutic? ",P1,"// " R Y:DTIME S:'$T!("^"[Y) Y=P1
60 S:$P("dietary",Y,1)="" Y="D" S:$P("therapeutic",Y,1)="" Y="T"
61 I $P("DIETARY",Y,1)'="",$P("THERAPEUTIC",Y,1)'="" W *7,!?5," Answer D for Dietary use or T for Therapeutic use" G G6
62 S $P(X,"^",25)=$E(Y,1),PNN=$P(PNN,"^",1,4)_"^"_X
63 G:$P(PNO,"^",5,29)=X UPD D CAN
64ADD ; Add SF
65 Q:'$D(WARD)
66 I WARD="" G ADDOUT
67 L +^FHPT(FHDFN,"A",ADM,"SF",0)
68 I '$D(^FHPT(FHDFN,"A",ADM,"SF",0)) S ^FHPT(FHDFN,"A",ADM,"SF",0)="^115.07^^"
69 S X=^FHPT(FHDFN,"A",ADM,"SF",0),NO=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_NO_"^"_($P(X,"^",4)+1)
70 L -^FHPT(FHDFN,"A",ADM,"SF",0) I $D(^FHPT(FHDFN,"A",ADM,"SF",NO)) G ADD
71 S ^FHPT(FHDFN,"A",ADM,"SF",NO,0)=NO_"^"_$P(PNN,"^",2,99)
72 S $P(^FHPT(FHDFN,"A",ADM,0),"^",7)=NO
73 I NO'="" S EVT="F^O^"_NO D ^FHORX
74UPD Q:'$D(WARD) I WARD="" G UPDOUT
75 S:NO $P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
76 Q
77CAN ; Cancel SF
78 Q:'$D(WARD)
79 I WARD="" G CANOUT
80 S NO=$P(^FHPT(FHDFN,"A",ADM,0),"^",7),$P(^(0),"^",7)=""
81 S:NO $P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",32,33)=NOW_"^"_DUZ
82 I NO'="" S EVT="F^C^"_NO D ^FHORX
83 Q
84SFOUT ;outpt SF
85 K FHSFLG,FHNMSAV,FHXSAV,X,OLD,FHLOC,FHLOCN
86 D SF^FHNO7
87 I '$G(FHSFLG) W !,"NO OUTPATIENT DATA ON FILE for today's date and the future!!" Q
88 D ASK0
89 Q
90ASK0 ;ask Rec Meal
91 K FHDM14,FHFLG,FHCK,FHDMIEN,FHIEN
92 S (FHTOTML("B"),FHTOTML("N"),FHTOTML("E"),FHTOTML("A"))=0
93 F FHI=DT-1:0 S FHI=$O(^FHPT("RM",FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(^FHPT("RM",FHI,FHDFN,FHJ)) Q:FHJ'>0 D
94 .S FHOPDAT=$G(^FHPT(FHDFN,"OP",FHJ,0))
95 .Q:$P(FHOPDAT,U,15)="C"
96 .S FHML=$P(FHOPDAT,U,4)
97 .S FHN=0
98 .S:FHML="B" FHN=1
99 .S:FHML="N" FHN=2
100 .S:FHML="E" FHN=3
101 .S FHDM14(FHI,FHN,FHML)=FHI_U_FHJ
102 F FHI=0:0 S FHI=$O(FHDM14(FHI)) Q:FHI'>0 D
103 .F FHN=1,2,3 Q:FHN="" F FHJ="B","N","E" Q:FHJ="" D
104 ..I (FHJ="B")&$D(FHDM14(FHI,FHN,FHJ)) S FHTOTML("B")=FHTOTML("B")+1,(FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
105 ..I (FHJ="N")&$D(FHDM14(FHI,FHN,FHJ)) S FHTOTML("N")=FHTOTML("N")+1,(FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
106 ..I (FHJ="E")&$D(FHDM14(FHI,FHN,FHJ)) S FHTOTML("E")=FHTOTML("E")+1,(FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
107 Q:'$D(FHDM14)
108R1 S (FHCNSFF,FHADSFF)=0,(FHLOCN,FHSFMEN)="",(FH1,FHQ,FHDTC)=0,(FHDTML,FHX)="" R !!,"Enter a Meal (B,N,E or ALL): ALL// ",FHDTML:DTIME
109 Q:'$T!(FHDTML["^")
110 S:FHDTML="" FHDTML="ALL"
111 I FHDTML["?" S FHQ=1 G MS1
112 S X=FHDTML D TR^FH S (FHX,FHDTML)=X
113 I FHDTML="A" S FHQ=1 G MS1
114 S FHALML=FHX
115 I FHDTML="ALL" S FHDTML=$E(FHDTML,1),FHALML="BNE"
116 I $L(FHDTML)=3 S:("BNE")'[$E(FHDTML,1) FHQ=1 S:("BNE")'[$E(FHDTML,2) FHQ=1 S:("BNE")'[$E(FHDTML,3) FHQ=1 S FHCK($E(FHDTML,1))="",FHCK($E(FHDTML,2))="",FHCK($E(FHDTML,3))=""
117 I $L(FHDTML)=2 S:("BNE")'[$E(FHDTML,1) FHQ=1 S:("BNE")'[$E(FHDTML,2) FHQ=1 S FHCK($E(FHDTML,1))="",FHCK($E(FHDTML,2))=""
118 I $L(FHDTML)=1 S:("ABNE")'[$E(FHDTML,1) FHQ=1 S FHCK(FHDTML)=""
119 I FHDTML="A" S (FHCK("B"),FHCK("N"),FHCK("E"))=""
120 S:$L(FHDTML)>3 FHQ=1
121 G:FHQ MS1
122 I $L(FHDTML)=3 S:'$G(FHTOTML($E(FHDTML,1))) FH1=1 S:'$G(FHTOTML($E(FHDTML,2))) FH1=1 S:'$G(FHTOTML($E(FHDTML,3))) FH1=1 I FH1 W !!,"There is no outpatient data for this Meal!!" G R1
123 I $L(FHDTML)=2 S:'$G(FHTOTML($E(FHDTML,1))) FH1=1 S:'$G(FHTOTML($E(FHDTML,2))) FH1=1 I FH1 W !!,"There is no outpatient data for this Meal!!" G R1
124MS1 I FHQ W *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals",!,"Answer may be multiple meals, e.g., BN or NE" G R1
125 S:$L(FHDTML)>1 FHDTML="A"
126 S (FHFLG,FHLIS)=0
127 I (FHDTML'="A"),(FHTOTML(FHDTML)'>0) W !!,"There is no outpatient data for this Meal!!" G R1
128 I FHDTML'="A",(FHTOTML(FHDTML)=1) F FHI=DT-1:0 S FHI=$O(FHDMIEN(FHI)) G:FHI'>0 EVNT I $D(FHDMIEN(FHI,FHDTML)) S FHDMDAT=FHDMIEN(FHI,FHDTML) D PR1
129 I FHDTML'="A",(FHTOTML(FHDTML)>1) D CHK^FHSPED
130 I 'FHFLG,FHDTML="A" G ALL
131 I $G(FHFLG) F FHI=FHDT1-1:0 S FHI=$O(FHDM14(FHI)) G:(FHI'>0)!(FHI>FHDT2) EVNT F FHN=1,2,3 Q:FHN="" I $D(FHDM14(FHI,FHN,FHDTML)) S FHDMDAT=FHDM14(FHI,FHN,FHDTML) D PR1
132 Q
133ALL S FHCT=0,(FHDT1,FHDT2,FHDTSV)=DT
134 F FHI=DT-1:0 S FHI=$O(FHDM14(FHI)) S:'FHI FHDT2=FHDTSV Q:FHI'>0 S FHCT=FHCT+1,FHDTSV=FHI S:FHCT=1 FHDT1=FHI F FHN=1,2,3 Q:FHN="" D
135 .S FHJ="" F S FHJ=$O(FHDM14(FHI,FHN,FHJ)) Q:FHJ="" I $D(FHDM14(FHI,FHN,FHJ)) S FHDMDAT=FHDM14(FHI,FHN,FHJ) D PR1
136 ;
137EVNT S:'$D(FHDTP) FHDTP=""
138 I $D(FHDT1) S DTP=FHDT1 D DTP^FH S FHDTP=DTP
139 I $D(FHDT2) S DTP=FHDT2 D DTP^FH S:FHDTP'=DTP FHDTP=FHDTP_" to "_DTP
140 I FHCNSFF=1 S FHACT="C",FHTXT="Outpatient Supplemental Feeding: ("_FHALML_") , "_FHLOCN_", Cancelled "_FHDTP D OPFILE^FHORX
141 I FHADSFF=1 S FHACT="O",FHTXT="Outpatient Supplemental Feeding: "_FHSFMEN_" ("_FHALML_") , "_FHLOCN_", "_FHDTP D OPFILE^FHORX
142 Q
143PR1 S FHDTE=$P(FHDMDAT,U,1),ADM=$P(FHDMDAT,U,2)
144 I '$G(^FHPT(FHDFN,"OP",ADM,0)) Q
145 S FHDTC=FHDTC+1,DTP=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,1) D DTP^FH S:FHDTC=1 FHDTP=DTP
146 S FHMEAL=$P(^FHPT(FHDFN,"OP",ADM,0),U,4)
147 I $G(FHIDFLG) D CAN S PNN=FHPNNSV,FHKK9=$S(FHMEAL="B":5,FHMEAL="N":14,1:23) S FHSFQT9=$P(FHPNNSV,"^",FHKK9,FHKK9+6) G:"^^^^^^^^"'[FHSFQT9 ADD Q
148 S (PNO,WARD,FHLOCN,FHSFMEN)=""
149 S FHLOC=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,3) S:$G(FHLOC) FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1)
150 I $D(FHXSAV),FHXSAV="@" D CAN W !," .. cancelled" Q
151 I $D(X),X="^" Q
152 I $D(FHNMSAV),FHNMSAV'="" D S1 Q
153 D CAD
154 D LIS^FHNO7 S PNO=Y
155 I $G(FHLIS),$G(NO) S PNO=^FHPT(FHDFN,"OP",ADM,"SF",NO,0)
156 I '$G(FHLIS) D SFA S FHLIS=FHLIS+1 Q
157 I $G(FHLIS) S NM=FHNMSAV D S1
158 Q
159CAD ;
160 S FHCFLG=""
161 S NO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3)
162 I NO S FHCFLG=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",NO,0)),"^",32)
163 Q
164ADDOUT ; Add outpt SF
165 S FHMEAL=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,4),FHSFMEN=""
166 L +^FHPT(FHDFN,"OP",ADM,"SF",0)
167 I '$D(^FHPT(FHDFN,"OP",ADM,"SF",0)) S ^FHPT(FHDFN,"OP",ADM,"SF",0)="^115.1627^^"
168 S X=^FHPT(FHDFN,"OP",ADM,"SF",0),NO=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_NO_"^"_($P(X,"^",4)+1)
169 L -^FHPT(FHDFN,"OP",ADM,"SF",0) I $D(^FHPT(FHDFN,"OP",ADM,"SF",NO)) G ADDOUT
170 I FHMEAL="B" S $P(PNN,U,13,20)="^^^^^^^",$P(PNN,U,21,28)="^^^^^^^"
171 I FHMEAL="N" S $P(PNN,U,5,12)="^^^^^^^",$P(PNN,U,21,28)="^^^^^^^"
172 I FHMEAL="E" S $P(PNN,U,5,12)="^^^^^^^",$P(PNN,U,13,20)="^^^^^^^"
173 S ^FHPT(FHDFN,"OP",ADM,"SF",NO,0)=NO_"^"_$P(PNN,"^",2,99)
174 S:$G(FHNMSAV) FHSFMEN=$P($G(^FH(118.1,FHNMSAV,0)),U,1)
175 S FHADSFF=1
176UPDOUT S:NO $P(^FHPT(FHDFN,"OP",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
177 Q
178CANOUT ; Cancel outpt SF
179 S NO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3)
180 S:NO $P(^FHPT(FHDFN,"OP",ADM,"SF",NO,0),"^",32,33)=NOW_"^"_DUZ
181 S FHCNSFF=1
182 Q
183KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.