Changeset 623 for WorldVistAEHR/trunk/r/DIETETICS-FH/FHNO2.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DIETETICS-FH/FHNO2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DIETETICS-FH/FHNO2.m
r613 r623 1 FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01 2 ;;5.5;DIETETICS;**5,13**;Jan 28, 2005;Build 1 3 ;patch #5 - add outpatient SFs. 4 D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL I "sw"[XX S X=XX D TR^FH S XX=X 5 I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0 6 I XX="S" S D1=$O(^FH(119.74,0)) I D1'<1,$O(^FH(119.74,D1))<1 G D3 7 I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G D3 8 I XX="S" G D2 9 D1 R !!,"Select WARD: ",X:DTIME G:'$T!("^"[X) KIL 10 K DIC S DIC="^FH(119.6,",DIC(0)="EMQ" D ^DIC G:Y<1 D1 S W1=+Y 11 S D1=$P($G(^FH(119.6,W1,0)),"^",9) G D3 12 D2 R !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME G:'$T!("^"[X) KIL 13 K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S D1=+Y,W1=0 14 D3 R !!,"Select Supplemental Feeding Time (10,2,8,ALL): ",TIM:DTIME G KIL:'$T!(U[TIM) I TIM="all" S X=TIM D TR^FH S TIM=X 15 I TIM'=2,TIM'=8,TIM'=10,TIM'="ALL" W *7," Enter a time, 10,2,8, or ALL" G D3 16 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR 17 Q:$D(DIRUT) S LABSTART=Y 18 D4 R !!,"Do you want Ingredient list only? N// ",D3:DTIME G:'$T!(D3="^") KIL S:D3="" D3="N" S X=D3 D TR^FH S D3=X I $P("YES",D3,1)'="",$P("NO",D3,1)'="" W *7," Answer YES or NO" G D4 19 S D3=$E(D3,1),D3=D3="Y" G:'D3 D6 20 D5 R !!,"Consolidated List only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G D5 21 S X=$E(X,1) S:X="Y" D3=D3+1 22 D6 I 'D3,'D1,XX="L" W !!,"No Supplemental Feeding Site associated with this location." G KIL 23 W:'D3 !!,"Place Labels in Printer" 24 PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL 25 I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^D3^LABSTART" D EN2^FH G KIL 26 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL 27 Q1 ; Process Printing Supplemental Feeding Labels 28 S TIMSAV=TIM 29 D NOW^%DTC S NOW=%,DT=%\1 G:D3=2 SUM 30 I 'D3 Q:'D1 S FHPAR=$G(^FH(119.74,D1,0)),LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 31 S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8 32 D Q2 33 I $G(LAB)>2 D DPLL^FHLABEL,KIL Q 34 I 'D3 F L=1:1:18 W ! 35 KIL K ^TMP($J) G KILL^XUSCLEAN 36 Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT,".",1)_"."_$S(TIM=10:1,TIM=2:14,1:2),P3=7,N1=0 37 I XX="W" S P0=$P($G(^FH(119.6,W1,0)),"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 38 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 39 D SF0 40 G ^FHNO21:'D3,PRT 41 F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 42 F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 43 G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 44 I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 45 D CHK G:'NO F1 46 S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) 47 S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC 48 I 'D3 D 49 .D PATNAME^FHOMUTL I DFN="" Q 50 .S $P(Y,"^",9)=IS 51 .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 52 .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 53 .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 54 .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 55 .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM 56 .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q 57 G F1 58 Q 59 ; 60 CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 61 I X1>1,X1'>T0 G C2 62 C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 63 S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" 64 C1 K FHORD,A1,K,X1 Q 65 C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K 66 G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2 67 SUM K C,^TMP($J,"SF") S P0=$S(TIM=2:13,TIM=8:21,1:5),P3=$S(TIM="ALL":23,1:7),N1=0 68 I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 69 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 D S0 70 D SF0 71 G PRT 72 S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 73 S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 74 G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 75 S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC 76 G S1 77 PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") 78 S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) 79 W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! 80 F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S:$D(C(L)) ^TMP($J,"SF",$P($G(^FH(118,L,0)),"^",1),L)="" 81 S A1="" F S A1=$O(^TMP($J,"SF",A1)) Q:A1="" F L=0:0 S L=$O(^TMP($J,"SF",A1,L)) Q:L<1 W !,$E(A1,1,26),?28,$J(C(L),5,0) 82 W !!?4,"**** PATIENTS = ",N1," ****",! Q 83 CALC S N1=N1+1 84 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 85 Q 86 ; 87 SF0 ;outpatient SFs 88 F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F ADM=0:0 S ADM=$O(^FHPT("RM",DT,FHDFN,ADM)) Q:ADM'>0 D 89 .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) 90 .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) 91 .S X1=$G(^FH(119.6,FHOWARD,0)) 92 .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) 93 .I XX="W",W1 Q:W1'=FHOWARD 94 .S WRDN=$P(X1,U,1) 95 .I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2 I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) 96 .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) 97 .I (FHMEAL="B"),(TIM'=10) Q 98 .I (FHMEAL="N"),(TIM'=2) Q 99 .I (FHMEAL="E"),(TIM'=8) Q 100 .I 'D3 S IS=$P($G(^FHPT(FHDFN,0)),"^",5) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 101 .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) 102 .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 103 .S N1=N1+1 104 .S RM="",RMIEN=$P(FHODAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10) 105 .I 'D3 D 106 ..D PATNAME^FHOMUTL 107 ..S $P(Y,"^",9)=IS 108 ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 109 ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 110 ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 111 ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 112 ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM 113 ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD 114 Q 115 CLC1 ; 116 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 117 Q 1 FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01 2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53 3 ;patch #5 - add outpatient SFs. 4 D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL I "sw"[XX S X=XX D TR^FH S XX=X 5 I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0 6 I XX="S" S D1=$O(^FH(119.74,0)) I D1'<1,$O(^FH(119.74,D1))<1 G D3 7 I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G D3 8 I XX="S" G D2 9 D1 R !!,"Select WARD: ",X:DTIME G:'$T!("^"[X) KIL 10 K DIC S DIC="^FH(119.6,",DIC(0)="EMQ" D ^DIC G:Y<1 D1 S W1=+Y 11 S D1=$P($G(^FH(119.6,W1,0)),"^",9) G D3 12 D2 R !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME G:'$T!("^"[X) KIL 13 K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S D1=+Y,W1=0 14 D3 R !!,"Select Supplemental Feeding Time (10,2,8,ALL): ",TIM:DTIME G KIL:'$T!(U[TIM) I TIM="all" S X=TIM D TR^FH S TIM=X 15 I TIM'=2,TIM'=8,TIM'=10,TIM'="ALL" W *7," Enter a time, 10,2,8, or ALL" G D3 16 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR 17 Q:$D(DIRUT) S LABSTART=Y 18 D4 R !!,"Do you want Ingredient list only? N// ",D3:DTIME G:'$T!(D3="^") KIL S:D3="" D3="N" S X=D3 D TR^FH S D3=X I $P("YES",D3,1)'="",$P("NO",D3,1)'="" W *7," Answer YES or NO" G D4 19 S D3=$E(D3,1),D3=D3="Y" G:'D3 D6 20 D5 R !!,"Consolidated List only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G D5 21 S X=$E(X,1) S:X="Y" D3=D3+1 22 D6 I 'D3,'D1,XX="L" W !!,"No Supplemental Feeding Site associated with this location." G KIL 23 W:'D3 !!,"Place Labels in Printer" 24 PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL 25 I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^D3^LABSTART" D EN2^FH G KIL 26 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL 27 Q1 ; Process Printing Supplemental Feeding Labels 28 S TIMSAV=TIM 29 D NOW^%DTC S NOW=%,DT=%\1 G:D3=2 SUM 30 I 'D3 Q:'D1 S FHPAR=$G(^FH(119.74,D1,0)),LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 31 S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8 32 D Q2 33 I $G(LAB)>2 D DPLL^FHLABEL,KIL Q 34 I 'D3 F L=1:1:18 W ! 35 KIL K ^TMP($J) G KILL^XUSCLEAN 36 Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT,".",1)_"."_$S(TIM=10:1,TIM=2:14,1:2),P3=7,N1=0 37 I XX="W" S P0=$P($G(^FH(119.6,W1,0)),"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 38 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 39 D SF0 40 G ^FHNO21:'D3,PRT 41 F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 42 F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 43 G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 44 I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 45 D CHK G:'NO F1 46 S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) 47 S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC 48 I 'D3 D 49 .D PATNAME^FHOMUTL I DFN="" Q 50 .S $P(Y,"^",9)=IS 51 .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 52 .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 53 .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 54 .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 55 .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM 56 .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q 57 G F1 58 Q 59 ; 60 CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 61 I X1>1,X1'>T0 G C2 62 C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 63 S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" 64 C1 K FHORD,A1,K,X1 Q 65 C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K 66 G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2 67 SUM K C,^TMP($J,"SF") S P0=$S(TIM=2:13,TIM=8:21,1:5),P3=$S(TIM="ALL":23,1:7),N1=0 68 I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 69 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 D S0 70 D SF0 71 G PRT 72 S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 73 S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 74 G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 75 S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC 76 G S1 77 PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") 78 S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) 79 W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! 80 F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S:$D(C(L)) ^TMP($J,"SF",$P($G(^FH(118,L,0)),"^",1),L)="" 81 S A1="" F S A1=$O(^TMP($J,"SF",A1)) Q:A1="" F L=0:0 S L=$O(^TMP($J,"SF",A1,L)) Q:L<1 W !,$E(A1,1,26),?28,$J(C(L),5,0) 82 W !!?4,"**** PATIENTS = ",N1," ****",! Q 83 CALC S N1=N1+1 84 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 85 Q 86 ; 87 SF0 ;outpatient SFs 88 F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F ADM=0:0 S ADM=$O(^FHPT("RM",DT,FHDFN,ADM)) Q:ADM'>0 D 89 .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) 90 .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) 91 .S X1=$G(^FH(119.6,FHOWARD,0)),WRDN=$P(X1,U,1) 92 .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) 93 .I XX="W",W1 Q:W1'=FHOWARD 94 .I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2 I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) 95 .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) 96 .I (FHMEAL="B"),(TIM'=10) Q 97 .I (FHMEAL="N"),(TIM'=2) Q 98 .I (FHMEAL="E"),(TIM'=8) Q 99 .I 'D3 S IS=$P($G(^FHPT(FHDFN,0)),"^",5) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 100 .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) 101 .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 102 .S N1=N1+1 103 .S RM="",RMIEN=$P(FHODAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10) 104 .I 'D3 D 105 ..D PATNAME^FHOMUTL 106 ..S $P(Y,"^",9)=IS 107 ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 108 ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 109 ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 110 ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 111 ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM 112 ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD 113 Q 114 CLC1 ; 115 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 116 Q
Note:
See TracChangeset
for help on using the changeset viewer.
