FHNO21 ; HISC/REL/NCA - Print Feeding Labels ;8/26/94 12:01
;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
S DTP=DT\1 D DTP^FH S DTE=DTP_" "_TIM_$S(TIM=10:"AM",1:"PM")
S S1=$S(LAB=1:6,1:9),S2=LAB=2*5+33
K N F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S Y=^(L,0),N1=$P(Y,"^",1),^TMP($J,"I",$E(N1,1,26)_","_L)=L I '$D(^FH(118,L,"I")) S N(L)=$P(Y,"^",1,2)
S LNOD="" F S LNOD=$O(^TMP($J,"L",LNOD)) Q:LNOD="" D P2
Q
P2 S PNOD="",N1=0 K C F S PNOD=$O(^TMP($J,"L",LNOD,PNOD)) Q:PNOD="" S Y2=^(PNOD) D P3
;I LAB<3 D P5 Q
Q
P3 S N1=N1+1
S FHDFN=$P(PNOD,"~",3),WRD=$P(Y2,"^",10)
D PATNAME^FHOMUTL I FHPTNM="" Q
S ALG="" D ALG^FHCLN
S NAM=FHPTNM,IS=$P(Y2,"^",9)
;S NAM=$P(^DPT(DFN,0),"^",1),IS=$P(Y2,"^",9) D PID^FHDPA
I LAB>2 D LL Q
I $P(FHPAR,"^",4)="Y" G P4
W !,$E(NAM,1,S2-$L(WRD)),?(S2+2-$L(WRD)),$E(WRD,3,99),!?$S(LAB=1:3,1:0),FHBID,$S(ALG="":"",1:" *ALG") W:IS'="" ?(S2-22),"*NURSE" W ?(S2-15),DTE S LN=2 I LAB=2 W !! S LN=4
F L=1:2:7 S Z=$P(Y2,"^",L) I Z'="" D
.S Q=$P(Y2,"^",L+1) S:'Q Q=1
.W !,$J(Q,2)," "
.W $S($D(N(Z)):$P(N(Z),"^",1),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:"")
.S LN=LN+1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q
.Q
I LN<S1 F L=LN+1:1:S1 W !
Q
P4 S ALG="" D ALG^FHCLN
F L=1:2:7 S Z=$P(Y2,"^",L) I Z'="",$S($D(N(Z)):$P(N(Z),"^",2),$D(^FH(118,+Z,0)):$P(^(0),"^",2),1:"")'="N" D
.S Q=$P(Y2,"^",L+1) S:'Q Q=1
.W !,$E(NAM,1,S2-$L(WRD)),?(S2+2-$L(WRD)),$E(WRD,3,99),!,FHBID,$S(ALG="":"",1:" *ALG")
.W:IS'="" ?11,"*NURSE"
.W ?(S2-15),DTE,!!,$J(Q,2)," "
.W $S($D(N(Z)):$P(N(Z),"^",1),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:""),!!
.W:LAB=2 !!!
.S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q
.Q
Q
P5 S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:$P($G(^FH(119.6,W1,0)),"^",1))
W !?3,"**** INGREDIENTS LIST ****",!!?(33-$L(Y)\2),Y,!?9,DTE,!! S LN=6
S A1="" F K=0:0 S A1=$O(^TMP($J,"I",A1)) Q:A1="" S L=^(A1) I $D(C(L)),C(L) W !,$S($D(N(L)):$P(N(L),"^",1),$D(^FH(118,+L,0)):$P(^(0),"^",1),1:""),?28,$J(C(L),5,0) S LN=LN+1
P6 W !!?4,"**** PATIENTS = ",N1," ****",! S LN=LN+3
S LN=LN#S1 I LN F L=LN+1:1:S1 W !
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 FHTAB=$S(LAB=3:24,1:37)
S WRD1=$E(WRD,3,99)
S NAM=$E(NAM,1,FHTAB-$L(WRD1)),BIDIS=BID_$S(ALG="":"",1:" *ALG")
I IS="N" S BIDIS=BIDIS_" *NURSE"
S LNA=NAM_$J(WRD1,FHTAB+1-$L(NAM)),LNB=BIDIS_$J(DTE,FHTAB+1-$L(BIDIS))
I $P(FHPAR,"^",4)="Y" D LL2 Q
S NUM=0 F XSF=1:2:7 I $P(Y2,U,XSF)'="" S NUM=NUM+1
S INDX=0 F XSF=1:2:7 D
.S SFPTR=$P(Y2,U,XSF) I SFPTR="" Q
.S QTY=$P(Y2,U,XSF+1),SFNM=$P($G(^FH(118,SFPTR,0)),U,1)
.S INDX=INDX+1,ZF(INDX)=$J(QTY,2)_" "_SFNM
.Q
I LAB=3 D
.I NUM=1 S (PCL1,PCL2,PCL6)="",PCL3=LNA,PCL4=LNB,PCL5=ZF(1)
.I NUM=2 S (PCL1,PCL6)="",PCL2=LNA,PCL3=LNB,PCL4=ZF(1),PCL5=ZF(2)
.I NUM=3 S PCL1="",PCL2=LNA,PCL3=LNB,PCL4=ZF(1),PCL5=ZF(2),PCL6=ZF(3)
.I NUM=4 S PCL1=LNA,PCL2=LNB,PCL3=ZF(1),PCL4=ZF(2),PCL5=ZF(3),PCL6=ZF(4)
.D LL3^FHLABEL
I LAB=4 D
.I NUM=1 S (PCL1,PCL2,PCL3,PCL7,PCL8)="",PCL4=LNA,PCL5=LNB,PCL6=ZF(1)
.I NUM=2 S (PCL1,PCL2,PCL7,PCL8)="",PCL3=LNA,PCL4=LNB,PCL5=ZF(1),PCL6=ZF(2)
.I NUM=3 S (PCL1,PCL2,PCL8)="",PCL3=LNA,PCL4=LNB,PCL5=ZF(1),PCL6=ZF(2),PCL7=ZF(3)
.I NUM=4 S (PCL1,PCL8)="",PCL2=LNA,PCL3=LNB,PCL4=ZF(1),PCL5=ZF(2),PCL6=ZF(3),PCL7=ZF(4)
.D LL4^FHLABEL
Q
LL2 ;
F XSF=1:2:7 D
.S SFPTR=$P(Y2,U,XSF) I SFPTR="" Q
.S QTY=$P(Y2,U,XSF+1),SFNM=$P($G(^FH(118,SFPTR,0)),U,1)
.S LNC=$J(QTY,2)_" "_SFNM
.I LAB=3 S (PCL1,PCL4,PCL6)="",PCL2=LNA,PCL3=LNB,PCL5=LNC D LL3^FHLABEL
.I LAB=4 S (PCL1,PCL2,PCL5,PCL7,PCL8)="",PCL3=LNA,PCL4=LNB,PCL6=LNC D LL4^FHLABEL
Q
FHNO21 ; HISC/REL/NCA - Print Feeding Labels ;8/26/94 12:01
+1 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
+2 SET DTP=DT\1
DO DTP^FH
SET DTE=DTP_" "_TIM_$SELECT(TIM=10:"AM",1:"PM")
+3 SET S1=$SELECT(LAB=1:6,1:9)
SET S2=LAB=2*5+33
+4 KILL N
FOR L=0:0
SET L=$ORDER(^FH(118,L))
IF L<1
QUIT
SET Y=^(L,0)
SET N1=$PIECE(Y,"^",1)
SET ^TMP($JOB,"I",$EXTRACT(N1,1,26)_","_L)=L
IF '$DATA(^FH(118,L,"I"))
SET N(L)=$PIECE(Y,"^",1,2)
+5 SET LNOD=""
FOR
SET LNOD=$ORDER(^TMP($JOB,"L",LNOD))
IF LNOD=""
QUIT
DO P2
+6 QUIT
P2 SET PNOD=""
SET N1=0
KILL C
FOR
SET PNOD=$ORDER(^TMP($JOB,"L",LNOD,PNOD))
IF PNOD=""
QUIT
SET Y2=^(PNOD)
DO P3
+1 ;I LAB<3 D P5 Q
+2 QUIT
P3 SET N1=N1+1
+1 SET FHDFN=$PIECE(PNOD,"~",3)
SET WRD=$PIECE(Y2,"^",10)
+2 DO PATNAME^FHOMUTL
IF FHPTNM=""
QUIT
+3 SET ALG=""
DO ALG^FHCLN
+4 SET NAM=FHPTNM
SET IS=$PIECE(Y2,"^",9)
+5 ;S NAM=$P(^DPT(DFN,0),"^",1),IS=$P(Y2,"^",9) D PID^FHDPA
+6 IF LAB>2
DO LL
QUIT
+7 IF $PIECE(FHPAR,"^",4)="Y"
GOTO P4
+8 WRITE !,$EXTRACT(NAM,1,S2-$LENGTH(WRD)),?(S2+2-$LENGTH(WRD)),$EXTRACT(WRD,3,99),!?$SELECT(LAB=1:3,1:0),FHBID,$SELECT(ALG="":"",1:" *ALG")
IF IS'=""
WRITE ?(S2-22),"*NURSE"
WRITE ?(S2-15),DTE
SET LN=2
IF LAB=2
WRITE !!
SET LN=4
+9 FOR L=1:2:7
SET Z=$PIECE(Y2,"^",L)
IF Z'=""
Begin DoDot:1
+10 SET Q=$PIECE(Y2,"^",L+1)
IF 'Q
SET Q=1
+11 WRITE !,$JUSTIFY(Q,2)," "
+12 WRITE $SELECT($DATA(N(Z)):$PIECE(N(Z),"^",1),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:"")
+13 SET LN=LN+1
IF '$DATA(C(Z))
SET C(Z)=0
SET C(Z)=C(Z)+Q
+14 QUIT
End DoDot:1
+15 IF LN<S1
FOR L=LN+1:1:S1
WRITE !
+16 QUIT
P4 SET ALG=""
DO ALG^FHCLN
+1 FOR L=1:2:7
SET Z=$PIECE(Y2,"^",L)
IF Z'=""
IF $SELECT($DATA(N(Z)):$PIECE(N(Z),"^",2),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",2),1:"")'="N"
Begin DoDot:1
+2 SET Q=$PIECE(Y2,"^",L+1)
IF 'Q
SET Q=1
+3 WRITE !,$EXTRACT(NAM,1,S2-$LENGTH(WRD)),?(S2+2-$LENGTH(WRD)),$EXTRACT(WRD,3,99),!,FHBID,$SELECT(ALG="":"",1:" *ALG")
+4 IF IS'=""
WRITE ?11,"*NURSE"
+5 WRITE ?(S2-15),DTE,!!,$JUSTIFY(Q,2)," "
+6 WRITE $SELECT($DATA(N(Z)):$PIECE(N(Z),"^",1),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:""),!!
+7 IF LAB=2
WRITE !!!
+8 IF '$DATA(C(Z))
SET C(Z)=0
SET C(Z)=C(Z)+Q
+9 QUIT
End DoDot:1
+10 QUIT
P5 SET Y=$SELECT(XX="S":$PIECE($GET(^FH(119.74,D1,0)),"^",1),1:$PIECE($GET(^FH(119.6,W1,0)),"^",1))
+1 WRITE !?3,"**** INGREDIENTS LIST ****",!!?(33-$LENGTH(Y)\2),Y,!?9,DTE,!!
SET LN=6
+2 SET A1=""
FOR K=0:0
SET A1=$ORDER(^TMP($JOB,"I",A1))
IF A1=""
QUIT
SET L=^(A1)
IF $DATA(C(L))
IF C(L)
WRITE !,$SELECT($DATA(N(L)):$PIECE(N(L),"^",1),$DATA(^FH(118,+L,0)):$PIECE(^(0),"^",1),1:""),?28,$JUSTIFY(C(L),5,0)
SET LN=LN+1
P6 WRITE !!?4,"**** PATIENTS = ",N1," ****",!
SET LN=LN+3
+1 SET LN=LN#S1
IF LN
FOR L=LN+1:1:S1
WRITE !
+2 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 FHTAB=$SELECT(LAB=3:24,1:37)
+8 SET WRD1=$EXTRACT(WRD,3,99)
+9 SET NAM=$EXTRACT(NAM,1,FHTAB-$LENGTH(WRD1))
SET BIDIS=BID_$SELECT(ALG="":"",1:" *ALG")
+10 IF IS="N"
SET BIDIS=BIDIS_" *NURSE"
+11 SET LNA=NAM_$JUSTIFY(WRD1,FHTAB+1-$LENGTH(NAM))
SET LNB=BIDIS_$JUSTIFY(DTE,FHTAB+1-$LENGTH(BIDIS))
+12 IF $PIECE(FHPAR,"^",4)="Y"
DO LL2
QUIT
+13 SET NUM=0
FOR XSF=1:2:7
IF $PIECE(Y2,U,XSF)'=""
SET NUM=NUM+1
+14 SET INDX=0
FOR XSF=1:2:7
Begin DoDot:1
+15 SET SFPTR=$PIECE(Y2,U,XSF)
IF SFPTR=""
QUIT
+16 SET QTY=$PIECE(Y2,U,XSF+1)
SET SFNM=$PIECE($GET(^FH(118,SFPTR,0)),U,1)
+17 SET INDX=INDX+1
SET ZF(INDX)=$JUSTIFY(QTY,2)_" "_SFNM
+18 QUIT
End DoDot:1
+19 IF LAB=3
Begin DoDot:1
+20 IF NUM=1
SET (PCL1,PCL2,PCL6)=""
SET PCL3=LNA
SET PCL4=LNB
SET PCL5=ZF(1)
+21 IF NUM=2
SET (PCL1,PCL6)=""
SET PCL2=LNA
SET PCL3=LNB
SET PCL4=ZF(1)
SET PCL5=ZF(2)
+22 IF NUM=3
SET PCL1=""
SET PCL2=LNA
SET PCL3=LNB
SET PCL4=ZF(1)
SET PCL5=ZF(2)
SET PCL6=ZF(3)
+23 IF NUM=4
SET PCL1=LNA
SET PCL2=LNB
SET PCL3=ZF(1)
SET PCL4=ZF(2)
SET PCL5=ZF(3)
SET PCL6=ZF(4)
+24 DO LL3^FHLABEL
End DoDot:1
+25 IF LAB=4
Begin DoDot:1
+26 IF NUM=1
SET (PCL1,PCL2,PCL3,PCL7,PCL8)=""
SET PCL4=LNA
SET PCL5=LNB
SET PCL6=ZF(1)
+27 IF NUM=2
SET (PCL1,PCL2,PCL7,PCL8)=""
SET PCL3=LNA
SET PCL4=LNB
SET PCL5=ZF(1)
SET PCL6=ZF(2)
+28 IF NUM=3
SET (PCL1,PCL2,PCL8)=""
SET PCL3=LNA
SET PCL4=LNB
SET PCL5=ZF(1)
SET PCL6=ZF(2)
SET PCL7=ZF(3)
+29 IF NUM=4
SET (PCL1,PCL8)=""
SET PCL2=LNA
SET PCL3=LNB
SET PCL4=ZF(1)
SET PCL5=ZF(2)
SET PCL6=ZF(3)
SET PCL7=ZF(4)
+30 DO LL4^FHLABEL
End DoDot:1
+31 QUIT
LL2 ;
+1 FOR XSF=1:2:7
Begin DoDot:1
+2 SET SFPTR=$PIECE(Y2,U,XSF)
IF SFPTR=""
QUIT
+3 SET QTY=$PIECE(Y2,U,XSF+1)
SET SFNM=$PIECE($GET(^FH(118,SFPTR,0)),U,1)
+4 SET LNC=$JUSTIFY(QTY,2)_" "_SFNM
+5 IF LAB=3
SET (PCL1,PCL4,PCL6)=""
SET PCL2=LNA
SET PCL3=LNB
SET PCL5=LNC
DO LL3^FHLABEL
+6 IF LAB=4
SET (PCL1,PCL2,PCL5,PCL7,PCL8)=""
SET PCL3=LNA
SET PCL4=LNB
SET PCL6=LNC
DO LL4^FHLABEL
End DoDot:1
+7 QUIT
