source: FOIAVistA/trunk/r/DIETETICS-FH/FHNO7.m@ 873

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

initial load of FOIAVistA 6/30/08 version
File size: 7.5 KB
Line 
1FHNO7 ; HISC/REL - List Supplemental Fdgs. ;12/15/94 09:14
2 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
3 ;patch #5 - add outpatient SF. ;patch #8 - add allergy display
4LIS ; Display Feeding
5 S (FHLOCN,Y)=""
6 I WARD'="" S NAM=$P($G(^DPT(DFN,0)),"^",1) D CUR^FHORD7
7 I WARD="",'$G(ADM) Q
8 I WARD="" D PATNAME^FHOMUTL S NAM=FHPTNM,FHDIET=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,2) D
9 .S:FHDIET Y=$P($G(^FH(111,FHDIET,0)),U,7) I 'FHDIET S FHRNUM=ADM D DIETPAT^FHOMRR1 S Y=FHDIETP
10 .S FHLOC=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,3) S:$G(FHLOC) FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1)
11 W:$E(IOST,1,2)="C-" @IOF W !!,NAM," " W:WARD'="" "( ",WARD," )" W:FHLOCN'="" "( ",FHLOCN," )"
12 I WARD="",$D(^FHPT(FHDFN,"OP",ADM,0)) S DTP=$P(^FHPT(FHDFN,"OP",ADM,0),U,1) D DTP^FH W ?50,"Outpatient Date: ",DTP
13 W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
14 D ALG^FHCLN W !," Allergies: ",$S(ALG="":"None on file",1:ALG)
15 I WARD'="" S NO=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",7),Y=$S('NO:"",1:$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)))
16 I WARD="" S NO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3),Y=$S('NO:"",1:$G(^FHPT(FHDFN,"OP",ADM,"SF",NO,0))) I $P(Y,"^",32)'="" S (NO,Y)=""
17 I WARD="" W:$D(FHMEAL) ?50,"MEAL: ",$S(FHMEAL="B":"Breakfast",FHMEAL="N":"Noon",1:"Evening")
18L1 ; Display SF Order
19 I '$D(WARD) S WARD=""
20 S NM=$P(Y,"^",4) W !,"Feeding Menu: ",$S('NM:"None",1:$P(^FH(118.1,NM,0),"^",1)) Q:'NO S DTP=$P(Y,"^",30) D DTP^FH W ?50,"Reviewed: ",DTP
21 I WARD'="" W !!,"10AM",?26,"2PM",?52,"8PM",!,"----------------------- ----------------------- -----------------------"
22 I WARD="",$D(FHMEAL),FHMEAL="B" W !!,"10AM",!,"----------------------------------------------------------------------------"
23 I WARD="",$D(FHMEAL),FHMEAL="N" W !!,"2PM",!,"-----------------------------------------------------------------------------"
24 I WARD="",$D(FHMEAL),FHMEAL="E" W !!,"8PM",!,"-----------------------------------------------------------------------------"
25 K N F K1=1:1:3 F K2=1:1:4 S N(K1,K2)=""
26 S L=4 F K1=1:1:3 S K=0 F K2=1:1:4 S Z=$P(Y,"^",L+1),Q=$P(Y,"^",L+2),L=L+2 I Z'="" S:'Q Q=1 S K=K+1,N(K1,K)=$J(Q,2)_" "_$P($G(^FH(118,Z,0)),"^",1)
27 I WARD'="" F K2=1:1:4 W !,N(1,K2),?26,N(2,K2),?52,N(3,K2)
28 I WARD="",$D(FHMEAL) F K2=1:1:4 W !,$S(FHMEAL="B":N(1,K2),FHMEAL="N":N(2,K2),1:N(3,K2))
29 W:$P(Y,"^",34)'="" !!,"Diet Pattern Associated: ",$S($P(Y,"^",34)="Y":"YES",1:"NO")
30 Q
31EN2 ; Supplemental Feeding Inquiry
32 K FHSFLG,FHDFN,FHPTNM,FHMEAL,ADM,NO,Y,X
33 S FHALL=1 D ^FHOMDPA G:'FHDFN KIL
34 S WARD="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1)) I WARD'="" D LIS G EN2
35 I WARD="" D SF
36 I '$G(FHSFLG) W !,"NO OUTPATIENT DATA ON FILE for today's date and the future!!" G EN2
37 D SF0
38 D:$G(ADM) LIS G EN2
39 ;
40SF ;LIST outpatient SF
41 W @IOF,!,"Outpatient Recurring Meals... "
42 S FHQ=0
43 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
44 .S FHDA15=$G(^FHPT(FHDFN,"OP",FHJ,0))
45 .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
46 .S Y=$P(FHDA15,U,1) X ^DD("DD") S DTP=Y
47 .S (FHCOFLG,FHDATL,FHSF)=0
48 .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
49 .S FHSFLG=1
50 .W !,DTP,?12,FH11
51 .S FHDATL=$L(DTP)+13+$L(FH11)
52 .S:$D(^FHPT(FHDFN,"OP",FHJ,"SF",0)) FHSF=$P(^FHPT(FHDFN,"OP",FHJ,"SF",0),U,3)
53 .Q:'$G(FHSF)
54 .S FHDA15SF=$G(^FHPT(FHDFN,"OP",FHJ,"SF",FHSF,0))
55 .Q:$P(FHDA15SF,U,32)
56 .S FHDASFNM=$P($G(^FH(118.1,$P(FHDA15SF,U,4),0)),U,1)
57 .W ?40," (",FHDASFNM,")"
58 W !
59 Q
60 ;
61 ;K DIC
62 ;S DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
63 ;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"")"
64 ;S DIC="^FHPT(FHDFN,""OP"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
65SF0 ;ask for outpatient SF.
66 K DIC S DIC(0)="AEQM"
67 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"")"
68 S DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
69 S DIC="^FHPT(FHDFN,""OP"","
70 S DIC("?")="Select a Date, '^' to exit"
71 S DIC("A")="Select the Outpatient Date :" D ^DIC K DIC Q:(Y'>0)!$D(DTOUT)
72 S ADM=+Y
73 S FHMEAL=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,4)
74 Q
75 ;
76OIS ;Outpatient Individualized SF
77 Q:'NM
78 I '$D(FHX) S FHX="ALL"
79 I (FHX="ALL")!($L(FHX)=3) S FHIDI="BNE"
80 I $L(FHX)=2 S FHIDI=$S(FHX="NB":"BN",FHX="EB":"BE",FHX="EN":"NE",1:FHX)
81 I $L(FHX)=1 S FHIDI=FHX
82 F FHII=1,2,3 S FHMEAL=$E(FHIDI,FHII) Q:FHII'>0!(FHMEAL="") D G0
83 D G6
84 Q
85G0 ;process each meals for individualized SF.
86 S T1=$S(FHMEAL="B":"10am",FHMEAL="N":"2pm",1:"8pm")
87 S KK=$S(FHMEAL="B":1,FHMEAL="N":5,1:9)
88 ;I NM'=1 D CAN^FHNO5,ADD^FHNO5
89 S DIC="^FH(118,",DIC(0)="EQM",DIC("S")="I $P(^(0),U,3)'=""Y"""
90 ;
91G1 G:KK>12 G5
92 I ((WARD="")&(FHMEAL="B")&(KK>4))!((WARD="")&(FHMEAL="N")&(KK>8)) G G5
93 ;I WARD'="" S T1=$P("10am^2pm^8pm","^",KK-1\4+1)
94 S T2="#"_(KK-1#4+1),P1=KK*2+3
95 S DIC("A")=T1_" Feeding "_T2_": "
96 S OLD=$P(PNN,"^",P1) I OLD S DIC("A")=DIC("A")_$P(^FH(118,+OLD,0),"^",1)_"// "
97 ;
98G2 W !!,DIC("A") R X:DTIME G:'$T!(X["^") G5
99 I X="" G:OLD G3 S KK=$S(KK<5:5,KK<9:9,1:13) G G1
100 I OLD,X="@" S $P(PNN,"^",P1)="",$P(PNN,"^",P1+1)="" S KK=KK+1 G G1
101 D ^DIC G:Y<1 G2 S Y=+Y,K1=$S(KK<5:1,KK<9:5,1:9)
102 F L=K1:1:K1+3 I L'=KK,$P(PNN,"^",L*2+3)=Y W *7," .. DUPLICATE OF EXISTING ITEM!" G G2
103 S:OLD'=Y $P(PNN,"^",P1)=Y
104 ;
105G3 S OLD=$P(PNN,"^",P1+1)
106 ;
107G4 W !,T1," ",T2," Qty: ",$S(OLD="":1,1:OLD),"// " R X:DTIME G:'$T!(X["^") G5
108 S:X="@" X=0 I X="" S:OLD="" $P(PNN,"^",P1+1)=1 S KK=KK+1 G G1
109 I X'?1N.N!(X>20) W *7," ??" S X="?"
110 I X["?" W !?5,"Enter a whole number between 1 and 20" G G4
111 I 'X S $P(PNN,"^",P1)="",$P(PNN,"^",P1+1)="" S KK=KK+1 G G1
112 S $P(PNN,"^",P1+1)=X,KK=KK+1 G G1
113 ;
114G5 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)
115 ;I X="" D CAN^FHNO5 Q
116 Q
117 ;
118G6 S P1=$P(PNN,"^",29) S:P1="" P1="D" W !!,"Dietary or Therapeutic? ",P1,"// " R Y:DTIME S:'$T!("^"[Y) Y=P1
119 S:$P("dietary",Y,1)="" Y="D" S:$P("therapeutic",Y,1)="" Y="T"
120 I $P("DIETARY",Y,1)'="",$P("THERAPEUTIC",Y,1)'="" W *7,!?5," Answer D for Dietary use or T for Therapeutic use" G G6
121 S $P(X,"^",25)=$E(Y,1),PNN=$P(PNN,"^",1,4)_"^"_X
122 ;G:$P(PNO,"^",5,29)=X UPD^FHNO5 D CAN^FHNO5
123 S FHPNNSV=PNN
124 S FHIDFLG=1
125 Q
126 ;
127CPRSF ;check previous SF
128 K PNN
129 S (FHDAT,FHSF)=""
130CPRS1 I FHSF="" S FHSF=$O(^FHPT(FHDFN,"OP",999999999),-1)
131 E S FHSF=$O(^FHPT(FHDFN,"OP",FHSF),-1)
132 Q:'$G(FHSF)
133 S FHDAT=$G(^FHPT(FHDFN,"OP",FHSF,0)),FHPRML=$P(FHDAT,U,4),FHPRCN=$P(FHDAT,U,15),FHLOCN=$P(FHDAT,U,3)
134 I (FHPRML'=FHMEAL)!(FHPRCN="C")!'$D(^FHPT(FHDFN,"OP",FHSF,"SF",0)) G CPRS1
135 S FHI=$P($G(^FHPT(FHDFN,"OP",FHSF,"SF",0)),U,3) Q:FHI'>0
136 S PNN=$G(^FHPT(FHDFN,"OP",FHSF,"SF",FHI,0)),FHSFCX=$P(PNN,U,32)
137 I $G(FHSFCX) K PNN G CPRS1
138 I $P(PNN,U,34)="Y" K PNN Q
139 S $P(PNN,U,3)=DUZ,FHNMSAV=$P(PNN,U,4)
140 Q
141PPRSF ;PROCESS previous SF
142 Q:'$D(PNN)
143 D NOW^%DTC S NOW=%
144 D ADDOUT^FHNO5
145 Q
146SFEVNT ;
147 S FHDTC=0
148 S FHLOCN="" I $D(FHLOC),$G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHLOCN=$P(^(0),U,1)
149 S FHDTC=FHDTC+1,DTP=FHOSTDT D DTP^FH S:FHDTC=1 FHDTP=DTP
150 S DTP=$P(ENDT,".",1) D DTP^FH
151 I DTP'=FHDTP S FHDTP=FHDTP_" to "_DTP
152 I FHADSFF=1 S FHACT="O",FHTXT="Outpatient Supplemental Feeding: "_FHSFMEN_" ("_FHMEAL_") , "_FHLOCN_", "_FHDTP D OPFILE^FHORX
153 Q
154 ;
155KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.