source: FOIAVistA/tag/r/DIETETICS-FH/FHORX1C.m@ 949

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

initial load of FOIAVistA 6/30/08 version

File size: 2.8 KB
Line 
1FHORX1C ; HISC/REL/NCA/RVD - List Dietetic Events ;11/15/00 14:38
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 ;
4 F TYP="L","D","M","I","T","O","P","S","F" I $D(PP(TYP)) S NXT="" F S NXT=$O(PP(TYP,NXT)) Q:NXT="" S ADM=$P(NXT,"~",1),FHORD=$P(NXT,"~",2),ACT=$P(PP(TYP,NXT),"^",1),TXT=$P(PP(TYP,NXT),"^",2),CLK=$P(PP(TYP,NXT),"^",3) D @TYP
5 Q
6L ; Location
7 S EVT=$S(ACT="A":"Admit to ",ACT="T":"Transfer from ",1:"Discharge from ")
8 I "DT"[ACT S X1=$P(TXT,"~",1) S:X1 X1=$P($G(^FH(119.6,X1,0)),"^",1) S EVT=EVT_X1 S X1=$P(TXT,"~",2) S:X1 X1=$P($G(^DG(405.4,X1,0)),"^",1) S:X1'="" EVT=EVT_" "_X1
9 S:ACT="T" EVT=EVT_" to "
10 I "AT"[ACT S X1=$P(TXT,"~",3) S:X1 X1=$P($G(^FH(119.6,X1,0)),"^",1) S EVT=EVT_X1 S X1=$P(TXT,"~",4) S:X1 X1=$P($G(^DG(405.4,X1,0)),"^",1) S:X1'="" EVT=EVT_" "_X1
11 G LNE
12D ; Diet
13 S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),COM=$G(^(1)) Q:X="" D CUR S EVT="Diet: "_Y
14 I FHLD="" S X9=$P(X,"^",8) I X9'="",X9'=TC S EVT=EVT_" ("_$S(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe")_")"
15 S:COM'="" EVT=EVT_", "_COM D LNE
16 S X2="" F NX=0:0 S NX=$O(^FHPT(FHDFN,"A",ADM,"AC",NX)) Q:NX<1!(NX>TIM) S X2=$P(^(NX,0),"^",2)
17 Q:X2=FHORD!(X2="") S X=$G(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) D CUR
18 S EVT="Old: "_Y G LNE
19I ; Isolation
20 S EVT="IS: "_$P($G(^FH(119.4,FHORD,0)),"^",1)
21 S:ACT="C" EVT=EVT_" Cancelled" G LNE
22T ; Tubefeed
23 S EVT=""
24 F K1=0:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"TF",FHORD,"P",K1)) Q:K1<1 S X3=$G(^(K1,0)),TUN=$P(X3,"^",1),XX=$G(^FH(118.2,TUN,0)) D CALC^FHORX3 S:EVT'="" EVT=EVT_", " S EVT=EVT_P2_" "_$P(XX,"^",1)
25 S COM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",FHORD,0)),"^",5) I COM'="" S EVT=EVT_", "_COM
26 S EVT="TF: "_EVT S:ACT="C" EVT=EVT_" Cancelled"
27 G LNE
28O ; Additional Order
29 S Y=$P($G(^FHPT(FHDFN,"A",ADM,"OO",FHORD,0)),"^",3) Q:Y=""
30 S EVT="AO: "_Y S:ACT="C" EVT=EVT_" Cancelled" G LNE
31P ; Food Preferences
32 S EVT="FP: "_TXT D CLK G LNE
33M ; Message
34 S EVT="Msg: "_TXT G LNE
35F ; Suppl. feedings P30
36 S Z=$G(^FHPT(FHDFN,"A",ADM,"SF",+FHORD,0)) Q:Z="" S SP=$P(Z,"^",4)
37 S EVT="SF: "_$P($G(^FH(118.1,+SP,0)),"^",1) S:ACT="C" EVT=EVT_" Cancelled" G LNE
38S ; Standing Orders
39 S Z=$G(^FHPT(FHDFN,"A",ADM,"SP",+FHORD,0)) Q:Z="" S SP=$P(Z,"^",2),MEAL=$P(Z,"^",3),QTY=$P(Z,"^",8)
40 S EVT="SO: "_$S(QTY:QTY,1:1)_" "_$P($G(^FH(118.3,+SP,0)),"^",1)_" ("_MEAL_")" S:ACT="C" EVT=EVT_" Cancelled" G LNE
41CUR S Y="" Q:X="" S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7)
42 I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
43 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)
44 Q
45CLK ; Get entered clerk
46 I CLK S EVT=EVT_" By: "_$P($G(^VA(200,+CLK,0)),"^",1)
47 Q
48LNE ; Break line if longer than 48 chars
49 I $Y>(IOSL-6) D HDR^FHORX1A W !
50 I $L(EVT)<49 G EX
51 F KK=49:-1:4 Q:$E(EVT,KK)?1P
52 I KK=4 S KK=48 W !?12,$E(EVT,1,48)
53 E W !?12,$E(EVT,1,KK-1)
54 S EVT=" "_$E(EVT,KK+1,999) G LNE
55EX W !?12,EVT Q
Note: See TracBrowser for help on using the repository browser.