- FHORE21 ; HISC/REL/NCA - List Early/Late Trays (cont) ;11/9/94 13:33
- ;;5.5;DIETETICS;**5,8,15**;Jan 28, 2005;Build 2
- ;patch #5 - added outpt room-bed.
- S D1=DTE,COUNT=0,LINE=1 K ^TMP($J) S ANS=""
- F2 S D1=$O(^FHPT("ADLT",D1)) G:D1<1!(D1\1'=DTE) P0 S FHDFN=0
- F3 S FHDFN=$O(^FHPT("ADLT",D1,FHDFN)) G:FHDFN<1 F2 S ADM=0
- F4 S ADM=$O(^FHPT("ADLT",D1,FHDFN,ADM)) G:ADM<1 F3
- I $S($D(^DGPM(ADM,0)):$P(^(0),"^",17),1:1) G F7
- S Y(0)=$G(^FHPT(FHDFN,"A",ADM,"EL",D1,0)) G:Y(0)="" F7
- S X=$G(^FHPT(FHDFN,"A",ADM,0)),OLW=$P(X,"^",11),IS=$P(X,"^",10)
- S W1=$P(X,"^",8),X2=$G(^FH(119.6,+W1,0)),WARD=$P(X2,"^",1)
- G:WARD="" F4 S P0=$P(X2,"^",8) I FHP,P0'=FHP G F4
- S M1=$P(Y(0),"^",2) I MEAL'="A",M1'=MEAL G F4
- D CUR G:FHLD'="" F4 S O1=Y
- S ^TMP($J,"EL",D1_"-"_$P(Y(0),"^",6),FHDFN_"-"_ADM)=WARD_"^"_P0_"^"_OLW_"^"_IS_"^"_O1_"^"_$P(Y(0),"^",2,4) G F4
- P0 D NOW^%DTC S DTP=% D DTP^FH S H1=DTP,DTP=DTE\1 D DTP^FH S L1=DTP
- I LAB S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1
- S S1=LAB=2*5+36
- P1 S M2="Z",PG=0 D:'LAB HDR
- S N1="" F S N1=$O(^TMP($J,"EL",N1)) Q:N1=""!(ANS="^") S N2="" F S N2=$O(^TMP($J,"EL",N1,N2)) Q:N2="" S Y=^(N2) D P2 Q:ANS="^"
- ;
- D ^FHOMELT ;List Outpatient (Recurring Meals) Late Trays
- I LAB<1 W !!
- S FHPREV="" D:'LAB OPHDR
- F N1="B","N","E" D
- .I '$D(^TMP($J,N1)) Q
- .S N2="" F S N2=$O(^TMP($J,N1,N2)) Q:N2=""!(ANS="^") D
- ..S FHDATA=$G(^TMP($J,N1,N2)),FHLOC=$P(FHDATA,U,1),FHDFN=$P(FHDATA,U,2)
- ..S FHBAG=$P(FHDATA,U,3),(O1,FHDIET)=$P(FHDATA,U,4),RM=$P(FHDATA,U,5) D PATNAME^FHOMUTL
- ..S (WARD,FHLOCNM)=$E($P($G(^FH(119.6,FHLOC,0)),U,1),1,10)
- ..S FHIP=$P($G(^FHPT(FHDFN,0)),U,5),FHIPD="",IS=""
- ..I FHIP'="" S (IS,FHIPD)=$P($G(^FH(119.4,FHIP,0)),U,2)_$P($G(^FH(119.4,FHIP,0)),U,3)
- ..S P1=FHPTNM,BID=FHBID,TIM=$P(N2,"~",1),M1=N1
- ..I LAB<1 D OUTP
- ..I LAB>0,LAB<3 D P3
- ..I LAB>2 D LL Q
- I LAB>2 D DPLL^FHLABEL K ^TMP($J) Q
- I LAB<3 F K=1:1:$S('LAB:1,1:18) W !
- Q
- P2 S FHDFN=+N2,WARD=$P(Y,"^",1),P0=$P(Y,"^",2),OLW=$P(Y,"^",3),IS=$P(Y,"^",4),O1=$P(Y,"^",5),M1=$P(Y,"^",6),TIM=$P(Y,"^",7),BAG=$P(Y,"^",8)
- I IS S IS=^FH(119.4,IS,0),IS=$P(IS,"^",2)_$P(IS,"^",3)
- D PATNAME^FHOMUTL I DFN="" Q
- S Y=^DPT(DFN,0),P1=$P(Y,"^",1) D PID^FHDPA
- S RM=$G(^DPT(DFN,.101)) I LAB>2 D LL Q
- G:LAB P3
- I $Y>(IOSL-10) D HDR Q:ANS="^" W !!?56,$S(M1="B":"Breakfast ",M1="N":" Noon ",1:" Evening "),$J(TIM,6),! S M2=M1_TIM
- S X=M1_TIM I X'=M2 W !!?56,$S(M1="B":"Breakfast ",M1="N":" Noon ",1:" Evening "),$J(TIM,6),! S M2=X
- W !,$S(WARD'="":$E(WARD,1,10),1:"")_$S(RM'="":"/"_$E(RM,1,10),1:""),?24,$E(P1,1,22),?50,BID,?61,$S(IS'="":IS,1:""),?67,$S(BAG="Y":"YES",1:""),?73,O1
- D ALG^FHCLN W !,"Allergies: ",$S(ALG="":"None on file",1:ALG)
- Q
- P3 S P1=$E(P1,1,22),WARD=$E(WARD,1,15),RM=$E(RM,1,10)
- D ALG^FHCLN
- W !,$S(M1="B":"Breakfast",M1="N":" Noon ",1:" Evening"),?10,TIM,?(S1-12),L1 W:LAB=2 !
- W !,$E(P1,1,S1-5-$L(WARD)),?(S1-3-$L(WARD)),WARD
- W !,BID W:IS'="" ?(S1-3\2),IS W ?(S1-3-$L(RM)),RM W:LAB=2 !
- I $L(O1)<S1 W !,O1,$S(ALG="":"",1:" *ALG"),!!
- E S L=$S($L($P(O1,",",1,3))<S1:3,1:2) W !,$P(O1,",",1,L),!,$E($P(O1,",",L+1,5),2,99),$S(ALG="":"",1:"*ALG"),!
- W:LAB=2 ! Q
- OUTP ;
- I $Y>(IOSL-10) D OPHDR Q:ANS="^"
- S NEW=N1_$P(N2,"~",1) I FHPREV'=NEW W !!?56,$S(N1="B":"Breakfast ",N1="N":" Noon ",1:" Evening "),$J($P(N2,"~",1),6),!
- W !,FHLOCNM
- D PATNAME^FHOMUTL W "/"_RM,?24,FHPTNM,?50,FHBID
- W ?61,FHIPD,?67,$S(FHBAG="Y":"YES",1:"")
- W ?73,FHDIET
- D ALG^FHCLN W !,"Allergies: ",$S(ALG="":"None on file",1:ALG)
- S FHPREV=N1_$P(N2,"~",1)
- Q
- F7 K ^FHPT("ADLT",D1,FHDFN,ADM) G F4
- CUR S A1=0,(Y,FHLD,FHOR)="" F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1!(KK>D1) S A1=KK
- Q:'A1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2),X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7)
- I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
- S Y="" F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
- Q
- DP K N S Y=$G(^FH(119.73,+P0,1))
- F KK=1,2,3,7,8,9,13,14,15 S X=$P(Y,"^",KK) I X'="" S N($S(KK<7:"B",KK<13:"N",1:"E"),X)=""
- Q
- HDR ; Print Header (INPATIENT)
- I PG,IOST?1"C-".E R !!,"Press RETURN to continue or ""^"" to exit. ",ANS:DTIME S:'$T!(ANS["^") ANS="^" Q:ANS="^" I "^"'[ANS W !,"Enter Return or ""^""." G HDR
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
- W !?32,"I N P A T I E N T E A R L Y / L A T E T R A Y S",?110,H1
- W !,$S('FHP:"Consolidated",1:$P(^FH(119.73,FHP,0),"^",1)),?61,L1,?121,"Page ",PG
- W !!,"Ward/Room",?24,"Patient",?50,"ID#",?61,"Iso Bag Current-Diet",! Q
- OPHDR ; Print Header (OUTPATIENT)
- I PG,IOST?1"C-".E R !!,"Press RETURN to continue or ""^"" to exit. ",ANS:DTIME S:'$T!(ANS["^") ANS="^" Q:ANS="^" I "^"'[ANS W !,"Enter Return or ""^""." G OPHDR
- W:$E(IOST,1,2)="C-" @IOF S PG=PG+1
- W !?32,"O U T P A T I E N T E A R L Y / L A T E T R A Y S",?110,H1
- W !,$S('FHP:"Consolidated",1:$P(^FH(119.73,FHP,0),"^",1)),?61,L1,?121,"Page ",PG
- W !!,"Ward/Room",?24,"Patient",?50,"ID#",?61,"Iso Bag Current-Diet",! Q
- LL ;
- D ALG^FHCLN
- S FHCOL=$S(LAB=3:3,1:2)
- I LABSTART>1 F FHLABST=1:1:(LABSTART-1)*FHCOL D S LABSTART=1
- .I LAB=3 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)="" D LL3^FHLABEL
- .I LAB=4 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)="" D LL4^FHLABEL
- .Q
- S SL1=$S(LAB=3:25,1:38)
- S MEALTM=$S(M1="B":"Breakfast",M1="N":"Noon",1:"Evening")_" "_TIM
- S BID=BID_$S(ALG="":"",1:" *ALG")
- S BIDIS=BID_$E(" ",1,12-$L(BID))_IS
- S WARD=$E(WARD,1,15),WLN=$L(WARD),RM=$E(RM,1,10)
- I LAB=3 D
- .S P1=$E(P1,1,24-WLN)
- .S (PCL1,PCL6)="",PCL2=MEALTM_$J(L1,25-$L(MEALTM))
- .S PCL3=P1_$J(WARD,25-$L(P1)),PCL4=BIDIS_$J(RM,25-$L(BIDIS))
- .S PCL5=$E(O1,1,29) D LL3^FHLABEL
- I LAB=4 D
- .S P1=$E(P1,1,37-WLN)
- .S (PCL1,PCL2,PCL7,PCL8)="",PCL3=MEALTM_$J(L1,38-$L(MEALTM))
- .S PCL4=P1_$J(WARD,38-$L(P1)),PCL5=BIDIS_$J(RM,38-$L(BIDIS))
- .S PCL6=$E(O1,1,42) D LL4^FHLABEL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORE21 5948 printed Mar 13, 2025@20:58:26 Page 2
- FHORE21 ; HISC/REL/NCA - List Early/Late Trays (cont) ;11/9/94 13:33
- +1 ;;5.5;DIETETICS;**5,8,15**;Jan 28, 2005;Build 2
- +2 ;patch #5 - added outpt room-bed.
- +3 SET D1=DTE
- SET COUNT=0
- SET LINE=1
- KILL ^TMP($JOB)
- SET ANS=""
- F2 SET D1=$ORDER(^FHPT("ADLT",D1))
- if D1<1!(D1\1'=DTE)
- GOTO P0
- SET FHDFN=0
- F3 SET FHDFN=$ORDER(^FHPT("ADLT",D1,FHDFN))
- if FHDFN<1
- GOTO F2
- SET ADM=0
- F4 SET ADM=$ORDER(^FHPT("ADLT",D1,FHDFN,ADM))
- if ADM<1
- GOTO F3
- +1 IF $SELECT($DATA(^DGPM(ADM,0)):$PIECE(^(0),"^",17),1:1)
- GOTO F7
- +2 SET Y(0)=$GET(^FHPT(FHDFN,"A",ADM,"EL",D1,0))
- if Y(0)=""
- GOTO F7
- +3 SET X=$GET(^FHPT(FHDFN,"A",ADM,0))
- SET OLW=$PIECE(X,"^",11)
- SET IS=$PIECE(X,"^",10)
- +4 SET W1=$PIECE(X,"^",8)
- SET X2=$GET(^FH(119.6,+W1,0))
- SET WARD=$PIECE(X2,"^",1)
- +5 if WARD=""
- GOTO F4
- SET P0=$PIECE(X2,"^",8)
- IF FHP
- IF P0'=FHP
- GOTO F4
- +6 SET M1=$PIECE(Y(0),"^",2)
- IF MEAL'="A"
- IF M1'=MEAL
- GOTO F4
- +7 DO CUR
- if FHLD'=""
- GOTO F4
- SET O1=Y
- +8 SET ^TMP($JOB,"EL",D1_"-"_$PIECE(Y(0),"^",6),FHDFN_"-"_ADM)=WARD_"^"_P0_"^"_OLW_"^"_IS_"^"_O1_"^"_$PIECE(Y(0),"^",2,4)
- GOTO F4
- P0 DO NOW^%DTC
- SET DTP=%
- DO DTP^FH
- SET H1=DTP
- SET DTP=DTE\1
- DO DTP^FH
- SET L1=DTP
- +1 IF LAB
- SET LAB=$PIECE($GET(^FH(119.9,1,"D",IOS,0)),"^",2)
- if 'LAB
- SET LAB=1
- +2 SET S1=LAB=2*5+36
- P1 SET M2="Z"
- SET PG=0
- if 'LAB
- DO HDR
- +1 SET N1=""
- FOR
- SET N1=$ORDER(^TMP($JOB,"EL",N1))
- if N1=""!(ANS="^")
- QUIT
- SET N2=""
- FOR
- SET N2=$ORDER(^TMP($JOB,"EL",N1,N2))
- if N2=""
- QUIT
- SET Y=^(N2)
- DO P2
- if ANS="^"
- QUIT
- +2 ;
- +3 ;List Outpatient (Recurring Meals) Late Trays
- DO ^FHOMELT
- +4 IF LAB<1
- WRITE !!
- +5 SET FHPREV=""
- if 'LAB
- DO OPHDR
- +6 FOR N1="B","N","E"
- Begin DoDot:1
- +7 IF '$DATA(^TMP($JOB,N1))
- QUIT
- +8 SET N2=""
- FOR
- SET N2=$ORDER(^TMP($JOB,N1,N2))
- if N2=""!(ANS="^")
- QUIT
- Begin DoDot:2
- +9 SET FHDATA=$GET(^TMP($JOB,N1,N2))
- SET FHLOC=$PIECE(FHDATA,U,1)
- SET FHDFN=$PIECE(FHDATA,U,2)
- +10 SET FHBAG=$PIECE(FHDATA,U,3)
- SET (O1,FHDIET)=$PIECE(FHDATA,U,4)
- SET RM=$PIECE(FHDATA,U,5)
- DO PATNAME^FHOMUTL
- +11 SET (WARD,FHLOCNM)=$EXTRACT($PIECE($GET(^FH(119.6,FHLOC,0)),U,1),1,10)
- +12 SET FHIP=$PIECE($GET(^FHPT(FHDFN,0)),U,5)
- SET FHIPD=""
- SET IS=""
- +13 IF FHIP'=""
- SET (IS,FHIPD)=$PIECE($GET(^FH(119.4,FHIP,0)),U,2)_$PIECE($GET(^FH(119.4,FHIP,0)),U,3)
- +14 SET P1=FHPTNM
- SET BID=FHBID
- SET TIM=$PIECE(N2,"~",1)
- SET M1=N1
- +15 IF LAB<1
- DO OUTP
- +16 IF LAB>0
- IF LAB<3
- DO P3
- +17 IF LAB>2
- DO LL
- QUIT
- End DoDot:2
- End DoDot:1
- +18 IF LAB>2
- DO DPLL^FHLABEL
- KILL ^TMP($JOB)
- QUIT
- +19 IF LAB<3
- FOR K=1:1:$SELECT('LAB:1,1:18)
- WRITE !
- +20 QUIT
- P2 SET FHDFN=+N2
- SET WARD=$PIECE(Y,"^",1)
- SET P0=$PIECE(Y,"^",2)
- SET OLW=$PIECE(Y,"^",3)
- SET IS=$PIECE(Y,"^",4)
- SET O1=$PIECE(Y,"^",5)
- SET M1=$PIECE(Y,"^",6)
- SET TIM=$PIECE(Y,"^",7)
- SET BAG=$PIECE(Y,"^",8)
- +1 IF IS
- SET IS=^FH(119.4,IS,0)
- SET IS=$PIECE(IS,"^",2)_$PIECE(IS,"^",3)
- +2 DO PATNAME^FHOMUTL
- IF DFN=""
- QUIT
- +3 SET Y=^DPT(DFN,0)
- SET P1=$PIECE(Y,"^",1)
- DO PID^FHDPA
- +4 SET RM=$GET(^DPT(DFN,.101))
- IF LAB>2
- DO LL
- QUIT
- +5 if LAB
- GOTO P3
- +6 IF $Y>(IOSL-10)
- DO HDR
- if ANS="^"
- QUIT
- WRITE !!?56,$SELECT(M1="B":"Breakfast ",M1="N":" Noon ",1:" Evening "),$JUSTIFY(TIM,6),!
- SET M2=M1_TIM
- +7 SET X=M1_TIM
- IF X'=M2
- WRITE !!?56,$SELECT(M1="B":"Breakfast ",M1="N":" Noon ",1:" Evening "),$JUSTIFY(TIM,6),!
- SET M2=X
- +8 WRITE !,$SELECT(WARD'="":$EXTRACT(WARD,1,10),1:"")_$SELECT(RM'="":"/"_$EXTRACT(RM,1,10),1:""),?24,$EXTRACT(P1,1,22),?50,BID,?61,$SELECT(IS'="":IS,1:""),?67,$SELECT(BAG="Y":"YES",1:""),?73,O1
- +9 DO ALG^FHCLN
- WRITE !,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG)
- +10 QUIT
- P3 SET P1=$EXTRACT(P1,1,22)
- SET WARD=$EXTRACT(WARD,1,15)
- SET RM=$EXTRACT(RM,1,10)
- +1 DO ALG^FHCLN
- +2 WRITE !,$SELECT(M1="B":"Breakfast",M1="N":" Noon ",1:" Evening"),?10,TIM,?(S1-12),L1
- if LAB=2
- WRITE !
- +3 WRITE !,$EXTRACT(P1,1,S1-5-$LENGTH(WARD)),?(S1-3-$LENGTH(WARD)),WARD
- +4 WRITE !,BID
- if IS'=""
- WRITE ?(S1-3\2),IS
- WRITE ?(S1-3-$LENGTH(RM)),RM
- if LAB=2
- WRITE !
- +5 IF $LENGTH(O1)<S1
- WRITE !,O1,$SELECT(ALG="":"",1:" *ALG"),!!
- +6 IF '$TEST
- SET L=$SELECT($LENGTH($PIECE(O1,",",1,3))<S1:3,1:2)
- WRITE !,$PIECE(O1,",",1,L),!,$EXTRACT($PIECE(O1,",",L+1,5),2,99),$SELECT(ALG="":"",1:"*ALG"),!
- +7 if LAB=2
- WRITE !
- QUIT
- OUTP ;
- +1 IF $Y>(IOSL-10)
- DO OPHDR
- if ANS="^"
- QUIT
- +2 SET NEW=N1_$PIECE(N2,"~",1)
- IF FHPREV'=NEW
- WRITE !!?56,$SELECT(N1="B":"Breakfast ",N1="N":" Noon ",1:" Evening "),$JUSTIFY($PIECE(N2,"~",1),6),!
- +3 WRITE !,FHLOCNM
- +4 DO PATNAME^FHOMUTL
- WRITE "/"_RM,?24,FHPTNM,?50,FHBID
- +5 WRITE ?61,FHIPD,?67,$SELECT(FHBAG="Y":"YES",1:"")
- +6 WRITE ?73,FHDIET
- +7 DO ALG^FHCLN
- WRITE !,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG)
- +8 SET FHPREV=N1_$PIECE(N2,"~",1)
- +9 QUIT
- F7 KILL ^FHPT("ADLT",D1,FHDFN,ADM)
- GOTO F4
- CUR SET A1=0
- SET (Y,FHLD,FHOR)=""
- FOR KK=0:0
- SET KK=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",KK))
- if KK<1!(KK>D1)
- QUIT
- SET A1=KK
- +1 if 'A1
- QUIT
- SET FHORD=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
- SET X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
- SET FHOR=$PIECE(X,"^",2,6)
- SET FHLD=$PIECE(X,"^",7)
- +2 IF FHLD'=""
- SET FHDU=";"_$PIECE(^DD(115.02,6,0),"^",3)
- SET %=$FIND(FHDU,";"_FHLD_":")
- if %<1
- QUIT
- SET Y=$PIECE($EXTRACT(FHDU,%,999),";",1)
- QUIT
- +3 SET Y=""
- FOR A1=1:1:5
- SET D3=$PIECE(FHOR,"^",A1)
- IF D3
- if Y'=""
- SET Y=Y_", "
- SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
- +4 QUIT
- DP KILL N
- SET Y=$GET(^FH(119.73,+P0,1))
- +1 FOR KK=1,2,3,7,8,9,13,14,15
- SET X=$PIECE(Y,"^",KK)
- IF X'=""
- SET N($SELECT(KK<7:"B",KK<13:"N",1:"E"),X)=""
- +2 QUIT
- HDR ; Print Header (INPATIENT)
- +1 IF PG
- IF IOST?1"C-".E
- READ !!,"Press RETURN to continue or ""^"" to exit. ",ANS:DTIME
- if '$TEST!(ANS["^")
- SET ANS="^"
- if ANS="^"
- QUIT
- IF "^"'[ANS
- WRITE !,"Enter Return or ""^""."
- GOTO HDR
- +2 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- +3 WRITE !?32,"I N P A T I E N T E A R L Y / L A T E T R A Y S",?110,H1
- +4 WRITE !,$SELECT('FHP:"Consolidated",1:$PIECE(^FH(119.73,FHP,0),"^",1)),?61,L1,?121,"Page ",PG
- +5 WRITE !!,"Ward/Room",?24,"Patient",?50,"ID#",?61,"Iso Bag Current-Diet",!
- QUIT
- OPHDR ; Print Header (OUTPATIENT)
- +1 IF PG
- IF IOST?1"C-".E
- READ !!,"Press RETURN to continue or ""^"" to exit. ",ANS:DTIME
- if '$TEST!(ANS["^")
- SET ANS="^"
- if ANS="^"
- QUIT
- IF "^"'[ANS
- WRITE !,"Enter Return or ""^""."
- GOTO OPHDR
- +2 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- SET PG=PG+1
- +3 WRITE !?32,"O U T P A T I E N T E A R L Y / L A T E T R A Y S",?110,H1
- +4 WRITE !,$SELECT('FHP:"Consolidated",1:$PIECE(^FH(119.73,FHP,0),"^",1)),?61,L1,?121,"Page ",PG
- +5 WRITE !!,"Ward/Room",?24,"Patient",?50,"ID#",?61,"Iso Bag Current-Diet",!
- QUIT
- LL ;
- +1 DO ALG^FHCLN
- +2 SET FHCOL=$SELECT(LAB=3:3,1:2)
- +3 IF LABSTART>1
- FOR FHLABST=1:1:(LABSTART-1)*FHCOL
- Begin DoDot:1
- +4 IF LAB=3
- SET (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)=""
- DO LL3^FHLABEL
- +5 IF LAB=4
- SET (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)=""
- DO LL4^FHLABEL
- +6 QUIT
- End DoDot:1
- SET LABSTART=1
- +7 SET SL1=$SELECT(LAB=3:25,1:38)
- +8 SET MEALTM=$SELECT(M1="B":"Breakfast",M1="N":"Noon",1:"Evening")_" "_TIM
- +9 SET BID=BID_$SELECT(ALG="":"",1:" *ALG")
- +10 SET BIDIS=BID_$EXTRACT(" ",1,12-$LENGTH(BID))_IS
- +11 SET WARD=$EXTRACT(WARD,1,15)
- SET WLN=$LENGTH(WARD)
- SET RM=$EXTRACT(RM,1,10)
- +12 IF LAB=3
- Begin DoDot:1
- +13 SET P1=$EXTRACT(P1,1,24-WLN)
- +14 SET (PCL1,PCL6)=""
- SET PCL2=MEALTM_$JUSTIFY(L1,25-$LENGTH(MEALTM))
- +15 SET PCL3=P1_$JUSTIFY(WARD,25-$LENGTH(P1))
- SET PCL4=BIDIS_$JUSTIFY(RM,25-$LENGTH(BIDIS))
- +16 SET PCL5=$EXTRACT(O1,1,29)
- DO LL3^FHLABEL
- End DoDot:1
- +17 IF LAB=4
- Begin DoDot:1
- +18 SET P1=$EXTRACT(P1,1,37-WLN)
- +19 SET (PCL1,PCL2,PCL7,PCL8)=""
- SET PCL3=MEALTM_$JUSTIFY(L1,38-$LENGTH(MEALTM))
- +20 SET PCL4=P1_$JUSTIFY(WARD,38-$LENGTH(P1))
- SET PCL5=BIDIS_$JUSTIFY(RM,38-$LENGTH(BIDIS))
- +21 SET PCL6=$EXTRACT(O1,1,42)
- DO LL4^FHLABEL
- End DoDot:1
- +22 QUIT
