FHNO31 ; HISC/REL - Supplemental Feeding Lists (cont) ;4/27/93 11:26
;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
K C F L=0:0 S L=$O(^FH(118,L)) Q:L<1 I '$D(^FH(118,L,"I")) S C(L)=$P(^(0),"^",1)
D NOW^%DTC S (NOW,DTP)=%,DT=%\1 D DTP^FH S X1=DT,X2=-14 D C^%DTC S OLD=+X
K ^TMP("FH",$J) S PG=0
F KK=0:0 S KK=$O(^FH(119.6,KK)) Q:KK<1 S X=^(KK,0) D F0
S NXW="" F KK=0:0 S NXW=$O(^TMP("FH",$J,NXW)) Q:NXW="" F WRD=0:0 S WRD=$O(^TMP("FH",$J,NXW,WRD)) Q:WRD<1 D F2
Q
;
F0 I XX="S" S K1=$P(X,"^",9) I WRDS,K1'=WRDS Q
I XX="W",WRDS,KK'=WRDS Q
S K1=$S(XX="W":"",K1<1:99,K1<10:"0"_K1,1:K1),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
S WRDN=$P(^FH(119.6,KK,0),"^",1),^TMP("FH",$J,K1_P0_$E(WRDN,1,26),KK)="" Q
;
F2 S WRDN=$P(^FH(119.6,WRD,0),"^",1)
;I $O(^FHPT("AW",WRD,0))<1 Q
K ^TMP($J) F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",WRD,FHDFN)) D RM
;PROCESS outpatient SF.
I '$D(^TMP($J)) D OSF I $D(^TMP($J)) D HDR D OSF1 Q
;
Q:'$D(^TMP($J)) D HDR
S (NR,RM)="",FHPAR=0 I XX="S",WRDS S FHPAR=$P($G(^FH(119.74,WRDS,0)),"^",5)="Y"
L2 S NR=$O(^TMP($J,"P",NR)) I NR="" W ! D:FHPAR ING Q
S FHDFN=""
L3 S FHDFN=$O(^TMP($J,"P",NR,FHDFN)) G:FHDFN="" L2 S ADM=$G(^TMP($J,"P",NR,FHDFN)) G:ADM<1 L3 D PATNAME^FHOMUTL G:DFN="" L2 S Y(0)=^DPT(DFN,0) D PID^FHDPA
S RM=$S(PRN="R":NR,$D(^DPT(DFN,.101)):^(.101),1:"")
S (NO,Y)="" I $D(^FHPT(FHDFN,"A",ADM,0)) S NO=$P(^(0),"^",7),IS=$P(^(0),"^",10)
G:'NO L3 S Y=^FHPT(FHDFN,"A",ADM,"SF",NO,0),NM=$P(Y,"^",4),LST=$P(Y,"^",30)\1
I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS=""
I NM S NM=$P(^FH(118.1,NM,0),"^",2) I NM="" S NM=$P(^(0),"^",1)
D:$Y>(IOSL-8) HDR W !!,RM,?13,$E($P(Y(0),"^",1),1,24),?38,BID
W ?47,$E(NM,1,10) W:IS'="" ?60,"*NURSE" W ?69,$E(LST,4,5),"-",$E(LST,6,7) W:LST<OLD "*"
D ALG^FHCLN W !,"ALLERGIES: ",$S(ALG="":"NONE ON FILE",1:ALG)
S L=4 F K1=1:1:3 S K=0,N(K1)="" F K2=1:1:4 S Z=$P(Y,U,L+1),Q=$P(Y,U,L+2),L=L+2 I Z'="" S:'Q Q=1 S:N(K1)'="" N(K1)=N(K1)_"; " S N(K1)=N(K1)_Q_" "_$S($D(C(Z)):C(Z),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:"") I FHPAR D L4
F K1=1:1:3 I N(K1)'="" W !?8,$P("10AM; 2PM; 8PM",";",K1),?14,N(K1)
G L3
;
L4 S:'$D(^TMP($J,"I",K1,Z)) ^TMP($J,"I",K1,Z)=0 S ^(Z)=^(Z)+Q Q
ING Q:'$D(^TMP($J,"I")) S DTP=DT D DTP^FH W @IOF,!,WRDN," INGREDIENT LIST FOR ",DTP
W !!,"--- 10 AM ---",?26,"--- 2 PM ---",?52,"--- 8 PM ---",! S (N(1),N(2),N(3))=.5
F L=0:0 Q:(N(1)+N(2)+N(3))=0 W ! F K=1:1:3 S:N(K)>0 N(K)=$O(^TMP($J,"I",K,N(K))) I N(K)>0 S Z=N(K) W ?(K-1*26),$J(^(Z),4,0)," ",$S($D(C(Z)):C(Z),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:"")
W ! Q
RM ;
D PATNAME^FHOMUTL I DFN="" Q
Q:'$D(^DPT(DFN,0)) Q:ADM<1
Q:'$D(^FHPT(FHDFN,"A",ADM,0)) S X1=^(0),NO=$P(X1,"^",7) Q:'NO
D CHK Q:'NO
I PRN="R" S RM=$G(^DPT(DFN,.101))
E S RM=$P($G(^DPT(DFN,0)),"^",1)
S:RM="" RM=" "
S ^TMP($J,"P",RM,FHDFN)=ADM Q
;
CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1
I X1>1,X1'>NOW G C2
C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2
S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO=""
C1 K FHORD,A1,K,X1 Q
C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>NOW) S A1=K
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
;
HDR ; Print Header
W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
W !?10,"W A R D S U P P L E M E N T A L F E E D I N G L I S T",?72,"Page ",PG
W !!,"Ward: ",WRDN,?61,DTP
W !!,"ROOM",?13,"PATIENT",?39,"ID# SUPP MENU",?60,"ISOLAT",?69,"REVIEW" Q
;
OSF ;outpatient SFs
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
.S X1=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO)
.S FHMEAL=$P(X1,U,4),FHOWARD=$P(X1,U,3)
.I (WRD'=FHOWARD)!(FHMEAL="") Q
.S FHSFDAT=""
.I $D(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) S FHSFDAT=^(0)
.Q:$P(FHSFDAT,U,32)
.S RM=$S(FHMEAL="N":2,FHMEAL="E":3,1:1)
.I $G(FHOWARD),($G(^FH(119.6,FHOWARD,0))) S WRDN=$P($G(^FH(119.6,FHOWARD,0)),U,1)
.S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5)
.D PATNAME^FHOMUTL
.S RM="",RMIEN=$P(X1,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10)
.S:RM="" RM=" "
.I PRN="A" S ^TMP($J,"P",FHPTNM,RM,ADM)=FHDFN
.I PRN="R" S ^TMP($J,"P",RM,FHPTNM,ADM)=FHDFN
.;S ^TMP($J,"P",FHPTNM,RM,ADM)=FHDFN
Q
;
OSF1 S FHPTN="",FHPAR=0 I XX="S",WRDS S FHPAR=$P($G(^FH(119.74,WRDS,0)),"^",5)="Y"
OL2 S FHPTN=$O(^TMP($J,"P",FHPTN)) I FHPTN="" W ! D:FHPAR ING Q
S NR="",ADM=0
;
OL3 S NR=$O(^TMP($J,"P",FHPTN,NR)) G:NR="" OL2
S RM=$S(PRN="R":FHPTN,1:NR)
OL4 S ADM=$O(^TMP($J,"P",FHPTN,NR,ADM)) G:ADM<1 OL3 S FHDFN=^TMP($J,"P",FHPTN,NR,ADM) D PATNAME^FHOMUTL
S (NO,Y,IS)="" I $D(^FHPT(FHDFN,"OP",ADM,0)) S NO=$P(^FHPT(FHDFN,"OP",ADM,"SF",0),"^",3),IS=$P(^FHPT(FHDFN,0),"^",5)
G:'NO OL4 S Y=^FHPT(FHDFN,"OP",ADM,"SF",NO,0),NM=$P(Y,"^",4),LST=$P(Y,"^",30)\1
I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS=""
I NM S NM=$P(^FH(118.1,NM,0),"^",2) I NM="" S NM=$P(^(0),"^",1)
D:$Y>(IOSL-8) HDR I $D(FHPTSAV),FHPTSAV'=FHPTN W !
W !,RM,?13,$E(FHPTNM,1,24),?38,FHBID
W ?47,$E(NM,1,10) W:IS'="" ?60,"*NURSE" W ?69,$E(LST,4,5),"-",$E(LST,6,7) W:LST<OLD "*"
D ALG^FHCLN W !,"ALLERGIES: ",$S(ALG="":"NONE ON FILE",1:ALG)
S L=4 F K1=1:1:3 S K=0,N(K1)="" F K2=1:1:4 S Z=$P(Y,U,L+1),Q=$P(Y,U,L+2),L=L+2 I Z'="" S:'Q Q=1 S:N(K1)'="" N(K1)=N(K1)_"; " S N(K1)=N(K1)_Q_" "_$S($D(C(Z)):C(Z),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:"") I FHPAR D L4
F K1=1:1:3 I N(K1)'="" W !?8,$P("10AM; 2PM; 8PM",";",K1),?14,N(K1)
S FHPTSAV=FHPTN
G OL4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNO31 5660 printed Sep 23, 2025@19:28:18 Page 2
FHNO31 ; HISC/REL - Supplemental Feeding Lists (cont) ;4/27/93 11:26
+1 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
+2 KILL C
FOR L=0:0
SET L=$ORDER(^FH(118,L))
if L<1
QUIT
IF '$DATA(^FH(118,L,"I"))
SET C(L)=$PIECE(^(0),"^",1)
+3 DO NOW^%DTC
SET (NOW,DTP)=%
SET DT=%\1
DO DTP^FH
SET X1=DT
SET X2=-14
DO C^%DTC
SET OLD=+X
+4 KILL ^TMP("FH",$JOB)
SET PG=0
+5 FOR KK=0:0
SET KK=$ORDER(^FH(119.6,KK))
if KK<1
QUIT
SET X=^(KK,0)
DO F0
+6 SET NXW=""
FOR KK=0:0
SET NXW=$ORDER(^TMP("FH",$JOB,NXW))
if NXW=""
QUIT
FOR WRD=0:0
SET WRD=$ORDER(^TMP("FH",$JOB,NXW,WRD))
if WRD<1
QUIT
DO F2
+7 QUIT
+8 ;
F0 IF XX="S"
SET K1=$PIECE(X,"^",9)
IF WRDS
IF K1'=WRDS
QUIT
+1 IF XX="W"
IF WRDS
IF KK'=WRDS
QUIT
+2 SET K1=$SELECT(XX="W":"",K1<1:99,K1<10:"0"_K1,1:K1)
SET P0=$PIECE(X,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+3 SET WRDN=$PIECE(^FH(119.6,KK,0),"^",1)
SET ^TMP("FH",$JOB,K1_P0_$EXTRACT(WRDN,1,26),KK)=""
QUIT
+4 ;
F2 SET WRDN=$PIECE(^FH(119.6,WRD,0),"^",1)
+1 ;I $O(^FHPT("AW",WRD,0))<1 Q
+2 KILL ^TMP($JOB)
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",WRD,FHDFN))
if FHDFN<1
QUIT
SET ADM=$GET(^FHPT("AW",WRD,FHDFN))
DO RM
+3 ;PROCESS outpatient SF.
+4 IF '$DATA(^TMP($JOB))
DO OSF
IF $DATA(^TMP($JOB))
DO HDR
DO OSF1
QUIT
+5 ;
+6 if '$DATA(^TMP($JOB))
QUIT
DO HDR
+7 SET (NR,RM)=""
SET FHPAR=0
IF XX="S"
IF WRDS
SET FHPAR=$PIECE($GET(^FH(119.74,WRDS,0)),"^",5)="Y"
L2 SET NR=$ORDER(^TMP($JOB,"P",NR))
IF NR=""
WRITE !
if FHPAR
DO ING
QUIT
+1 SET FHDFN=""
L3 SET FHDFN=$ORDER(^TMP($JOB,"P",NR,FHDFN))
if FHDFN=""
GOTO L2
SET ADM=$GET(^TMP($JOB,"P",NR,FHDFN))
if ADM<1
GOTO L3
DO PATNAME^FHOMUTL
if DFN=""
GOTO L2
SET Y(0)=^DPT(DFN,0)
DO PID^FHDPA
+1 SET RM=$SELECT(PRN="R":NR,$DATA(^DPT(DFN,.101)):^(.101),1:"")
+2 SET (NO,Y)=""
IF $DATA(^FHPT(FHDFN,"A",ADM,0))
SET NO=$PIECE(^(0),"^",7)
SET IS=$PIECE(^(0),"^",10)
+3 if 'NO
GOTO L3
SET Y=^FHPT(FHDFN,"A",ADM,"SF",NO,0)
SET NM=$PIECE(Y,"^",4)
SET LST=$PIECE(Y,"^",30)\1
+4 IF IS
SET IS=$PIECE($GET(^FH(119.4,IS,0)),"^",3)
if IS'="N"
SET IS=""
+5 IF NM
SET NM=$PIECE(^FH(118.1,NM,0),"^",2)
IF NM=""
SET NM=$PIECE(^(0),"^",1)
+6 if $Y>(IOSL-8)
DO HDR
WRITE !!,RM,?13,$EXTRACT($PIECE(Y(0),"^",1),1,24),?38,BID
+7 WRITE ?47,$EXTRACT(NM,1,10)
if IS'=""
WRITE ?60,"*NURSE"
WRITE ?69,$EXTRACT(LST,4,5),"-",$EXTRACT(LST,6,7)
if LST<OLD
WRITE "*"
+8 DO ALG^FHCLN
WRITE !,"ALLERGIES: ",$SELECT(ALG="":"NONE ON FILE",1:ALG)
+9 SET L=4
FOR K1=1:1:3
SET K=0
SET N(K1)=""
FOR K2=1:1:4
SET Z=$PIECE(Y,U,L+1)
SET Q=$PIECE(Y,U,L+2)
SET L=L+2
IF Z'=""
if 'Q
SET Q=1
if N(K1)'=""
SET N(K1)=N(K1)_"; "
SET N(K1)=N(K1)_Q_" "_$SELECT($DATA(C(Z)):C(Z),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:"")
IF FHPAR
DO L4
+10 FOR K1=1:1:3
IF N(K1)'=""
WRITE !?8,$PIECE("10AM; 2PM; 8PM",";",K1),?14,N(K1)
+11 GOTO L3
+12 ;
L4 if '$DATA(^TMP($JOB,"I",K1,Z))
SET ^TMP($JOB,"I",K1,Z)=0
SET ^(Z)=^(Z)+Q
QUIT
ING if '$DATA(^TMP($JOB,"I"))
QUIT
SET DTP=DT
DO DTP^FH
WRITE @IOF,!,WRDN," INGREDIENT LIST FOR ",DTP
+1 WRITE !!,"--- 10 AM ---",?26,"--- 2 PM ---",?52,"--- 8 PM ---",!
SET (N(1),N(2),N(3))=.5
+2 FOR L=0:0
if (N(1)+N(2)+N(3))=0
QUIT
WRITE !
FOR K=1:1:3
if N(K)>0
SET N(K)=$ORDER(^TMP($JOB,"I",K,N(K)))
IF N(K)>0
SET Z=N(K)
WRITE ?(K-1*26),$JUSTIFY(^(Z),4,0)," ",$SELECT($DATA(C(Z)):C(Z),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:"")
+3 WRITE !
QUIT
RM ;
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 if '$DATA(^DPT(DFN,0))
QUIT
if ADM<1
QUIT
+3 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
SET X1=^(0)
SET NO=$PIECE(X1,"^",7)
if 'NO
QUIT
+4 DO CHK
if 'NO
QUIT
+5 IF PRN="R"
SET RM=$GET(^DPT(DFN,.101))
+6 IF '$TEST
SET RM=$PIECE($GET(^DPT(DFN,0)),"^",1)
+7 if RM=""
SET RM=" "
+8 SET ^TMP($JOB,"P",RM,FHDFN)=ADM
QUIT
+9 ;
CHK SET FHORD=$PIECE(X1,"^",2)
SET X1=$PIECE(X1,"^",3)
if FHORD<1
GOTO C1
+1 IF X1>1
IF X1'>NOW
GOTO C2
C0 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
GOTO C2
+1 SET X1=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7)
IF X1'=""
IF X1'="X"
SET NO=""
C1 KILL FHORD,A1,K,X1
QUIT
C2 SET A1=0
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
if K<1!(K>NOW)
QUIT
SET A1=K
+1 if 'A1
GOTO C1
SET FHORD=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
if FHORD'<1
GOTO C0
+2 KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
GOTO C2
+3 ;
HDR ; Print Header
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
+2 WRITE !?10,"W A R D S U P P L E M E N T A L F E E D I N G L I S T",?72,"Page ",PG
+3 WRITE !!,"Ward: ",WRDN,?61,DTP
+4 WRITE !!,"ROOM",?13,"PATIENT",?39,"ID# SUPP MENU",?60,"ISOLAT",?69,"REVIEW"
QUIT
+5 ;
OSF ;outpatient SFs
+1 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",DT,FHDFN))
if FHDFN'>0
QUIT
FOR ADM=0:0
SET ADM=$ORDER(^FHPT("RM",DT,FHDFN,ADM))
if ADM'>0
QUIT
Begin DoDot:1
+2 SET X1=$GET(^FHPT(FHDFN,"OP",ADM,0))
SET FHNO=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3)
if '$GET(FHNO)
QUIT
+3 SET FHMEAL=$PIECE(X1,U,4)
SET FHOWARD=$PIECE(X1,U,3)
+4 IF (WRD'=FHOWARD)!(FHMEAL="")
QUIT
+5 SET FHSFDAT=""
+6 IF $DATA(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0))
SET FHSFDAT=^(0)
+7 if $PIECE(FHSFDAT,U,32)
QUIT
+8 SET RM=$SELECT(FHMEAL="N":2,FHMEAL="E":3,1:1)
+9 IF $GET(FHOWARD)
IF ($GET(^FH(119.6,FHOWARD,0)))
SET WRDN=$PIECE($GET(^FH(119.6,FHOWARD,0)),U,1)
+10 SET P1=$SELECT(FHMEAL="N":13,FHMEAL="E":21,1:5)
+11 DO PATNAME^FHOMUTL
+12 SET RM=""
SET RMIEN=$PIECE(X1,U,18)
IF $GET(RMIEN)
IF $DATA(^DG(405.4,RMIEN,0))
SET RM=$EXTRACT($PIECE(^DG(405.4,RMIEN,0),U,1),1,10)
+13 if RM=""
SET RM=" "
+14 IF PRN="A"
SET ^TMP($JOB,"P",FHPTNM,RM,ADM)=FHDFN
+15 IF PRN="R"
SET ^TMP($JOB,"P",RM,FHPTNM,ADM)=FHDFN
+16 ;S ^TMP($J,"P",FHPTNM,RM,ADM)=FHDFN
End DoDot:1
+17 QUIT
+18 ;
OSF1 SET FHPTN=""
SET FHPAR=0
IF XX="S"
IF WRDS
SET FHPAR=$PIECE($GET(^FH(119.74,WRDS,0)),"^",5)="Y"
OL2 SET FHPTN=$ORDER(^TMP($JOB,"P",FHPTN))
IF FHPTN=""
WRITE !
if FHPAR
DO ING
QUIT
+1 SET NR=""
SET ADM=0
+2 ;
OL3 SET NR=$ORDER(^TMP($JOB,"P",FHPTN,NR))
if NR=""
GOTO OL2
+1 SET RM=$SELECT(PRN="R":FHPTN,1:NR)
OL4 SET ADM=$ORDER(^TMP($JOB,"P",FHPTN,NR,ADM))
if ADM<1
GOTO OL3
SET FHDFN=^TMP($JOB,"P",FHPTN,NR,ADM)
DO PATNAME^FHOMUTL
+1 SET (NO,Y,IS)=""
IF $DATA(^FHPT(FHDFN,"OP",ADM,0))
SET NO=$PIECE(^FHPT(FHDFN,"OP",ADM,"SF",0),"^",3)
SET IS=$PIECE(^FHPT(FHDFN,0),"^",5)
+2 if 'NO
GOTO OL4
SET Y=^FHPT(FHDFN,"OP",ADM,"SF",NO,0)
SET NM=$PIECE(Y,"^",4)
SET LST=$PIECE(Y,"^",30)\1
+3 IF IS
SET IS=$PIECE($GET(^FH(119.4,IS,0)),"^",3)
if IS'="N"
SET IS=""
+4 IF NM
SET NM=$PIECE(^FH(118.1,NM,0),"^",2)
IF NM=""
SET NM=$PIECE(^(0),"^",1)
+5 if $Y>(IOSL-8)
DO HDR
IF $DATA(FHPTSAV)
IF FHPTSAV'=FHPTN
WRITE !
+6 WRITE !,RM,?13,$EXTRACT(FHPTNM,1,24),?38,FHBID
+7 WRITE ?47,$EXTRACT(NM,1,10)
if IS'=""
WRITE ?60,"*NURSE"
WRITE ?69,$EXTRACT(LST,4,5),"-",$EXTRACT(LST,6,7)
if LST<OLD
WRITE "*"
+8 DO ALG^FHCLN
WRITE !,"ALLERGIES: ",$SELECT(ALG="":"NONE ON FILE",1:ALG)
+9 SET L=4
FOR K1=1:1:3
SET K=0
SET N(K1)=""
FOR K2=1:1:4
SET Z=$PIECE(Y,U,L+1)
SET Q=$PIECE(Y,U,L+2)
SET L=L+2
IF Z'=""
if 'Q
SET Q=1
if N(K1)'=""
SET N(K1)=N(K1)_"; "
SET N(K1)=N(K1)_Q_" "_$SELECT($DATA(C(Z)):C(Z),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:"")
IF FHPAR
DO L4
+10 FOR K1=1:1:3
IF N(K1)'=""
WRITE !?8,$PIECE("10AM; 2PM; 8PM",";",K1),?14,N(K1)
+11 SET FHPTSAV=FHPTN
+12 GOTO OL4
