source: FOIAVistA/tag/r/DIETETICS-FH/FHORD3.m@ 1156

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

initial load of FOIAVistA 6/30/08 version
File size: 3.2 KB
Line 
1FHORD3 ; HISC/REL/NCA - Withhold Service ;8/20/96 09:09 ;
2 ;;5.5;DIETETICS;;Jan 28, 2005;
3F0 S ALL=0 D ^FHDPA G:'DFN KIL^FHORD1 G:'FHDFN KIL^FHORD1
4 D NOW^%DTC S NOW=% D CUR,FUT^FHORD1
5 W !!,"Place patient on NPO/HOLD-TRAY." D F5 Q:'$D(DFN) Q:'$D(FHDFN) D F7 W !!,"... done" G F0
6F5 ; Process NPO
7 S D3=1 D GETD^FHORD71 G:'D1 AB
8F6 R !!,"Comment: ",COM:DTIME G:'$T!(COM[U) AB I COM'?.ANP W *7," ??" G F6
9 I $L(COM)>80!(COM?1"?".E) W *7,!,"Enter comment of up to 80 characters!" G F6
10 Q
11F7 ; File NPO
12 S FHOR="^^^^",FHLD="N",TYP="",D4=0 D STR^FHORD7
13 G KIL^FHORD1
14EN2 ; Cancel Withhold Order
15 D NOW^%DTC S NOW=%,DT=%\1
16 S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL D CUR S OLD=FHLD
17 S (A2,CT)=0 F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1!(KK'<NOW) S A2=KK
18 S XT="" K N F KK=A2-.000001:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1 S FHORD=$P(^(KK,0),"^",2) D T1
19 I 'CT W !!,"No WITHHOLD Orders to Cancel" G KIL
20C0 R !!,"Cancel Which Order #? ",X:DTIME G:'$T!("^"[X) AB I X'?1N.N!(X<1)!(X>CT) W *7," Enter # of Order to Cancel" G C0
21 S FHORD=$P(XT,",",X),KK=N(FHORD) D T0 G KIL
22T0 ; Update cancelled NPO
23 S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),D1=$P(X,"^",9),D2=$S(D1'>NOW:NOW,1:D1)
24 S $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",10)=D2
25 S $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",18,19)=D2_"^"_DUZ
26 S:FHWF'=2 FHORN=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",14)
27 F K9=KK-.000001:0 S K9=$O(^FHPT(FHDFN,"A",ADM,"AC",K9)) Q:K9<1 I $P(^(K9,0),"^",2)=FHORD S D1=K9 D S0
28 D UPD^FHORD7 W:FHWF'=2 " ... done" Q:FHWF=2 D CUR
29 I OLD'="","^^^^"'[FHOR S D1=NOW D ^FHORD1A
30 Q
31S0 ; Set AC cross-ref data field
32 S X2=D1+.0000001,D2=$O(^FHPT(FHDFN,"A",ADM,"AC",D1)) S:D2<1 D2=""
33S1 S A2=0 F A1=0:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1<1!(A1'<X2) S A2=A1
34 I A2 S X2=A2,A2=$P(^FHPT(FHDFN,"A",ADM,"AC",A2,0),"^",2),X1=$P(^FHPT(FHDFN,"A",ADM,"DI",A2,0),"^",10) I X1'="",X1'>D1 G S1
35 D:'A2 NOR S Z6=D1_"^"_A2 D ACR^FHORD71
36 I X1'="",D2=""!(X1<D2) S D1=X1 G S0
37S2 S X1="",A1=0 G S4
38S3 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) G:A1="" S4 S X2=$P(^(A1,0),"^",2)
39 I X2<1 D SK G S3
40 I '$D(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) D SK G S3
41 S X2=^FHPT(FHDFN,"A",ADM,"DI",X2,0) I $P(X2,"^",2,8)'=$P(X1,"^",2,8) S X1=X2 G S3
42 I $P(X1,"^",10)="" D SK G S3
43 I $P(X2,"^",10),$P(X2,"^",10)'>$P(X1,"^",10) D SK G S3
44 S X1=X2 G S3
45S4 D OEU^FHORD71 Q
46SK K ^FHPT(FHDFN,"A",ADM,"AC",A1) S Z6=-1 G ACR^FHORD71
47NOR L +^FHPT(FHDFN,"A",ADM,"DI",0)
48 I '$D(^FHPT(FHDFN,"A",ADM,"DI",0)) S ^FHPT(FHDFN,"A",ADM,"DI",0)="^115.02A^^"
49 S X=^FHPT(FHDFN,"A",ADM,"DI",0),A2=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_A2_"^"_($P(X,"^",4)+1) L -^FHPT(FHDFN,"A",ADM,"DI",0)
50 S ^FHPT(FHDFN,"A",ADM,"DI",A2,0)=A2_"^^^^^^X^^"_D1_"^^"_DUZ_"^"_NOW,X="" Q
51CUR D CUR^FHORD7 W !!,"Current Diet: ",$S(Y'="":Y,1:"No Current Order")
52 Q:'FHORD S X9=$P(X,"^",8) W:X9'="" " (",$S(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe"),")" Q
53T1 Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))!($D(N(FHORD))) Q:$P(^(0),"^",7)="" S P2=$P(^(0),"^",10)
54 S DTP=KK D DTP^FH,C2^FHORD7
55 I 'CT W !!," # Effective Expires Order",!
56 S CT=CT+1,XT=XT_FHORD_",",N(FHORD)=KK W !,$J(CT,2)," ",DTP
57 S DTP=P2 D:DTP DTP^FH W ?24,DTP,?47,Y Q
58AB W *7,!!,"Withhold entry TERMINATED - No change!"
59KIL K %,%H,%I,C,CT,DA,DG,DLB,DTP,I,K9,N,OLD,POP,P2,X9,XT G KIL^FHORD1
Note: See TracBrowser for help on using the repository browser.