40 lines
1.7 KiB
Mathematica
40 lines
1.7 KiB
Mathematica
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
|