source: FOIAVistA/trunk/r/DIETETICS-FH/FHASN71.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: 4.1 KB
Line 
1FHASN71 ; HISC/NCA - Print Status Average (cont.) ;9/28/95 10:52
2 ;;5.5;DIETETICS;;Jan 28, 2005
3Q0 ; Process Screening all patients
4 K S,DWRD S TOT=""
5 F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 F LST=0:0 S LST=$O(^FH(119.6,WRD,"W",LST)) Q:LST<1 S X=+$G(^(LST,0)) S:'$D(DWRD(X)) DWRD(X)=WRD
6 F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN<1 I $D(^FHPT(FHDFN,0)) K N S ND=0 D Q1,CALC
7 G P0
8Q1 ; Tabulate status
9 D PATNAME^FHOMUTL I DFN="" Q
10 S DGT=EDT+1,DGT=DGT+.0000001,(DGA1,DG1,DGXFR0)="" D ^DGPMSTAT Q:DGA1=""!(DG1="")
11 S ADM=DGA1,XX=$G(^DGPM(ADM,0)),DISC=$P(XX,"^",17) S:DISC'="" DISC=$P($G(^DGPM(DISC,0)),"^",1)
12 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
13 S MW1=$S($P(DG1,"^",1):$P(DG1,"^",1),1:0),W1=$S($D(DWRD(+MW1)):$G(DWRD(+MW1)),1:0)
14 I '$D(^FH(119.6,+W1,0)) S MWRD=$P($G(^DIC(42,+MW1,0)),"^",1) S DW1=$O(^FH(119.6,"B",MWRD,0)) Q:DW1<1 S W1=+DW1
15 S WD=$P($G(^FH(119.6,+W1,0)),"^",2) S:'WD WD=0
16 I '$D(^FHPT(FHDFN,"S",0)) D Q2 Q
17 D NS I '$D(^TMP($J,"FHNS")) D Q2 Q
18 S NX="" F X4=0:0 S X4=$O(^TMP($J,"FHNS",X4)) Q:X4<1 S X5=$G(^(X4,0)),NX=X4 D CHK
19 Q
20CHK ; Check if inpat with ADM
21 I $P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999) D GADM G:'$D(^FHPT(FHDFN,"A",ADM,0)) Q2 G:$P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999) Q2
22 I DISC,$P(X5,"^",1)>DISC D GADM Q:'$D(^FHPT(FHDFN,"A",ADM,0)) Q:DISC&($P(X5,"^",1)>DISC)
23 S S1=$P(X5,"^",2),D1=$P(X5,"^",3)
24 S W1=$S($P(X5,"^",6)'="":$P(X5,"^",6),1:W1) S:'W1 W1=0 S WD=$P($G(^FH(119.6,+W1,0)),"^",2) S:'WD WD=0
25 I S1,S1<5 G Q3
26Q2 ; Unclassified
27 S S1=5,D1=WD
28Q3 ; Set Classification
29 S X=$S(SRT="W":W1,1:D1) S:'$D(N(X)) N(X)="" S $P(N(X),"^",S1)=$P(N(X),"^",S1)+1,ND=ND+1
30 Q
31GADM ; Get next ADM for pat
32 D PATNAME^FHOMUTL I DFN="" Q
33 S NX=$O(^DGPM("ATID1",DFN,NX)) Q:NX="" S ADM=+$O(^(NX,0)),XX=$G(^DGPM(ADM,0)),DISC=$P(XX,"^",17) S:DISC'="" DISC=$P($G(^DGPM(DISC,0)),"^",1)
34 Q:'$D(^FHPT(FHDFN,"A",ADM,0)) Q:$P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999)
35 S W1=$S($P(XX,"^",6):$P(XX,"^",6),1:0),WD=$P($G(^FH(119.6,+W1,0)),"^",2) S:'WD WD=0
36 Q
37NS ; Nutrition Status in inverse date order
38 K ^TMP($J,"FHNS") S FHX1=9999999-(EDT+.3),FHX2=9999999-(SDT+.0001),ZZ=""
39 F XX=FHX1:0 S XX=$O(^FHPT(FHDFN,"S",XX)) Q:XX<1!(XX>FHX2) S X=$G(^(XX,0)) D STOR
40 I '$D(^TMP($J,"FHNS")) S XX=FHX1,FHX1=$O(^FHPT(FHDFN,"S",FHX1)) Q:FHX1="" S X=$G(^(FHX1,0)) D STOR
41 Q
42STOR ; Store Nutrition Status by inverse date
43 I ZZ'=($P(X,"^",1)\1) S ^TMP($J,"FHNS",XX,0)=X
44 S ZZ=$P(X,"^",1)\1
45 Q
46CALC ; Calculate Average
47 I $G(N(0))'="" S L=0 D C1
48 F L=0:0 S L=$O(N(L)) Q:L<1 D C1
49 Q
50C1 F K=1:1:5 D
51 .S X=$S(ND:$P(N(L),"^",K)/ND,1:"")
52 .S X=$J(X,0,0) S:'$D(S(L)) S(L)=""
53 .S $P(S(L),"^",K)=$P(S(L),"^",K)+X
54 .S $P(S(L),"^",6)=$P(S(L),"^",6)+X
55 .S $P(TOT,"^",K)=$P(TOT,"^",K)+X
56 .S $P(TOT,"^",6)=$P(TOT,"^",6)+X
57 .Q
58 Q
59P0 ; Print summary
60 S DTP=SDT D DTP^FH S DTE=DTP_" to " S DTP=EDT D DTP^FH S DTE=DTE_DTP
61 D NOW^%DTC S (NOW,DTP)=% D DTP^FH S PG=0,LN="",$P(LN,"-",100)="" D HDR
62 K ^TMP($J) F W1=0:0 S W1=$O(S(W1)) Q:W1="" D P1
63 S NAM="" F W1=0:0 S NAM=$O(^TMP($J,NAM)) Q:NAM="" S D1=^(NAM) D P2
64 I $G(S(0))'="" S D1=$G(S(0)) W ! D
65 .W ?16,"UNKNOWN",?48
66 .F K=1:1:5 S X=$P(D1,"^",K) W $S(X:$J(X,7),1:$J("",7)) S X=$S($P(D1,"^",6):X/$P(D1,"^",6)*100,1:"") W $S(X:$J(X,5,0),1:$J("",5))
67 .S X=$P(D1,"^",6) W $S(X:$J(X,7),1:$J("",7)) Q
68 W !?16,LN,!?16,"Grand Total",?48 F K=1:1:5 S X=$P(TOT,"^",K) W $S(X:$J(X,7),1:$J("",7)) S X=$S($P(TOT,"^",6):X/$P(TOT,"^",6)*100,1:"") W $S(X:$J(X,5,0),1:$J("",5))
69 S X=$P(TOT,"^",6) W $S(X:$J(X,7),1:$J("",7))
70 W ! Q
71P1 I SRT="W" S NAM=$P($G(^FH(119.6,+W1,0)),"^",1)
72 E S NAM=$P($G(^VA(200,+W1,0)),"^",1)
73 Q:NAM="" S ^TMP($J,NAM_"~"_W1)=S(W1) Q
74P2 D:$Y>(IOSL-8) HDR W !?16,$P(NAM,"~",1),?48
75 F K=1:1:5 S X=$P(D1,"^",K) W $S(X:$J(X,7),1:$J("",7)) S X=$S($P(D1,"^",6):X/$P(D1,"^",6)*100,1:"") W $S(X:$J(X,5,0),1:$J("",5))
76 S X=$P(D1,"^",6) W $S(X:$J(X,7),1:$J("",7))
77 Q
78HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?16,DTP,!!?42,"N U T R I T I O N S T A T U S A V E R A G E",?109,"Page ",PG
79 W !!?(132-$L(DTE)\2),DTE
80 W !!?16,$S(SRT="C":"CLINICIAN",1:"WARD"),?54,"I % II % III % IV % UNC % TOTAL",!?16,LN,! Q
Note: See TracBrowser for help on using the repository browser.