| 1 | IBQLPL2 ;LEB/MRY - PRINT PATIENTS QUALIFY/MISSING LIST ; 15-APR-95
|
|---|
| 2 | ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | PRINT ;
|
|---|
| 6 | D DTC
|
|---|
| 7 | I IBRPT="Q" S IBHDR="PATIENTS TO BE ROLLED UP"
|
|---|
| 8 | I IBRPT="M" S IBHDR="PATIENTS WITH MISSING DATA"
|
|---|
| 9 | S IBHDR1=IBDRNG D HDR I '$D(^TMP("IBQLPL",$J)) W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
|
|---|
| 10 | S ENRLL="" F S ENRLL=$O(^TMP("IBQLPL",$J,ENRLL)) Q:ENRLL="" D DISCH
|
|---|
| 11 | Q
|
|---|
| 12 | DISCH S IBENRLL=$S(ENRLL="AA":"*NEITHER*",ENRLL="ZL":"LOCAL",(ENRLL="N")!(ENRLL="B"):"NATIONAL",1:"")
|
|---|
| 13 | S IBDDT="" F S IBDDT=$O(^TMP("IBQLPL",$J,ENRLL,IBDDT)) Q:IBDDT="" D Q:IBQUIT
|
|---|
| 14 | .S SSN="" F S SSN=$O(^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN)) Q:SSN="" D Q:IBQUIT
|
|---|
| 15 | ..S X=^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN),IBNAM=$P(X,"^")
|
|---|
| 16 | ..D CHKL Q:IBQUIT
|
|---|
| 17 | ..W:IBRPT="M" ! W !,SSN,?20,IBNAM,?45 S Y=IBDDT X ^DD("DD") W Y W ?70,IBENRLL
|
|---|
| 18 | ..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
|
|---|
| 19 | ...D CHKL Q:IBQUIT
|
|---|
| 20 | ...W !?5,^TMP("IBQLPL",$J,ENRLL,IBDDT,SSN,IBDAY)
|
|---|
| 21 | Q
|
|---|
| 22 | ;
|
|---|
| 23 | HDR ; -- print headers
|
|---|
| 24 | W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
|
|---|
| 25 | W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
|
|---|
| 26 | W !?(IOM-$L(IBHDR1)/2),IBHDR1
|
|---|
| 27 | W !!,?45,"DISCHARGE DATE"
|
|---|
| 28 | W !,"SSN",?20,"PATIENT NAME",?45,"FROM ACUTE CARE",?70,"ROLLUP"
|
|---|
| 29 | W !,$TR($J("",IOM)," ","-")
|
|---|
| 30 | Q
|
|---|
| 31 | ;
|
|---|
| 32 | CHKL ; -- check end of page
|
|---|
| 33 | I IOSL<($Y+3),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT W @IOF D HDR Q
|
|---|
| 34 | I IOSL<($Y+3) D HDR
|
|---|
| 35 | Q
|
|---|
| 36 | ;
|
|---|
| 37 | DTC ;
|
|---|
| 38 | 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)
|
|---|
| 39 | Q
|
|---|
