source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHORT5A.m@ 949

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

initial load of WorldVistAEHR
File size: 5.2 KB
RevLine 
[613]1FHORT5A ; HISC/REL/NCA/RVD - Tubefeeding Reports (cont) ;3/1/04 13:15
2 ;;5.5;DIETETICS;**1,3,5**;Jan 28, 2005;Build 53
3 ;
4Q1 ; Print Tubefeeding Report
5 S PG=0 D NOW^%DTC S (DTP,NOW)=% D DTP^FH K ^TMP($J)
6INPAT ;get inpatient data
7 F FHDFN=0:0 S FHDFN=$O(^FHPT("ADTF",FHDFN)) Q:FHDFN<1 F ADM=0:0 S ADM=$O(^FHPT("ADTF",FHDFN,ADM)) Q:ADM<1 D PATNAME^FHOMUTL Q:DFN="" D Q2
8 ;
9OUTPAT ;get outpatient data, for today's date.
10 F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F FHFIN=0:0 S FHFIN=$O(^FHPT("RM",DT,FHDFN,FHFIN)) Q:FHFIN'>0 D
11 .;quit if TF is cancelled
12 .I $D(^FHPT(FHDFN,"OP",FHFIN,3)),$P(^(3),U,5)="C" Q
13 .S (FHRMB,RM)=" "
14 .I $D(^FHPT(FHDFN,"OP",FHFIN,0)) S FHRMB=$P($G(^FHPT(FHDFN,"OP",FHFIN,0)),U,18)
15 .I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S RM=$P(^DG(405.4,FHRMB,0),U,1)
16 .F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF)) Q:FHTF'>0 D
17 ..Q:'$D(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF,0))
18 ..S YY=$G(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF,0))
19 ..;
20 ..S TF2=FHTF
21 ..S Z=$G(^FHPT(FHDFN,"OP",FHFIN,0))
22 ..S XY=$G(^FHPT(FHDFN,"OP",FHFIN,3))
23 ..S (Z1,Z2)="",W1=$P(Z,"^",3)
24 ..S P0=$G(^FH(119.6,+W1,0)),Z3=$P(P0,"^",8),WARD=$E($P(P0,"^",1),U,12)
25 ..S CC=$P($G(^FH(119.73,+Z3,0)),"^",1)
26 ..I FHXX="C" S D2=$P(P0,"^",8) I FHP,FHP'=D2 Q
27 ..I FHXX="L" I FHP,FHP'=W1 Q
28 ..S P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
29 ..S TNOD=$S(FHXX="C":"99~"_CC,1:P0_"~"_WARD),CNOD=$S('SUM:TNOD,1:"0")
30 ..;
31 ..I FHOPT=3 D
32 ...S CTR=$G(^TMP($J,"C",CNOD,0))
33 ...;I "^^^^"[FHOR S:Z2 $P(CTR,"^",1)=$P(CTR,"^",1)+1 S:Z2 $P(CTR,"^",3)=$P(CTR,"^",3)+1
34 ...S $P(CTR,"^",1)=$P(CTR,"^",1)+1
35 ...;I "^^^^"'[FHOR,Z1="T" S:'Z2 $P(CTR,"^",2)=$P(CTR,"^",2)+1 S:Z2 $P(CTR,"^",4)=$P(CTR,"^",4)+1
36 ...S ^TMP($J,"C",CNOD,0)=CTR Q
37 ..;
38 ..S TP=$P(YY,"^",4) D PREP
39 ..;set ^tmp global for specific report.
40 ..D PATNAME^FHOMUTL
41 ..S PNOD=P0_"~"_WARD_"~"_FHDFN
42 ..I "135"[FHOPT S:'$D(^TMP($J,"C",CNOD,TUN,0)) ^(0)="" S $P(^(0),"^",1)=$P(^(0),"^",1)+TU,$P(^(0),"^",2)=$P(^(0),"^",2)+1
43 ..I "124"[FHOPT D
44 ...S:'$D(^TMP($J,"T",TNOD,PNOD,0)) ^(0)=$E(FHPTNM,1,22)_"^"_FHBID_"^"_WARD_"^"_RM_"^"_$P(XY,"^",1,3)
45 ...S ^TMP($J,"T",TNOD,PNOD,TF2,0)=$P(Y0,"^",1)_"^"_$P(Y0,"^",2)_"^"_TP_"^"_TW_"^"_TU_"^"_P1_"^"_STR_"^"_QUA_"^"_TUN
46 ;
47PRT ;prints corresponding reports.
48 I FHOPT=1 D PREP^FHORT5B,PULL^FHORT5C,DEL^FHORT5C Q
49 I FHOPT=2 D PREP^FHORT5B Q
50 I FHOPT=3 D CST^FHORT5D Q
51 I FHOPT=4 D LAB^FHORT5D Q
52 I FHOPT=5 D PULL^FHORT5C
53 Q
54Q2 S Z=$G(^FHPT(FHDFN,"A",ADM,0)),WARD=$P(Z,"^",8) S:WARD WARD=$P($G(^FH(119.6,WARD,0)),"^",1) I WARD="" G Q3
55 G:'$D(^DPT(DFN,.1)) Q3 S CADM=$G(^DPT("CN",^DPT(DFN,.1),DFN)) G:ADM'=CADM Q3
56 S TF=$P(Z,"^",4) G:TF<1 Q3
57 S Z1=$P(Z,"^",5),Z2=$P(Z,"^",7),W1=$P(Z,"^",8),P0=$G(^FH(119.6,+W1,0)),Z3=$P(P0,"^",8),CC=$P($G(^FH(119.73,+Z3,0)),"^",1)
58 I FHXX="C" S D2=$P(P0,"^",8) I FHP,FHP'=D2 Q
59 I FHXX="L" I FHP,FHP'=W1 Q
60 S P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
61 S TNOD=$S(FHXX="C":"99~"_CC,1:P0_"~"_WARD),CNOD=$S('SUM:TNOD,1:"0")
62 D CUR^FHORD7 I FHLD="P" Q
63 I FHOPT=3 D
64 .S CTR=$G(^TMP($J,"C",CNOD,0))
65 .I "^^^^"[FHOR S:'Z2 $P(CTR,"^",1)=$P(CTR,"^",1)+1 S:Z2 $P(CTR,"^",3)=$P(CTR,"^",3)+1
66 .I "^^^^"'[FHOR,Z1="T" S:'Z2 $P(CTR,"^",2)=$P(CTR,"^",2)+1 S:Z2 $P(CTR,"^",4)=$P(CTR,"^",4)+1
67 .S ^TMP($J,"C",CNOD,0)=CTR Q
68 I "124"[FHOPT D
69 .S RM=$G(^DPT(DFN,.101))
70 .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
71 .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
72 .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
73 .S PNOD=P0_"~"_R0_RM_"~"_DFN,X=^DPT(DFN,0) D PID^FHDPA
74 .S XY=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
75 .S ^TMP($J,"T",TNOD,PNOD,0)=$E($P(X,"^",1),1,22)_"^"_BID_"^"_WARD_"^"_RM_"^"_$P(XY,"^",5,7) Q
76 F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 S YY=^(TF2,0) D LP
77 Q
78LP S TP=$P(YY,"^",4) D PREP
79 I "135"[FHOPT S:'$D(^TMP($J,"C",CNOD,TUN,0)) ^(0)="" S $P(^(0),"^",1)=$P(^(0),"^",1)+TU,$P(^(0),"^",2)=$P(^(0),"^",2)+1
80 I "124"[FHOPT S ^TMP($J,"T",TNOD,PNOD,TF2,0)=$P(Y0,"^",1)_"^"_$P(Y0,"^",2)_"^"_TP_"^"_TW_"^"_TU_"^"_P1_"^"_STR_"^"_QUA_"^"_TUN
81 Q
82Q3 K ^FHPT("ADTF",FHDFN,ADM)
83 I $D(^FHPT(FHDFN,"A",ADM,0)) S TF=$P(^(0),"^",4),$P(^(0),"^",4)="" I TF>0,$D(^FHPT(FHDFN,"A",ADM,"TF",TF,0)) S $P(^(0),"^",11)=NOW,ORIFN=$P(^(0),"^",14) I ORIFN S ORSTS=1 D ST^ORX
84 Q
85PREP ; Calculate Preparation
86 S TUN=$P(YY,"^",1),Y0=$G(^FH(118.2,TUN,0)) Q:Y0=""
87 S STR=$P(YY,"^",2),QUA=$P(YY,"^",3)
88 I QUA["CC" S QUAFI=$P(QUA,"CC",1),QUASE=$P(QUA,"CC",2),QUA=QUAFI_"ML"_QUASE
89 I $E($P(Y0,"^",3),$L($P(Y0,"^",3)))="G" D GRM Q
90 S TU=$P(YY,"^",4)/$S(+$P(Y0,"^",3):+$P(Y0,"^",3),1:9999),TW=$P(YY,"^",5)
91 ;I TW<6 S TP="",TW="",TU=TU+.75\1,P1=TU Q ;NOIS MWV-0303-21626
92 I TW<6 S TP="",TW="",(TU,P1)=TU+.9999\1 Q
93 S TU=TU+.2*4\1/4,TP=$J(TP/10,0)*10,TW=$J(TW/10,0)*10
94 S P1=$S(TU<1:"",1:TU\1) I TU#1 S:P1 P1=P1_"-" S P2=TU#1,P1=P1_$S(P2<.3:"1/4",P2<.6:"1/2",1:"3/4")
95 Q
96GRM ; Calculate Gram
97 S TW=0,X=QUA D FIX^FHORT10 S Z5="" F L=1:1:$L(X) I $E(X,L)'=" " S Z5=Z5_$E(X,L)
98 S Z5=$P(Z5,"/",2),Z5=$P(Z5,"X",2)
99 I 'Z5 S Z5=$P("1,24,2,3,12,8,6,4",",",K) G G1
100 I Z5'["F" S Z5=$S(K=1:1,K=2:Z5,K=3:2,K=4:3,K=5:Z5\2,K=6:Z5\3,K=7:Z5\4,1:Z5\6)
101 E S:K=1 Z5=1
102G1 S TU=+QUA*Z5
103 S TU=TU/$S(+$P(Y0,"^",3):+$P(Y0,"^",3),1:9999)
104 ;S P1=$S(TU<1:"",1:TU\1) I P1="" S TU=TU+.95\1,P1=TU
105 S P1=$S(TU<1:"",1:TU\1)
106 I P1="" S TU=TU+.999\1,P1=TU
107 E S TU=TU+.999\1
108 I TU#1 S:P1 P1=P1_"-" S TU=TU#1,P1=P1_$S(TU<.3:"1/4",TU<.6:"1/2",1:"3/4")
109 Q
Note: See TracBrowser for help on using the repository browser.