source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHOMTK2.m@ 1800

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

initial load of WorldVistAEHR
File size: 5.4 KB
Line 
1FHOMTK2 ;Hines OIFO/RTK OUTPATIENT MEALS BUILD TRAY TICKETS ;2/11/04 13:45
2 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
3BLD ; Build Tray Ticket list for a patient
4 D GETOPV ; GET OUTPATIENT VARIABLES - FHDIET, FHLOC, FHLOCNM
5 I FHDIET=""!(FHLOC="") W !!,"NO DIET OR NO NUTRITION LOCATION!" Q
6 S FHOR=FHDIET F ZZZ=1:1:4 I $L(FHOR,"^")<5 S FHOR=FHOR_"^"
7 I FHMEAL'=MEAL Q
8 ; SVC (SERVICE), IS (ISOLATION/PRE), FHD (D/T TICKET LAST PRINTED),
9 ; PD (PRODUCTION DIET), SP (TRAY SERVICE PT), SP1 (CAF SERVICE PT)
10 S SVC="T",SX=$E($P($G(^FH(119.6,FHLOC,0)),U,10),1) I "TCD"[SX S SVC=SX
11 S SP=$P($G(^FH(119.6,FHLOC,0)),U,5),SP1=$P($G(^FH(119.6,FHLOC,0)),U,6)
12 S FHPAR=$P($G(^FH(119.6,FHLOC,0)),U,24)
13 S IS=$P($G(^FHPT(FHDFN,0)),U,5)
14 I FHPAR'="Y" Q:SVC="C"
15 I SVC="C" S:SP'=SP1 SP=SP1 Q:'SP
16 I IS S IS=$G(^FH(119.4,+IS,0)) S:IS'="" SVC=SVC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
17 I FHOMTYP="R" D
18 .S SF=""
19 .I $D(^FHPT(FHDFN,"OP",FHRNUM,"SF",0)) S SF=$P(^(0),U,3)
20 .I SF,$D(^FHPT(FHDFN,"OP",FHRNUM,"SF",SF,0)),'$P(^(0),U,32) S SVC=SVC_" "_"SF"_"("_$S($P($G(^FHPT(FHDFN,"OP",FHRNUM,"SF",SF,0)),"^",34)="Y":"M",1:"I")_")"
21 K FP,MP,N2,NN,P4,PS
22 S DPAT=$O(^FH(111.1,"AB",FHOR,0)) I DPAT="" S FHPDT1=$P(FHDIET,U,1),PD=$P($G(^FH(111,FHPDT1,0)),U,5) ;set Prod Diet so no INV DIET PATTERN for OP's
23 I DPAT S PD=$P($G(^FH(111.1,DPAT,0)),"^",7) I $O(MP(""))="" F X8=0:0 S X8=$O(^FH(111.1,DPAT,MEAL,X8)) Q:X8<1 S Z1=$G(^(X8,0)),MP(+Z1)=$P(Z1,"^",2)
24 Q:PD="" S PD=$P($G(^FH(116.2,PD,0)),"^",2) Q:PD="" D CHK^FHMTK1B
25 I $G(NBR)=3 D PRT^FHMTK1C K MM,PP,S S NBR=0
26 S NBR=$G(NBR)+1 ;D PID^FHDPA
27 F X6=0:0 S X6=$O(^FHPT(FHDFN,"P","B",X6)) Q:X6<1 F X7=0:0 S X7=$O(^FHPT(FHDFN,"P","B",X6,X7)) Q:X7<1 S PS=$P($G(^FH(115.2,+X6,0)),"^",4) I PS S P4=$G(^FH(114,+PS,0)),P1=$P(P4,"^",7)_"^"_+PS_"^"_$P(P4,"^",1) I +P1 D
28 .S CHK="" F S CHK=$O(^TMP($J,"DEF",MEAL,PD,CHK)) Q:CHK="" S C1=$G(^(CHK)) I $D(^TMP($J,"FHDEF",MEAL,+C1)),+^TMP($J,"FHDEF",MEAL,+C1)=+P1 D Q
29 ..S C2=$G(^FHPT(FHDFN,"P",+X7,0)) Q:$P(C2,"^",2)'[MEAL
30 ..S P2=+CHK,P3=$P(P1,"^",3) S:'$D(N2(P2,+C1,P3)) N2(P2,+C1,P3)=+$P(P1,"^",2)_"^"_P3 Q
31 .Q
32 S Y0=FHPTNM_" ("_FHBID_")"_" "_SVC,S(NBR)=0,N1=0
33 S N1=N1+1 I $L(Y)<40 S PP(N1,NBR)=Y
34 E S L=$S($L($P(Y,",",1,3))<40:3,1:2) S PP(N1,NBR)=$P(Y,",",1,L),N1=N1+1,PP(N1,NBR)=$E($P(Y,",",L+1,5),2,99)
35 S MM(0,NBR)=Y0_"^"_FHLOCNM_"^"_FHRMBNM_"^^^^"_FHMEAL
36 D ALG^FHCLN S ALG="ALLGS.: "_$S(ALG="":"NONE ON FILE",1:ALG) S J=0 D BRK^FHMTK1B
37 S X8="" F S X8=$O(^TMP($J,MEAL,PD,X8)) Q:X8="" S (P4,X1)=^(X8),X1=+X1,P4=$P(P4,"^",3) D
38 .S Z1=+$P(X8,"~",2) Q:'$F(P4,"~"_SP_"~")
39 .S (MSG,X6)="",CTR=1
40 .S QTY="" Q:'$D(MP(Z1)) Q:MP(Z1)=0 S PAD=$E(" ",1,5-$L(MP(Z1))),QTY=MP(Z1)_PAD,CTR=$J(MP(Z1),0,2)
41 .S:$G(^TMP($J,"FHPO",$P(X8,"~",3)))="" ^TMP($J,"FHPO",$P(X8,"~",3))=X8 S C2=$G(^TMP($J,"FHPO",$P(X8,"~",3)))
42 .I $D(N2(Z1,X1)) D BRD Q
43 .I $D(FP(+X1)) D SUB Q
44 .S NN(X8)=QTY_$P(X8,"~",3) D CNT
45 .I $D(^TMP($J,"DBX",MEAL,PD,+X1)) F LL=0:0 S LL=$O(^TMP($J,"DBX",MEAL,PD,+X1,LL)) Q:LL<1 S NN(X8_" "_LL)=$G(^(LL))
46 .Q
47 S X8="" F S X8=$O(NN(X8)) Q:X8="" D
48 .S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$G(NN(X8)) Q
49 S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=""
50 S ADM="" I $G(FHRNUM)'="" S ADM=FHRNUM D SOUT^FHMTK1B ; get op stnd ords
51 D NOW^%DTC S (DTP,TIM)=% D DTP^FH S HD=DTP
52 S DTP=D1 D DTP^FH S MDT=DTP
53 I FHOMTYP="G" Q ;if not GM set D/T ticket last printed
54 I FHOMTYP="R" D NOW^%DTC S $P(^FHPT(FHDFN,"OP",FHRNUM,0),U,13)=%
55 I FHOMTYP="S" D NOW^%DTC S $P(^FHPT(FHDFN,"SM",FHOMDT,0),U,10)=%
56 Q
57SUB ; Get Substitutes
58 D ALT^FHMTK1B S:MSG'="" NN(X8)=MSG Q:'X6
59 S X1=+X6,XX=Z,Z1=$P(XX,"~",2) I $D(N2(Z1,X1)) D BRD Q
60 S:$D(^TMP($J,"FHPO",$P(XX,"~",3))) XX=$G(^TMP($J,"FHPO",$P(XX,"~",3)))
61 S NN(XX)=QTY_$P(XX,"~",3)
62 S CT=$G(^TMP($J,"CTR",MEAL,XX,SP))
63 S CT=CT+CTR,^TMP($J,"CTR",MEAL,XX,SP)=CT D C1
64 I SUM S TOT=$G(^TMP($J,"TOT",XX,SP)),TOT=TOT+CTR,^TMP($J,"TOT",XX,SP)=TOT
65 I $D(^TMP($J,"DBX",MEAL,PD,+X1)) F LL=0:0 S LL=$O(^TMP($J,"DBX",MEAL,PD,+X1,LL)) Q:LL<1 S NN(XX_" "_LL)=$G(^(LL))
66 Q
67BRD ; Get Bread/Beverage
68 S (X7,XX)="" F S X7=$O(N2(Z1,X1,X7)) Q:X7="" D
69 .S L1=+N2(Z1,X1,X7),XX=$P(X8,"~",1,2)_"~"_X7
70 .I '$D(NN(XX)) S NN(XX)=QTY_X7 S CT=$G(^TMP($J,"CTR",MEAL,XX,SP)),CT=CT+CTR,^TMP($J,"CTR",MEAL,XX,SP)=CT D C1 I SUM S TOT=$G(^TMP($J,"TOT",XX,SP)),TOT=TOT+CTR,^TMP($J,"TOT",XX,SP)=TOT
71 .Q
72 Q
73CNT ; Count Recipe items for Service Points
74 S CT=$G(^TMP($J,"CTR",MEAL,C2,SP)),CT=CT+CTR,^TMP($J,"CTR",MEAL,C2,SP)=CT
75 I SUM S TOT=$G(^TMP($J,"TOT",C2,SP)),TOT=TOT+CTR,^TMP($J,"TOT",C2,SP)=TOT
76C1 ; Setup Service Points Array
77 S M1=$G(^TMP($J,"SRP",SP)),M2=$P(M1,"^",1),M3=$P(M1,"^",4)
78 S:M3="" M3=$E(M2,1,8) I '$D(DP(MEAL,M3,SP)) S DP(MEAL,M3,SP)=$J(M3,10),LS(MEAL)=LS(MEAL)+10,P(MEAL,M3,SP)=""
79 I SUM,'$D(TP(M3,SP)) S TP(M3,SP)=$J(M3,10),SL=SL+10,T1(M3,SP)=""
80 Q
81GETOPV ; Get outpatient variables
82 I FHOMTYP="R" D
83 .S FHDIET=$P(FHZN,U,2),FHRMBD=$P(FHZN,U,18)
84 .I $P($G(^FH(119.6,FHLOC,1)),U,4)="Y" S FHDIET=$P(FHZN,U,7,11)
85 .S FHLOC=$P(FHZN,U,3),FHMEAL=$P(FHZN,U,4),FHD=$P(FHZN,U,13)
86 I FHOMTYP="S" D
87 .S FHDIET=$P(FHZN,U,4),FHRMBD=$P(FHZN,U,13)
88 .S FHLOC=$P(FHZN,U,3),FHMEAL=$P(FHZN,U,9),FHD=$P(FHZN,U,10)
89 I FHOMTYP="G" D
90 .S FHDIET=$P(FHZN,U,6),FHRMBD=$P(FHZN,U,11)
91 .S FHLOC=$P(FHZN,U,5),FHMEAL=$P(FHZN,U,3),FHD=$P(FHZN,U,7)
92 I FHDIET=""!(FHLOC="") Q
93 S FHLD="" ;no WITHHOLD for outpatients
94 S Y="" F A1=1:1:5 S D3=$P(FHDIET,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7) ;set Y = diet text
95 D PATNAME^FHOMUTL
96 S FHLOCNM=$P($G(^FH(119.6,FHLOC,0)),U,1) ;set location name
97 S FHRMBNM=""
98 I FHRMBD'="" S FHRMBNM=$P($G(^DG(405.4,FHRMBD,0)),U,1) ;set room-bed nm
99 Q
Note: See TracBrowser for help on using the repository browser.