- 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 Dec 13, 2024@01:47:28 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