FHDCR1C ; HISC/NCA/RVD - Print Diet Cards (cont.) ;5/10/95 13:02
;;5.5;DIETETICS;;Jan 28, 2005
PRT ; Print 2 person page
N NBR
S TL=0 D CHKH
W !! S TL=TL+2 F N1=1:1:2 I $D(^TMP($J,0,N1)) W ?$S(N1=1:2,1:65),MEALDT
W ! S TL=TL+1 F N1=1:1 Q:'$D(PP(N1)) W ! S TL=TL+1 F NBR=1:1:2 I $D(PP(N1,NBR)) W ?$S(NBR=1:2,1:65),PP(N1,NBR)
W ! S TL=TL+1
F N1=1:1 Q:'$D(^TMP($J,"MP",N1)) D:(TL+2)'<($S(FHBOT="Y":LN-5,1:LN-3)) NXT W !! S TL=TL+2 F NBR=1:1:2 D
.S S1=$S(NBR=1:2,1:65)
.I $D(^TMP($J,"MP",N1,NBR)) W ?S1,^TMP($J,"MP",N1,NBR)
.Q
I TL<LN F L1=TL:1:$S(FHBOT="Y":LN-2,1:LN) W !
I FHBOT="Y" D HEAD W @IOF Q
E D FOOT
W @IOF Q
NXT ; Print Next Page
W !! S TL=TL+2 F NM=1:1:2 I $D(^TMP($J,0,NM)) W ?$S(NM=1:20,1:80),"(More Items Next Pg)"
I TL<LN F L1=TL:1:$S(FHBOT="Y":LN-2,1:LN) W !
I FHBOT="Y" D HEAD G N1
E D FOOT
N1 W @IOF S TL=0 D CHKH
W !! S TL=TL+2 F XX=1:1:2 I $D(^TMP($J,0,XX)) W ?$S(XX=1:2,1:65),MEALDT," (Cont.)"
W ! S TL=TL+1
Q
CHKH ; Check whether name header should be on bottom
I FHBOT="Y" W ! S TL=TL+1 D FOOT W ! S TL=TL+1 Q
E D HEAD
Q
HEAD F NM=1:1:3 W ! S TL=TL+1 F NBR=1:1:2 S X=$P($G(^TMP($J,0,NBR)),"^",NM) I X'="" D
.S S1=$S(NBR=1:2,1:65) I NM=1 W ?S1,X Q
.W ?(S1+56-$L(X)),X Q
Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHDCR1C 1344 printed Apr 09, 2024@20:58:59 Page 2
FHDCR1C ; HISC/NCA/RVD - Print Diet Cards (cont.) ;5/10/95 13:02
+1 ;;5.5;DIETETICS;;Jan 28, 2005
PRT ; Print 2 person page
+1 NEW NBR
+2 SET TL=0
DO CHKH
+3 WRITE !!
SET TL=TL+2
FOR N1=1:1:2
IF $DATA(^TMP($JOB,0,N1))
WRITE ?$SELECT(N1=1:2,1:65),MEALDT
+4 WRITE !
SET TL=TL+1
FOR N1=1:1
if '$DATA(PP(N1))
QUIT
WRITE !
SET TL=TL+1
FOR NBR=1:1:2
IF $DATA(PP(N1,NBR))
WRITE ?$SELECT(NBR=1:2,1:65),PP(N1,NBR)
+5 WRITE !
SET TL=TL+1
+6 FOR N1=1:1
if '$DATA(^TMP($JOB,"MP",N1))
QUIT
if (TL+2)'<($SELECT(FHBOT="Y"
DO NXT
WRITE !!
SET TL=TL+2
FOR NBR=1:1:2
Begin DoDot:1
+7 SET S1=$SELECT(NBR=1:2,1:65)
+8 IF $DATA(^TMP($JOB,"MP",N1,NBR))
WRITE ?S1,^TMP($JOB,"MP",N1,NBR)
+9 QUIT
End DoDot:1
+10 IF TL<LN
FOR L1=TL:1:$SELECT(FHBOT="Y":LN-2,1:LN)
WRITE !
+11 IF FHBOT="Y"
DO HEAD
WRITE @IOF
QUIT
+12 IF '$TEST
DO FOOT
+13 WRITE @IOF
QUIT
NXT ; Print Next Page
+1 WRITE !!
SET TL=TL+2
FOR NM=1:1:2
IF $DATA(^TMP($JOB,0,NM))
WRITE ?$SELECT(NM=1:20,1:80),"(More Items Next Pg)"
+2 IF TL<LN
FOR L1=TL:1:$SELECT(FHBOT="Y":LN-2,1:LN)
WRITE !
+3 IF FHBOT="Y"
DO HEAD
GOTO N1
+4 IF '$TEST
DO FOOT
N1 WRITE @IOF
SET TL=0
DO CHKH
+1 WRITE !!
SET TL=TL+2
FOR XX=1:1:2
IF $DATA(^TMP($JOB,0,XX))
WRITE ?$SELECT(XX=1:2,1:65),MEALDT," (Cont.)"
+2 WRITE !
SET TL=TL+1
+3 QUIT
CHKH ; Check whether name header should be on bottom
+1 IF FHBOT="Y"
WRITE !
SET TL=TL+1
DO FOOT
WRITE !
SET TL=TL+1
QUIT
+2 IF '$TEST
DO HEAD
+3 QUIT
HEAD FOR NM=1:1:3
WRITE !
SET TL=TL+1
FOR NBR=1:1:2
SET X=$PIECE($GET(^TMP($JOB,0,NBR)),"^",NM)
IF X'=""
Begin DoDot:1
+1 SET S1=$SELECT(NBR=1:2,1:65)
IF NM=1
WRITE ?S1,X
QUIT
+2 WRITE ?(S1+56-$LENGTH(X)),X
QUIT
End DoDot:1
+3 QUIT
SET TL=TL+1
FOR NBR=1:1:2
SET S1=$SELECT(NBR=1:2,1:65)
if $DATA(^TMP($JOB,0,NBR))
WRITE ?S1,HD
+1 QUIT
