source: FOIAVistA/trunk/r/DIETETICS-FH/FHSPED.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 9.4 KB
Line 
1FHSPED ; HISC/REL/NCA - Enter/Cancel Standing Orders ;7/22/94 13:59
2 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
3EN1 ; Enter Standing Orders for Patient
4 D NOW^%DTC S NOW=%
5ASK K DIC,X,DFN,FHDFN,FHPTNM,Y S ADM="",FHALL=1 D ^FHOMDPA
6 G:'FHDFN KIL
7 S WARD="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1))
8 I WARD="" W !!,"** NO CURRENT ADMISSION ON FILE! If this is an Inpatient, please admit the patient first.",! D SO^FHSP 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"))) W !!,"** NO OUTPATIENT DATA ON FILE! Please enter outpatient meals from Recurring Meals Menu [FHOMRMGR]!!" G ASK
12 I (X="") D SO^FHSP G ASK
13 I WARD'="",X="C" S ADM=$G(^DPT("CN",WARD,DFN)) G CAD:ADM
14 S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
15CAD I ADM,$G(^FHPT(FHDFN,"A",ADM,0)) S (SDT,STDT)=$P(^FHPT(FHDFN,"A",ADM,0),U,1),ENDT=DT G E1:SDT
16 ;
17E1 W ! S NO=1 D LIS G:'$G(LN) N1
18 K DIR W ! S DIR(0)="YA",DIR("A")="Edit a Standing Order? ",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT)!$D(DIROUT) EN1 G:Y<1 N1
19N0 R !!,"Edit which Order #? ",X:DTIME G:'$T!("^"[X) EN1 I X'?1N.N!(X<1)!(X>LN) W *7," Enter # of Order to Edit" G N0
20 S SP=$P(LS,",",+X),SP=$P($G(^FHPT(FHDFN,"A",ADM,"SP",+SP,0)),"^",2) I $D(P(+X,SP)) S LN=+X G N1A
21 W !!,"Standing Order ",$P($G(^FH(118.3,+SP,0)),"^",1)," added" S LN=LN+1,P(LN,SP)="" G N1A
22N1 K DIC W ! S DIC="^FH(118.3,",DIC("A")="Enter Standing Order: ",DIC(0)="AEQM"
23 D ^DIC K DIC,DLAYGO G EN1:"^"[X!$D(DTOUT),N1:Y<1 S SP=+Y
24 W !!,"Standing Order ",$P($G(^FH(118.3,+SP,0)),"^",1)," added"
25 S LN=LN+1,P(LN,SP)=""
26N1A W !,"Standing Order: ",$P($G(^FH(118.3,+SP,0)),"^",1)_" // " R X:DTIME G KIL:'$T,FHSPED:X="^"
27 I X="@" D EN3 W " .. Done" G E1
28 I X'="" W *7,!,"Press Return to take Default or ""@"" to Delete" G N1A
29 S $P(P(LN,SP),"^",5)=SP
30N2 W !,"Select Meal (B,N,E or ALL): ",$S($P(P(LN,SP),"^",3)'="":$P(P(LN,SP),"^",3)_" // ",1:"") R MEAL:DTIME G:'$T!(MEAL="^") KIL
31 I MEAL="" G:$P(P(LN,SP),"^",3)="" KIL S MEAL=$P(P(LN,SP),"^",3),$P(P(LN,SP),"^",6)=MEAL G N2A
32 I MEAL="@" S $P(P(LN,SP),"^",3)="" G N2
33 S X=MEAL D TR^FH S MEAL=X S:$P("ALL",MEAL,1)="" MEAL="BNE" S X=MEAL,MEAL="" S:X["B" MEAL="B" S:X["N" MEAL=MEAL_"N" S:X["E" MEAL=MEAL_"E"
34 I $L(X)'=$L(MEAL) 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 N2
35 S $P(P(LN,SP),"^",6)=MEAL
36N2A W !,"Quantity: ",$S($P(P(LN,SP),"^",4):$P(P(LN,SP),"^",4)_"// ",1:"1// ") R NUM:DTIME S:NUM="" NUM=$S($P(P(LN,SP),"^",4):$P(P(LN,SP),"^",4),1:1) G:'$T!(NUM="^") KIL
37 I NUM="@" S $P(P(LN,SP),"^",4)="" G N2A
38 I NUM'?1N!(NUM<1) W !,*7,"Enter a number from 1-9." G N2A
39 S $P(P(LN,SP),"^",7)=NUM
40 S C1=$P(P(LN,SP),"^",2,4),C2=$P(P(LN,SP),"^",5,7) G:C1=C2 E1
41N3 W !!,"ADD this Order? Y// " R YN:DTIME G:'$T!(YN="^") KIL S:YN="" YN="Y" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G N3
42 G:YN?1"N".E E1
43 I C1'="^^" S OLD=$P(P(LN,SP),"^",1),$P(^FHPT(FHDFN,"A",ADM,"SP",OLD,0),"^",6,7)=NOW_"^"_DUZ K ^FHPT("ASP",FHDFN,ADM,OLD) S EVT="S^C^"_OLD D ^FHORX
44 S $P(P(LN,SP),"^",2,4)="^^",$P(P(LN,SP),"^",2,4)=$P(P(LN,SP),"^",5,7),$P(P(LN,SP),"^",5,7)="^^"
45ADD ; Add Standing Order
46 L +^FHPT(FHDFN,"A",ADM,"SP",0)
47 I '$D(^FHPT(FHDFN,"A",ADM,"SP",0)) S ^FHPT(FHDFN,"A",ADM,"SP",0)="^115.08^^"
48 S X=^FHPT(FHDFN,"A",ADM,"SP",0),NO=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_NO_"^"_($P(X,"^",4)+1)
49 L -^FHPT(FHDFN,"A",ADM,"SP",0) I $D(^FHPT(FHDFN,"A",ADM,"SP",NO)) G ADD
50 S ^FHPT(FHDFN,"A",ADM,"SP",NO,0)=NO_"^"_SP_"^"_MEAL_"^"_NOW_"^"_DUZ_"^^^"_NUM,^FHPT("ASP",FHDFN,ADM,NO)="",LS=LS_NO_","
51 S $P(P(LN,SP),"^",1)=NO,EVT="S^O^"_NO D ^FHORX W " .. done" G E1
52EN2 ; Standing Order Inquiry
53 K DIC,X,DFN,FHDFN,FHPTNM S ADM="",FHALL=1 D ^FHOMDPA
54 ;S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL S NO=0 D LIS G EN2
55 S (FHSOFG,WARD)="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1))
56 G:'FHDFN KIL S NO=0 D:$G(DFN) LIS
57 I $D(^FHPT("ASPO",FHDFN)) D OUT,LIS^FHSP
58 G EN2
59EN3 ; Cancel Standing Order
60 S NO=$P($G(P(LN,SP)),"^",1) Q:'NO
61 S $P(^FHPT(FHDFN,"A",ADM,"SP",NO,0),"^",6,7)=NOW_"^"_DUZ
62 S X=^FHPT(FHDFN,"A",ADM,"SP",NO,0),SP=$P(X,"^",2),MEAL=$P(X,"^",3),NUM=""
63 K ^FHPT("ASP",FHDFN,ADM,NO),P(LN,SP) S EVT="S^C^"_NO D ^FHORX Q
64LIS ;list SO
65 Q:WARD=""
66 S NAM=$P(^DPT(DFN,0),"^",1) D CUR^FHORD7
67 W !!,NAM," " W:WARD'="" "( ",WARD," )"
68 W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
69 D ALG^FHCLN W !," Allergies: ",$S(ALG="":"None on file",1:ALG)
70 K N,P S CTR=0
71 F K=0:0 S K=$O(^FHPT("ASP",FHDFN,ADM,K)) Q:K<1 S X=^FHPT(FHDFN,"A",ADM,"SP",K,0),M=$P(X,"^",3),M=$S(M="BNE":"A",1:$E(M,1)),N(M,K)=$P(X,"^",2,3)_"^"_$P(X,"^",8,9)
72 S FHSOFG=1
73 S LN=0,LS="" I $O(N(""))="" W !!,"No Active Inpatient Standing Orders." Q
74 W !!,"Active Inpatient Standing Orders: ",!
75 F M="A","B","N","E" D
76 .F K=0:0 S K=$O(N(M,K)) Q:K<1 S Z=+N(M,K) I Z D
77 ..S LN=LN+1,LS=LS_K_"," D L1 W ! W:NO $J(LN,2)
78 ..S NUM=$P(N(M,K),"^",3)
79 ..W ?5,M2,?18,$S(NUM:NUM,1:1)," ",$P(^FH(118.3,Z,0),"^",1)_$S($P(N(M,K),"^",4)'="Y":" (I)",1:"") I $G(^FH(118.3,Z,"I"))="Y" W " (** INACTIVE **)"
80 ..S P(LN,+Z)=K_"^"_$P(N(M,K),"^",1,3) Q
81 .Q
82 Q
83L1 ; Store Standing Order By Meal
84 S M1=$P(N(M,K),"^",2) I M1="BNE" S M2="All Meals" Q
85 S L=$E(M1,1),M2=$S(L="B":"Break",L="N":"Noon",1:"Even")
86 S L=$E(M1,2) Q:L="" S M2=M2_","_$S(L="B":"Break",L="N":"Noon",1:"Even") Q
87OUT ;ask for Recurring Meal Entry
88 W @IOF
89 W "Outpatient Recurring Meals..."
90 K FHDM14,FHEDI,FHEDIF,FHIEN,FHMIEN,FHFLG
91 S FHQ=0
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!FHQ F FHJ=0:0 S FHJ=$O(^FHPT("RM",FHI,FHDFN,FHJ)) Q:FHJ'>0!FHQ I ($P($G(^FHPT(FHDFN,"OP",FHJ,0)),U,15)'="C") D
94 .S FHDA15=$G(^FHPT(FHDFN,"OP",FHJ,0))
95 .S FHDM14(FHI,$P(FHDA15,U,4))=FHI_U_FHJ
96 .;
97 .S FHMEAL=$P(FHDA15,U,4),FHLOC=$P(FHDA15,U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHMEAL="B":"Break",FHMEAL="N":"Noon",1:"Even"),FH11=FHMEAL_" "_FHLOCN
98 .S Y=$P(FHDA15,U,1) X ^DD("DD") S DTP=Y
99 .S (FHCOFLG,FHDATL)=0
100 .I $Y>(IOSL-5) K DIR S DIR(0)="E",DIR("A")="Enter RETURN to Continue or '^' to Quit Listing" D ^DIR W:Y @IOF I 'Y S FHQ=1 Q
101 .W !,DTP,?12,FH11,":"
102 .S FHDATL=$L(DTP)+13+$L(FH11)
103 .F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"OP",FHJ,"SP",FHSF)) Q:FHSF'>0 D
104 ..S FHDA15SF=$G(^FHPT(FHDFN,"OP",FHJ,"SP",FHSF,0))
105 ..Q:$P(FHDA15SF,U,6)
106 ..S FHDASFNM=$P($G(^FH(118.3,$P(FHDA15SF,U,2),0)),U,1),FHDASFQT=$P(FHDA15SF,U,8)
107 ..I (FHDATL+$L(FHDASFNM)+3+$L(FHDASFQT))>79 W !,?19 S FHDATL=19
108 ..I (FHDATL>19),(FHCOFLG=1) W ","
109 ..S FHDATL=FHDATL+4+$L(FHDASFNM)+3+$L(FHDASFQT)
110 ..W " ",FHDASFNM," = ",FHDASFQT
111 I '$D(FHDM14) W !!,"NO OUTPATIENT DATA ON FILE for today's date and the future!!",! Q
112 W !
113 ;
114 K DIC S DIC(0)="AEQM"
115 S DIC("W")="S FHMEAL=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHMEAL=""B"":""Break"",FHMEAL=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
116 S DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
117 S DIC="^FHPT(FHDFN,""OP"","
118 S DIC("?")="Select a Date, '^' to exit"
119 S DIC("A")="Select the Outpatient Date :" D ^DIC K DIC Q:(Y'>0)!$D(DTOUT)
120 S ADM=+Y
121 Q
122CHK ;ENTER DATES.
123 K FHDT1,FHDT2
124 S FHFLG=0
125F1 ;START DATE
126 K DIC S DIC(0)="AEQM"
127 W !
128 S DIC("W")="S FHML=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHML=""B"":""Break"",FHML=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
129 S DIC("S")="S FHML=$P(^(0),U,4),FHDT1=$P(^(0),U,1) I $P(^(0),U,1)>(DT-1),($P(^(0),U,15)'=""C""),FHML=FHDTML"
130 S DIC="^FHPT(FHDFN,""OP"","
131 S DIC("?")="Enter a Date, '^' to exit"
132 S DIC("A")="Enter a Start Date :" D ^DIC K DIC Q:(Y'>0)!$D(DTOUT)
133 S FHDT1=$P(^FHPT(FHDFN,"OP",+Y,0),U,1)
134F2 ;END DATE
135 K DIC S DIC(0)="AEQM"
136 W !
137 S DIC("W")="S FHML=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHML=""B"":""Break"",FHML=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
138 S DIC("S")="S FHML=$P(^(0),U,4),FHDT2=$P(^(0),U,1) I $P(^(0),U,1)>(FHDT1-1),($P(^(0),U,15)'=""C""),FHML=FHDTML"
139 S DIC="^FHPT(FHDFN,""OP"","
140 S DIC("?")="Enter a Date, '^' to exit"
141 S DIC("A")="Enter an End Date :" D ^DIC K DIC Q:(Y'>0)!$D(DTOUT)
142 S FHDT2=$P(^FHPT(FHDFN,"OP",+Y,0),U,1)
143 I FHDT2<FHDT1 W !!,"***End Date must be on or after Start Date!!!" G F2
144 S FHFLG=1
145 Q
146CPRSO ;check previous SO
147 K FHSOO,FHCK
148 S (FHDAT,FHSO)=""
149CPRS1 I FHSO="" S FHSO=$O(^FHPT("ASPO",FHDFN,""),-1)
150 E S FHSO=$O(^FHPT("ASPO",FHDFN,FHSO),-1)
151 Q:'$G(FHSO)
152 S FHDAT=$G(^FHPT(FHDFN,"OP",FHSO,0)),FHPRML=$P(FHDAT,U,4),FHPRCN=$P(FHDAT,U,15)
153 I (FHPRML'=FHMEAL)!(FHPRCN="C") G CPRS1
154 S FHCK(FHPRML)=""
155 F FHI=0:0 S FHI=$O(^FHPT(FHDFN,"OP",FHSO,"SP",FHI)) Q:FHI'>0 D
156 .S FHSODAT=$G(^FHPT(FHDFN,"OP",FHSO,"SP",FHI,0)),FHSOI=$P(FHSODAT,U,2),FHSOCN=$P(FHSODAT,U,6),FHSOQ=$P(FHSODAT,U,8)
157 .Q:$P(FHSODAT,U,9)="Y"
158 .I '$G(FHSOI)!$G(FHSOCN) Q
159 .S FHSOO(FHI,FHSOI)=FHSOQ,P(1,FHSOI)=""
160 Q
161PPRSO ;PROCESS previous SO
162 Q:'$D(FHSOO)
163 S (LS,LN)=1
164 D NOW^%DTC S NOW=%
165 F FHI=0:0 S FHI=$O(FHSOO(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(FHSOO(FHI,FHJ)) Q:FHJ'>0 S NUM=FHSOO(FHI,FHJ),SP=FHJ D AD1^FHSP
166 Q
167SOEVNT S FHDTC=0
168 S FHLOCN="" I $D(FHLOC),$G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHLOCN=$P(^(0),U,1)
169 S FHDTC=FHDTC+1,DTP=FHOSTDT D DTP^FH S:FHDTC=1 FHDTP=DTP
170 S DTP=$P(ENDT,".",1) D DTP^FH
171 I DTP'=FHDTP S FHDTP=FHDTP_" to "_DTP
172 S FHALML=FHMEAL
173 F FHI=0:0 S FHI=$O(FHSOO(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(FHSOO(FHI,FHJ)) Q:FHJ'>0 S NUM=FHSOO(FHI,FHJ),SP=FHJ D EVNT^FHSP1
174 Q
175KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.