source: FOIAVistA/trunk/r/DIETETICS-FH/FHASN4.m@ 1166

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1FHASN4 ; HISC/NCA - Nutrition Status Matrix (cont.) ;8/3/94 11:11
2 ;;5.5;DIETETICS;;Jan 28, 2005
3Q0 ; Process Screening
4 K S,^TMP($J),CTN,CTR S CT=0,ANS=""
5 F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1'>0 D F0
6 G P0
7F0 I WRDS,W1'=WRDS Q
8 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",W1,FHDFN)) Q:ADM<1 S (NEW,OLD)=0 D Q1
9 Q
10Q1 ; Process screening inpatients for status comparison
11 S ADTE=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",1) Q:ADTE=""
12 S DSCH=$P($G(^DGPM(ADM,0)),"^",17) S:DSCH>0 DSCH=$P($G(^DGPM(+DSCH,0)),"^",1)
13 I FHX1=2 S SDT=ADTE,EDT=DT
14 S X1=EDT\1,X2=ADTE\1 D ^%DTC Q:'%Y
15 I FHX1=1 Q:X<NOM I X'>NOM,SDT<(ADTE\1) Q
16 I FHX1=2 Q:X'=NOM
17 I DSCH,DSCH>SDT,DSCH<EDT Q
18 ; Tabulate status for new
19 S X4=EDT+1,X4=X4+.0001,X4=9999999-X4
20 S X4=$O(^FHPT(FHDFN,"S",X4)) G:'X4 Q2 S X5=^(X4,0)
21 I $P(X5,"^",1)<$S(SDT:SDT,1:9999999) G Q2:$P(X5,"^",1)<ADTE,CNT
22 S NEW=$S($P(X5,"^",2)<5:$P(X5,"^",2),1:5)
23 G Q3
24CNT ; Count unchanged status
25 S (OLD,NEW)=$S($P(X5,"^",2)<5:$P(X5,"^",2),1:5)
26 G Q5
27Q2 ; Unclassified New
28 S NEW=5
29Q3 ; Tabulate status for old
30 S L1=SDT\1,L1=L1-.0001
31 S L1=$O(^FHPT(FHDFN,"S","B",L1)) G:L1=""!(L1\1>EDT) Q4
32 S L1=9999999-L1,X6=$G(^FHPT(FHDFN,"S",L1,0)) G:X6="" Q4
33 S X1=SDT\1-.0001,X1=X1\1,X2=3 D C^%DTC S THR=X
34 I $P(X6,"^",1)>$S(THR:THR+.3,1:9999999) G:SDT\1=ADTE\1 Q4 S L1=$O(^FHPT(FHDFN,"S",L1)) G:L1="" Q4 S X6=$G(^(L1,0)) G:$P(X6,"^",1)<ADTE Q4
35 S OLD=$S($P(X6,"^",2)<5:$P(X6,"^",2),1:5)
36 G Q5
37Q4 ; Unclassified Old
38 S OLD=5
39Q5 ; Set Classification for Old and New
40 I OLD=NEW S:'$D(CTR(W1)) CTR(W1)="" S $P(CTR(W1),"^",OLD)=$P(CTR(W1),"^",OLD)+1,$P(CTR(W1),"^",6)=$P(CTR(W1),"^",6)+1
41 S:'$D(S(W1,OLD)) S(W1,OLD)="" S $P(S(W1,OLD),"^",NEW)=$P(S(W1,OLD),"^",NEW)+1
42 S:'$D(CTN(W1)) CTN(W1)="" S $P(CTN(W1),"^",OLD)=$P(CTN(W1),"^",OLD)+1
43 I OLD=NEW Q:OLD'=5
44 S CT=CT+1
45 S:'$D(^TMP($J,"VEC1",W1,OLD,NEW,CT)) ^TMP($J,"VEC1",W1,OLD,NEW,CT)=""
46 D PATNAME^FHOMUTL I DFN="" Q
47 S Y=$P($G(^DPT(DFN,0)),"^",1) S:Y="" Y="Unknown" D PID^FHDPA
48 S ^TMP($J,"VEC1",W1,OLD,NEW,CT)=$E(Y,1,30)_"^"_BID
49 S $P(^TMP($J,"VEC1",W1,OLD,NEW,CT),"^",NEW+2)=$P(^TMP($J,"VEC1",W1,OLD,NEW,CT),"^",NEW+2)+1
50 Q
51P0 ; Print Summary
52 D NOW^%DTC S (NOW,DTP)=% D DTP^FH S HD=DTP S PG=0,LN="",$P(LN,"-",80)=""
53 I FHX1=1 S DTP=SDT D DTP^FH S DTE=DTP_" to " S DTP=EDT D DTP^FH S DTE=DTE_DTP
54 I FHX1=2 S DTE="Admission "_NOM_" Days to "_HD
55 F W1=0:0 S W1=$O(S(W1)) Q:W1="" F ST=0:0 S ST=$O(S(W1,ST)) Q:ST="" D P1
56 F W1=0:0 S W1=$O(CTN(W1)) Q:W1="" S NAM=$P($G(^FH(119.6,+W1,0)),"^",1) S:NAM'="" ^TMP($J,"CNT",NAM_"~"_W1,0)=$P(CTN(W1),"^",1)_"^"_$P(CTN(W1),"^",2)_"^"_$P(CTN(W1),"^",3)_"^"_$P(CTN(W1),"^",4)_"^"_$P(CTN(W1),"^",5)_"^"_$G(CTR(W1))
57 S (NAM,STS)="",N=1
58 F W1=0:0 S NAM=$O(^TMP($J,"VEC2",NAM)) Q:NAM=""!(ANS="^") D HDR^FHASN3:N=1,HD^FHASN3:N'=1 S (TOT,SUM)=0,TOT1="",N=N+1 F ST=0:0 S ST=$O(^TMP($J,"VEC2",NAM,ST)) D:ST<1 LAST Q:ST<1!(ANS="^") S STS=ST,D1=^(STS,0) D P2
59 K ^TMP($J),CTN,CTR,N,SUM,TOT,TOT1,X
60 W ! Q
61P1 S NAM=$P($G(^FH(119.6,+W1,0)),"^",1)
62 Q:NAM="" S ^TMP($J,"VEC2",NAM_"~"_W1,ST,0)=$G(S(W1,ST))
63 F LL=1:1:5 I $D(^TMP($J,"VEC1",W1,ST,LL)) F CT=0:0 S CT=$O(^TMP($J,"VEC1",W1,ST,LL,CT)) Q:CT<1 S ^TMP($J,"VEC2",NAM_"~"_W1,ST,"NS",LL,CT)=$G(^TMP($J,"VEC1",W1,ST,LL,CT))
64 Q
65P2 D:$Y'<(IOSL-3) HD^FHASN3 Q:ANS="^"
66 W !,$S(STS=1:"I",STS=2:"II",STS=3:"III",STS=4:"IV",1:"UNC")
67 S TOT=$G(^TMP($J,"CNT",NAM,0)) W ?24,$J($P(TOT,"^",STS),7) S SUM=SUM+$P(TOT,"^",STS)
68 W ?37 F K=1:1:5 S X=$P(D1,"^",K) W $J(X,7) S $P(TOT1,"^",K)=$P(TOT1,"^",K)+X
69 S X=$P(TOT,"^",5+STS) W $J(X,7)
70 F LL=0:0 S LL=$O(^TMP($J,"VEC2",NAM,STS,"NS",LL)) Q:LL<1 F CT=0:0 S CT=$O(^TMP($J,"VEC2",NAM,STS,"NS",LL,CT)) Q:CT<1 S Y=^(CT) W !?1,$P(Y,"^",2),?10,$E($P(Y,"^",1),1,26),?37 D
71 .F L=1:1:5 S AST=$P(Y,"^",L+2) S:AST AST="*" W $J(AST,7)
72 .Q
73 Q
74LAST ; Last Total Line
75 W !,LN,!,"Total",?24,$J(SUM,7),?37 F L=1:1:5 W $J($P(TOT1,"^",L),7)
76 W $J($S($P(TOT,"^",11)'="":$P(TOT,"^",11),1:""),7)
77 Q
Note: See TracBrowser for help on using the repository browser.