IBQLPL2 ;LEB/MRY - PRINT PATIENTS QUALIFY/MISSING LIST ; 15-APR-95
 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PRINT ;
 D DTC
 I IBRPT="Q" S IBHDR="PATIENTS TO BE ROLLED UP"
 I IBRPT="M" S IBHDR="PATIENTS WITH MISSING DATA"
 S IBHDR1=IBDRNG D HDR I '$D(^TMP("IBQLPL",$J)) W !!,?20,"<<<   NO PATIENTS TO PRINT   >>>" Q 
 S ENRLL="" F  S ENRLL=$O(^TMP("IBQLPL",$J,ENRLL)) Q:ENRLL=""  D DISCH
 Q
DISCH S IBENRLL=$S(ENRLL="AA":"*NEITHER*",ENRLL="ZL":"LOCAL",(ENRLL="N")!(ENRLL="B"):"NATIONAL",1:"")
 S IBDDT="" F  S IBDDT=$O(^TMP("IBQLPL",$J,ENRLL,IBDDT)) Q:IBDDT=""  D  Q:IBQUIT
 .S SSN="" F  S SSN=$O(^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN)) Q:SSN=""  D  Q:IBQUIT
 ..S X=^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN),IBNAM=$P(X,"^")
 ..D CHKL Q:IBQUIT
 ..W:IBRPT="M" ! W !,SSN,?20,IBNAM,?45 S Y=IBDDT X ^DD("DD") W Y W ?70,IBENRLL
 ..I $O(^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN,0)) S IBDAY=0 F  S IBDAY=$O(^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN,IBDAY)) Q:'IBDAY  D  Q:IBQUIT
 ...D CHKL Q:IBQUIT
 ...W !?5,^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN,IBDAY)
 Q
 ;
HDR ; -- print headers
 W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
 W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
 W !?(IOM-$L(IBHDR1)/2),IBHDR1
 W !!,?45,"DISCHARGE DATE"
 W !,"SSN",?20,"PATIENT NAME",?45,"FROM ACUTE CARE",?70,"ROLLUP"
 W !,$TR($J("",IOM)," ","-")
 Q
 ;
CHKL ; -- check end of page
 I IOSL<($Y+3),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT  W @IOF D HDR Q
 I IOSL<($Y+3) D HDR
 Q
 ;
DTC ;
 D NOW^%DTC,YX^%DTC S IBTDT=Y,IBDRNG=+$E(IBBDT,4,5)_"/"_+$E(IBBDT,6,7)_"/"_+$E(IBBDT,2,3)_" - "_+$E(IBEDT,4,5)_"/"_+$E(IBEDT,6,7)_"/"_+$E(IBEDT,2,3)
 Q