- FHNO21 ; HISC/REL/NCA - Print Feeding Labels ; 6/21/2017 12:01
- ;;5.5;DIETETICS;**5,8,43**;Jan 28, 2005;Build 66
- ;;
- ;ICR# Type Description
- ;----- ---- --------------------------------------
- ;325 Controlled ADM^VADPT2
- ;
- 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
- 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)
- I LAB>2 D LL Q
- I $P(FHPAR,"^",4)="Y" G P4
- ; FH*5.5*43 BEGIN Add patient's diet orders
- W !,$E(NAM,1,S2-$L(WRD)),?(S2+2-$L(WRD)),$E(WRD,3,99)
- ; *** Print Diet 1, 2, 3
- D DIETORD(DFN,FHDFN,"^1^2^3^")
- W !?$S(LAB=1:3,1:0),FHBID W:IS'="" ?(S2-22),"*NURSE" W ?(S2-15),DTE
- ; *** Print Diet 4, 5
- D DIETORD(DFN,FHDFN,"^4^5^")
- S LN=2 I LAB=2 W !! S LN=4
- ; FH*5.5*43 END Add patient's diet orders
- 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
- ; FH*5.5*43 BEGIN Add patient's diet orders
- DIETORD(DFN,FHDFN,DIETS) ;
- N DIET,DIETORD,DIETORD0,PIECE,VADMVT,VAERR,VAINDT2
- D ADM^VADPT2
- I $G(VAERR)'>0,$G(VADMVT) D
- .S DIETORD0=+$P($G(^FHPT(FHDFN,"A",VADMVT,0)),U,2)
- .S DIETORD=$P($G(^FHPT(FHDFN,"A",VADMVT,"DI",DIETORD0,0)),U,2,6)
- .F PIECE=1:1:5 I DIETS[(U_PIECE_U) D
- ..N DIERR,DTOUT,DUOUT,FHERR
- ..S DIET=+$P(DIETORD,U,PIECE)
- ..W ?$P("36^51^66^36^51",U,PIECE),$$GET1^DIQ(111,DIET,6,,,"FHERR")
- ..Q
- .Q
- ; FH*5.5*43 END Add patient's diet orders
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNO21 4543 printed Mar 13, 2025@20:56:56 Page 2
- FHNO21 ; HISC/REL/NCA - Print Feeding Labels ; 6/21/2017 12:01
- +1 ;;5.5;DIETETICS;**5,8,43**;Jan 28, 2005;Build 66
- +2 ;;
- +3 ;ICR# Type Description
- +4 ;----- ---- --------------------------------------
- +5 ;325 Controlled ADM^VADPT2
- +6 ;
- +7 SET DTP=DT\1
- DO DTP^FH
- SET DTE=DTP_" "_TIM_$SELECT(TIM=10:"AM",1:"PM")
- +8 SET S1=$SELECT(LAB=1:6,1:9)
- SET S2=LAB=2*5+33
- +9 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)
- +10 SET LNOD=""
- FOR
- SET LNOD=$ORDER(^TMP($JOB,"L",LNOD))
- if LNOD=""
- QUIT
- DO P2
- +11 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 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 IF LAB>2
- DO LL
- QUIT
- +6 IF $PIECE(FHPAR,"^",4)="Y"
- GOTO P4
- +7 ; FH*5.5*43 BEGIN Add patient's diet orders
- +8 WRITE !,$EXTRACT(NAM,1,S2-$LENGTH(WRD)),?(S2+2-$LENGTH(WRD)),$EXTRACT(WRD,3,99)
- +9 ; *** Print Diet 1, 2, 3
- +10 DO DIETORD(DFN,FHDFN,"^1^2^3^")
- +11 WRITE !?$SELECT(LAB=1:3,1:0),FHBID
- if IS'=""
- WRITE ?(S2-22),"*NURSE"
- WRITE ?(S2-15),DTE
- +12 ; *** Print Diet 4, 5
- +13 DO DIETORD(DFN,FHDFN,"^4^5^")
- +14 SET LN=2
- IF LAB=2
- WRITE !!
- SET LN=4
- +15 ; FH*5.5*43 END Add patient's diet orders
- +16 FOR L=1:2:7
- SET Z=$PIECE(Y2,"^",L)
- IF Z'=""
- Begin DoDot:1
- +17 SET Q=$PIECE(Y2,"^",L+1)
- if 'Q
- SET Q=1
- +18 WRITE !,$JUSTIFY(Q,2)," "
- +19 WRITE $SELECT($DATA(N(Z)):$PIECE(N(Z),"^",1),$DATA(^FH(118,+Z,0)):$PIECE(^(0),"^",1),1:"")
- +20 SET LN=LN+1
- if '$DATA(C(Z))
- SET C(Z)=0
- SET C(Z)=C(Z)+Q
- +21 QUIT
- End DoDot:1
- +22 IF LN<S1
- FOR L=LN+1:1:S1
- WRITE !
- +23 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
- +3 ; FH*5.5*43 BEGIN Add patient's diet orders
- DIETORD(DFN,FHDFN,DIETS) ;
- +1 NEW DIET,DIETORD,DIETORD0,PIECE,VADMVT,VAERR,VAINDT2
- +2 DO ADM^VADPT2
- +3 IF $GET(VAERR)'>0
- IF $GET(VADMVT)
- Begin DoDot:1
- +4 SET DIETORD0=+$PIECE($GET(^FHPT(FHDFN,"A",VADMVT,0)),U,2)
- +5 SET DIETORD=$PIECE($GET(^FHPT(FHDFN,"A",VADMVT,"DI",DIETORD0,0)),U,2,6)
- +6 FOR PIECE=1:1:5
- IF DIETS[(U_PIECE_U)
- Begin DoDot:2
- +7 NEW DIERR,DTOUT,DUOUT,FHERR
- +8 SET DIET=+$PIECE(DIETORD,U,PIECE)
- +9 WRITE ?$PIECE("36^51^66^36^51",U,PIECE),$$GET1^DIQ(111,DIET,6,,,"FHERR")
- +10 QUIT
- End DoDot:2
- +11 QUIT
- End DoDot:1
- +12 ; FH*5.5*43 END Add patient's diet orders
- 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
