source: FOIAVistA/trunk/r/DIETETICS-FH/FHORX1B.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1FHORX1B ; HISC/REL/RVD - Diet Activity Labels ;8/26/94 12:10
2 ;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
3 ;
4 ;^tmp($J,"I" - for inpatient data.
5 ;^tmp($J,"O" - for outpatient data;
6 ;
7 ;S FHPIO="** INPATIENT **"
8 S S2=LAB=2*5+36 I LAB<3 D LHD
9 S COUNT=0,LINE=1
10 S P0="",NN=0 F S P0=$O(^TMP($J,"I",P0)) Q:P0="" D LST
11 ;S FHPIO="** OUTPATIENT **"
12 D LST1 ;go process event for outpatient
13 S:$G(FHP) $P(^FH(119.73,FHP,0),"^",3)=NOW
14 I '$G(FHP) F FHII=0:0 S FHII=$O(^FH(119.73,FHII)) Q:FHII'>0 S $P(^FH(119.73,FHII,0),"^",3)=NOW
15 I LAB>2 D DPLL^FHLABEL
16 I LAB<3 F L=1:1:18 W !
17 K ^TMP($J) D KILL^XUSCLEAN
18 Q
19LST K PP S NP=0,LOC=0 F DA=0:0 S DA=$O(^TMP($J,"I",P0,DA)) Q:DA<1 S Z=^(DA) D L1
20 Q:LOC
21 I $D(PP) D L2 D:$G(FHORD) WRT
22 Q
23 ;
24LST1 ;process outpatient
25 K PP S NP=0,LOC=0,P0="" F S P0=$O(^TMP($J,"O",P0)) Q:P0="" D T2
26 Q
27 ;
28L1 ; Process event for inpatient
29 S ADM=$P(Z,"^",1),TYP=$P(Z,"^",2),ACT=$P(Z,"^",3),FHORD=$P(Z,"^",4),TXT=$P(Z,"^",5)
30 Q:"DIL"'[TYP I 'FHORD S NN=NN+1,FHORD=NN
31 I "DI"[TYP D
32 .I $D(PP(TYP,ADM_"~"_FHORD)),ACT="C" K PP(TYP,ADM_"~"_FHORD) Q
33 .K PP(TYP) S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT Q
34 I TYP="L" D
35 .I ACT="D" S LOC=1 Q
36 .S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT S:ACT="A" NP=1 Q
37 Q
38 ;
39L2 S W1=$P(P0,"~",2),R1=$P(P0,"~",4),FHDFN=$P(P0,"~",5)
40 D PATNAME^FHOMUTL I DFN="" Q
41 S Y0=$G(^DPT(DFN,0))
42 S N1=$P(Y0,"^",1) D PID^FHDPA
43 S TC=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",5),IS=$P($G(^(0)),"^",10),FHORD=+$P($G(^(0)),"^",2)
44 Q:'FHORD
45 I IS S IS=$G(^FH(119.4,IS,0)) I IS'="" S TC=TC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
46 S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) D CUR
47 Q
48 ;
49T2 ;get the last outpatient entry.
50 K PP S NP=0,LOC=0 F FH8=0:0 S FH8=$O(^TMP($J,"O",P0,FH8)) Q:FH8'>0 D
51 .S FHTDAT=$G(^TMP($J,"O",P0,FH8))
52 .S FHACTI=$P(FHTDAT,"^",1)
53 .Q:FHACTI'="O"
54 .S BID=$P(FHTDAT,"^",3)
55 .S FHDESC=$P(FHTDAT,"^",4)
56 .S TC=$P(FHTDAT,"^",5)
57 .S FHDES1=$P(FHDESC,",",1)
58 .S FHDIET=$P(FHDES1,":",2),FHDIET=$E(FHDIET,2,$L(FHDIET))
59 .I FHDIET'="",$D(^FH(111,"B",FHDIET)) S FHDIDA=$O(^FH(111,"B",FHDIET,0))
60 .Q:'$G(FHDIDA)
61 .I $G(FHDIDA),$D(^FH(111,FHDIDA,0)) S FHDIET=$P(^FH(111,FHDIDA,0),U,7)
62 .;S:FHDIET="" FHDIET="NO ORDER"
63 .S Y=FHDIET
64 .S W1=$P(P0,"~",2),R1="",N1=$P(P0,"~",5)
65 .D WRT
66 Q
67 ;
68WRT S ALG="" D ALG^FHCLN
69 I LAB>2 D LL Q
70 W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W:NP " *"
71 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 !,$S(ALG="":"",1:"*ALG"),!,Y,!!
72 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),!
73 W @FHIO("EOF") W:LAB=2 ?(S2-20),$P(H1," - ",2),!! Q
74 ;
75LHD S A1=S2-30\2 W:LAB=2 ! W !?A1,"***************************",!?A1,"*",?(A1+26),"*",!?A1,"*",?(A1+5),$P(H1," - ",2),?(A1+26),"*"
76 W !?A1,"*",?(A1+26),"*",!?A1,"***************************",! W:LAB=2 !! Q
77CUR S Y="" Q:X="" S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7)
78 I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
79 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)
80 Q
81LL ;
82 S X1=TC S:NP BID=BID_" *"
83 D LAB^FHLABEL Q
Note: See TracBrowser for help on using the repository browser.