source: FOIAVistA/trunk/r/DIETETICS-FH/FHORD11.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 
1FHORD11 ; HISC/REL/NCA - Diet Activity Report (cont) ;4/26/93 16:37
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 S PG=0,S2=LAB=2*5+36 D HDR:'LAB,LHD:LAB
4 F D2=0:0 S D2=$O(^TMP($J,D2)) Q:D2<1 S P0="" F E1=0:0 S P0=$O(^TMP($J,D2,P0)) Q:P0="" F FHDFN=0:0 S FHDFN=$O(^TMP($J,D2,P0,FHDFN)) Q:FHDFN<1 S X=$G(^TMP($J,D2,P0,FHDFN)) D LST
5 D DISC I LAB F L=1:1:18 W !
6 W:'LAB ! I UPD S $P(^FH(119.73,FHP,0),"^",2)=NOW
7 Q
8LST D PATNAME^FHOMUTL I DFN="" Q
9 S W1=$P(X,"^",1),R1=$P(X,"^",2),ADM=$P(X,"^",3),FHORD=$P(X,"^",4),SF=$P(X,"^",5),IS=$P(X,"^",6),OLW=$P(X,"^",7),OLR=$P(X,"^",8) Q:'$D(^DPT(DFN,0)) S Y0=^(0)
10 S SO=$D(^FHPT("ASP",FHDFN,ADM))
11 S W1=$E(W1,1,15),R1=$E(R1,1,10),N1=$E($P(Y0,"^",1),1,22) D PID^FHDPA
12 S X0=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),COM=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
13 S TC=$P(X0,"^",8) I IS S IS=$G(^FH(119.4,IS,0)) I IS'="" S TC=TC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
14 G:LAB L1 D:$Y>54 HDR W !!,W1,?18,R1,?31,N1,?54,BID W:OLW="" " *" W ?63,$S(SF:"SF",1:""),?66,$S(SO:"SO",1:""),?73,TC W:" "'[OLW ?81,$E(OLW,1,15) W:" "'[OLR ?99,$E(OLR,1,10)
15 D:OLW="" NEWP D OLD S X=X0 D CUR W !?18,"Diet: ",Y W:COM'="" !?24,COM Q
16L1 S X=X0 D CUR W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W:OLW="" " *"
17 W @FHIO("EON") W ?(S2-3\2),TC W @FHIO("EOF") W ?(S2-3-$L(R1)),R1 W @FHIO("EON") I $L(Y)<S2 W:LAB=2 ! W !!,Y,!!
18 E S L=$S($L($P(Y,",",1,3))<S2:3,1:2) W !!,$P(Y,",",1,L) W:LAB=2 ! W !,$E($P(Y,",",L+1,5),2,99),!
19 W @FHIO("EOF") W:LAB=2 ?(S2-20),$P(H1," - ",2),!! Q
20HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?35,"D I E T A C T I V I T Y R E P O R T",?102,"Page ",PG
21 W !!?(110-$L(H1)\2),H1
22 W !!,"Ward",?18,"Room",?31,"Patient",?55,"ID#",?62,"Sup/Std Service Old Ward",?99,"Old Room" Q
23LHD S A1=S2-30\2 W:LAB=2 ! W !?A1,"***************************",!?A1,"*",?(A1+26),"*",!?A1,"*",?(A1+5),$P(H1," - ",2),?(A1+26),"*"
24 W !?A1,"*",?(A1+26),"*",!?A1,"***************************",! W:LAB=2 !! Q
25CUR S Y="" Q:X="" S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7)
26 I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
27 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)
28 Q
29OLD 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)
30 Q:X2=FHORD!(X2="") S X=$G(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) D CUR
31 W !?18,"Old: ",Y Q
32NEWP D ALG^FHCLN W:ALG'="" !?18,"Allergies: ",ALG
33 S X1="Pref:" F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) D N1
34 W:$L(X1)>6 !?18,X1 Q
35N1 S Y=$G(^FH(115.2,+X,0)) Q:$P(Y,"^",2)'="D"
36 S Y=" "_$P(Y,"^",1)_" ("_$P(X,"^",2)_")"_$S($P(X,"^",4)="Y":" (D)",1:"") I $L(X1)+$L(Y)>92 W !?18,X1 S X1="Pref:"
37 S X1=X1_Y Q
38DISC F NX=TIM:0 S NX=$O(^DGPM("ATT3",NX)) Q:NX<1!(NX>NOW) F DA=0:0 S DA=$O(^DGPM("ATT3",NX,DA)) Q:DA'>0 D D2
39 Q
40D2 S X=$G(^DGPM(DA,0)),DFN=$P(X,"^",3),ADM=$P(X,"^",14) Q:'DFN!('ADM)
41 S W1=$G(^DPT(DFN,.1)),CADM=$S(W1="":"",$D(^DPT("CN",W1,DFN)):^(DFN),1:"") Q:CADM
42 S X=$P(X,"^",18) I X=41!(X=42)!(X=46)!(X=47) Q
43 S X=^DPT(DFN,0),N1=$P(X,"^",1),(R1,W1,SF,SO,D2)="" D PID^FHDPA
44 S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
45 I $D(^FHPT(FHDFN,"A",ADM,0)) S X=^(0),W1=$P(X,"^",11),R1=$P(X,"^",12),SF=$P(X,"^",7)
46 S SO=$D(^FHPT("ASP",FHDFN,ADM))
47 S OLW=W1 D:'W1 D3 I W1 S D2=$P($G(^FH(119.6,W1,0)),"^",8),W1=$P($G(^FH(119.6,W1,0)),"^",1)
48 I FHP,FHP'=D2 Q
49 S W1=$E(W1,1,15),R1=$E(R1,1,10),N1=$E(N1,1,22)
50 I 'LAB D:$Y>54 HDR W !!,"** DISCHARGED **",?31,N1,?54,BID,?63,$S(SF:"SF",1:""),?66,$S(SO:"SO",1:""),?81,W1,?99,R1 Q
51 W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W:OLW="" " *" W ?(S2-3-$L(R1)),R1 W !!?(S2-18\2),"** DISCHARGED **",!! W:LAB=2 !?(S2-20),$P(H1," - ",2),!! Q
52D3 S W1="" F L1=0:0 S L1=$O(^DGPM("APMV",DFN,ADM,L1)) Q:L1="" F L2=0:0 S L2=$O(^DGPM("APMV",DFN,ADM,L1,L2)) Q:L2="" S X1=$P($G(^DGPM(L2,0)),"^",6) I X1 S W1=X1 G D4
53D4 S:W1 W1=$O(^FH(119.6,"AW",W1,0)) Q
Note: See TracBrowser for help on using the repository browser.