source: FOIAVistA/tag/r/DIETETICS-FH/FHMTK11.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 4.4 KB
Line 
1FHMTK11 ; HISC/REL/NCA - Build Tray Tickets (Cont.) ;2/23/00 09:53
2 ;;5.5;DIETETICS;;Jan 28, 2005
3BLD ; Build Tray Ticket list for a patient
4 S X1=$G(^FHPT(+FHDFN,"A",+ADM,0)),FHORD=$P(X1,"^",2),SVC=$P(X1,"^",5),SF=$P(X1,"^",7),IS=$P(X1,"^",10),FHD=$P(X1,"^",15),(FHOR,X)=""
5 I FHPAR'="Y" Q:SVC="C"
6 I SVC="C" S:SP'=SP1 SP=SP1 Q:'SP
7 Q:'FHORD S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
8 S PD=$P(X,"^",13),FHOR=$P(X,"^",2,6) Q:"^^^^"[FHOR
9 I IS S IS=$G(^FH(119.4,+IS,0)) S:IS'="" SVC=SVC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
10 S:SF SVC=SVC_" "_"SF"_"("_$S($P($G(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
11 I UPD D OLD I OLD=FHOR S FLG2=0 D EVT^FHDCR2 Q:'FLG2
12 S STR=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2)) K FP,MP,N2,NN,P4,PS D:STR'="" DECOD^FHMTK1B
13 S DPAT=$O(^FH(111.1,"AB",FHOR,0))
14 I DPAT S PD=$P($G(^FH(111.1,DPAT,0)),"^",7) I STR="",$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)
15 Q:PD="" S PD=$P($G(^FH(116.2,PD,0)),"^",2) Q:PD="" D CHK^FHMTK1B
16 I NBR=3 D PRT^FHMTK1C K MM,PP,S S NBR=0
17 S NBR=NBR+1 D PID^FHDPA
18 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
19 .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
20 ..S C2=$G(^FHPT(FHDFN,"P",+X7,0)) Q:$P(C2,"^",2)'[MEAL
21 ..S P2=+CHK,P3=$P(P1,"^",3) S:'$D(N2(P2,+C1,P3)) N2(P2,+C1,P3)=+$P(P1,"^",2)_"^"_P3 Q
22 .Q
23 S Y0=$P($G(^DPT(DFN,0)),"^",1)_" ("_BID_")"_" "_SVC,S(NBR)=0,N1=0
24 D CUR^FHORD7 S N1=N1+1 I $L(Y)<40 S PP(N1,NBR)=Y
25 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)
26 S MM(0,NBR)=Y0_"^"_WRDN_"^"_RM
27 I $G(DFN) D ALG^FHCLN S ALG="ALLGS.: "_$S(ALG="":"NONE ON FILE",1:ALG) S J=0 D BRK^FHMTK1B
28 S X8="" F S X8=$O(^TMP($J,MEAL,PD,X8)) Q:X8="" S (P4,X1)=^(X8),X1=+X1,P4=$P(P4,"^",3) D
29 .S Z1=+$P(X8,"~",2) Q:'$F(P4,"~"_SP_"~")
30 .S (MSG,X6)="",CTR=1
31 .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)
32 .S:$G(^TMP($J,"FHPO",$P(X8,"~",3)))="" ^TMP($J,"FHPO",$P(X8,"~",3))=X8 S C2=$G(^TMP($J,"FHPO",$P(X8,"~",3)))
33 .I $D(N2(Z1,X1)) D BRD Q
34 .I $D(FP(+X1)) D SUB Q
35 .S NN(X8)=QTY_$P(X8,"~",3) D CNT
36 .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))
37 .Q
38 S X8="" F S X8=$O(NN(X8)) Q:X8="" D
39 .S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$G(NN(X8)) Q
40 S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=""
41 D SO^FHMTK1B
42 Q
43SUB ; Get Substitutes
44 D ALT^FHMTK1B S:MSG'="" NN(X8)=MSG Q:'X6
45 S X1=+X6,XX=Z,Z1=$P(XX,"~",2) I $D(N2(Z1,X1)) D BRD Q
46 S:$D(^TMP($J,"FHPO",$P(XX,"~",3))) XX=$G(^TMP($J,"FHPO",$P(XX,"~",3)))
47 S NN(XX)=QTY_$P(XX,"~",3)
48 S CT=$G(^TMP($J,"CTR",MEAL,XX,SP))
49 S CT=CT+CTR,^TMP($J,"CTR",MEAL,XX,SP)=CT D C1
50 I SUM S TOT=$G(^TMP($J,"TOT",XX,SP)),TOT=TOT+CTR,^TMP($J,"TOT",XX,SP)=TOT
51 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))
52 Q
53BRD ; Get Bread/Beverage
54 S (X7,XX)="" F S X7=$O(N2(Z1,X1,X7)) Q:X7="" D
55 .S L1=+N2(Z1,X1,X7),XX=$P(X8,"~",1,2)_"~"_X7
56 .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
57 .Q
58 Q
59CNT ; Count Recipe items for Service Points
60 S CT=$G(^TMP($J,"CTR",MEAL,C2,SP)),CT=CT+CTR,^TMP($J,"CTR",MEAL,C2,SP)=CT
61 I SUM S TOT=$G(^TMP($J,"TOT",C2,SP)),TOT=TOT+CTR,^TMP($J,"TOT",C2,SP)=TOT
62C1 ; Setup Service Points Array
63 S M1=$G(^TMP($J,"SRP",SP)),M2=$P(M1,"^",1),M3=$P(M1,"^",4)
64 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)=""
65 I SUM,'$D(TP(M3,SP)) S TP(M3,SP)=$J(M3,10),SL=SL+10,T1(M3,SP)=""
66 Q
67OLD ; Get Previous Diet Order
68 S:'FHD FHD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",1)
69 S E1="" F NXT=0:0 S NXT=$O(^FHPT(FHDFN,"A",ADM,"AC",NXT)) Q:NXT<1!(NXT>FHD) S E1=NXT
70 I 'E1 S OLD="^^^^" Q
71 S KK=$P($G(^FHPT(FHDFN,"A",ADM,"AC",E1,0)),"^",2) I 'KK S OLD="^^^^" Q
72 S NNXX="" I NXT'="" S NNXX=$P($G(^FHPT(FHDFN,"A",ADM,"AC",NXT,0)),"^",2)
73 I NNXX'="",$P($G(^FHPT(FHDFN,"A",ADM,"DI",NNXX,0)),U,10)=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),U,9),$P($G(^FHPT(FHDFN,"A",ADM,"DI",NNXX,0)),U,7)="N" S OLD="^^^^" Q
74 S OLD=$P($G(^FHPT(FHDFN,"A",ADM,"DI",KK,0)),"^",2,6) Q
Note: See TracBrowser for help on using the repository browser.