Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBQLPL2

IBQLPL2.m

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