- 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
- 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
