source: FOIAVistA/trunk/r/DIETETICS-FH/FHORD7.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: 3.8 KB
Line 
1FHORD7 ; HISC/REL/NCA/JH - Diet Order Utilities ;4/5/96 11:27
2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
3CUR ; Get Diet
4 S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
5 S X1=$G(^FHPT(FHDFN,"A",ADM,0)),FHORD=$P(X1,"^",2),X1=$P(X1,"^",3),(FHLD,FHOR,X,Y)=""
6 Q:'FHORD Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
7C2 ; Set FHOR & FHLD variables & Y = diet text
8 S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),Y=""
9 I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") S:%>0 Y=$P($E(FHDU,%,999),";",1) K % Q
10C3 S Y="" 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)
11 Q
12NOW D NOW^%DTC S NOW=% Q
13POST ; Generate bulletin
14 S WRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8) Q:WRD<1
15 F FHXMKK=0:0 S FHXMKK=$O(^FH(119.6,WRD,2,"B",FHXMKK)) Q:FHXMKK'>0 D
16 .S XMY(FHXMKK)=""
17 Q:'$D(XMY) S XMB="FHDIORD"
18 D PATNAME^FHOMUTL I DFN="" Q
19 S XMB(1)=$P(^DPT(DFN,0),"^",1),XMB(2)=$P(^FH(119.6,WRD,0),"^",1) D C3 S XMB(3)=Y
20 S XMB(5)=$S($D(^DPT(DFN,.101)):^(.101),1:"unknown")
21 S DTP=D1 D DTP^FH S XMB(4)=DTP D ^XMB K XMB,XMY,XMM,XMDT,FHXMKK Q
22STR ; Store new diet order
23 D ORD,NOW
24 S X=FHORD_"^"_FHOR_"^"_FHLD_"^"_TYP_"^"_D1_"^"_$S(D2:D2,1:"")_"^"_DUZ_"^"_NOW,FHNOW=NOW
25 S ^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=X S:COM'="" ^(1)=COM I FHWF D OE^FHORD71 S NOW=FHNOW
26S0 G:'D2 S1 S X2=D2+.000001
27S01 S A2=0 F A1=0:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1<1!(A1'<X2) S A2=A1
28 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'>D2 G S01
29 F A1=D1:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1<1!(A1'<D2) D SK
30 S Z6=D1_"^"_FHORD D ACR^FHORD71
31 I 'A2 D ORD S A2=FHORD,^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=FHORD_"^^^^^^X^^"_D2_"^^"_DUZ_"^"_NOW
32 E D OE3
33 S Z6=D2_"^"_A2 D ACR^FHORD71 G S2
34S1 I FHLD'="P" F A1=D1:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1="" D SK
35 S Z6=D1_"^"_FHORD D ACR^FHORD71
36S2 S X1="",A1=0 G S4
37S3 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) G:A1="" S4 S X2=$P(^(A1,0),"^",2)
38 I X2<1 D SK G S3
39 I '$D(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) D SK G S3
40 S X2=^FHPT(FHDFN,"A",ADM,"DI",X2,0) I $P(X2,"^",2,8)'=$P(X1,"^",2,8) S X1=X2 G S3
41 I $P(X1,"^",10)="" D SK G S3
42 I $P(X2,"^",10),$P(X2,"^",10)'>$P(X1,"^",10) D SK G S3
43 S X1=X2 G S3
44S4 D OEU^FHORD71 S NOW=FHNOW K FHNOW G U1
45UPD ; Get time & update diet
46 D NOW I $D(ZTQUEUED),$D(Z6) I NOW<Z6 S NOW=Z6+.0002
47U1 ; Update diet
48 S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" W "Could not find patient" Q
49 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>NOW) S A1=K
50 G:'A1 U3 S X1=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G S2:X1<1,S2:'$D(^FHPT(FHDFN,"A",ADM,"DI",X1,0))
51 S X2=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) S:X2<1 X2=""
52U2 I $P(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=X1_"^"_X2 Q
53 S FHYES=0 I $P(^FHPT(FHDFN,"A",ADM,0),"^",2)=X1 S FHYES=1
54 S $P(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=X1_"^"_X2,X9="" I X1 S X9=$P(^FHPT(FHDFN,"A",ADM,"DI",X1,0),"^",8) I 'FHYES S EVT="D^O^"_X1 D ^FHORX
55 I X9'="",X9'=$P(^FHPT(FHDFN,"A",ADM,0),"^",5) S $P(^(0),"^",5)=X9
56 K X9 D ^FHORD72 K FHYES Q
57U3 S (X1,X2)="" G U2
58SK K ^FHPT(FHDFN,"A",ADM,"AC",A1) S Z6=-1 G ACR^FHORD71
59ORD ; Get next order #
60 L +^FHPT(FHDFN,"A",ADM,"DI",0)
61 I '$D(^FHPT(FHDFN,"A",ADM,"DI",0)) S ^FHPT(FHDFN,"A",ADM,"DI",0)="^115.02A^^"
62 S X=^FHPT(FHDFN,"A",ADM,"DI",0),FHORD=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_FHORD_"^"_($P(X,"^",4)+1)
63 L -^FHPT(FHDFN,"A",ADM,"DI",0) Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD)) G ORD
64OE3 ; Enter New Re-enstated Order
65 Q:$$VERSION^XPDUTL("OR")=2.5
66 D ORD^FHORR S FHNO1=$G(^FHPT(FHDFN,"A",ADM,"DI",A2,0)),FHNO2=$G(^(1)),FHNO3=$G(^(2))
67 S ^FHPT(FHDFN,"A",ADM,"DI",FHORD1,0)=FHORD1_"^"_$P(FHNO1,"^",2,8)_"^"_D2_"^"_$P(FHNO1,"^",10)_"^"_DUZ_"^"_NOW_"^"_$P(FHNO1,"^",13) S:FHNO2'="" ^(1)=FHNO2
68 S:FHNO3 ^(2)=FHNO3,^(3)=DUZ_"^"_NOW S A2=FHORD1 I FHWF D OE^FHORR S NOW=FHNOW
69 K FHNO1,FHNO2,FHNO3,FHORD1 Q
Note: See TracBrowser for help on using the repository browser.