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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLPL2 1741 printed Dec 13, 2024@02:41:21 Page 2
IBQLPL2 ;LEB/MRY - PRINT PATIENTS QUALIFY/MISSING LIST ; 15-APR-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
PRINT ;
+1 DO DTC
+2 IF IBRPT="Q"
SET IBHDR="PATIENTS TO BE ROLLED UP"
+3 IF IBRPT="M"
SET IBHDR="PATIENTS WITH MISSING DATA"
+4 SET IBHDR1=IBDRNG
DO HDR
IF '$DATA(^TMP("IBQLPL",$JOB))
WRITE !!,?20,"<<< NO PATIENTS TO PRINT >>>"
QUIT
+5 SET ENRLL=""
FOR
SET ENRLL=$ORDER(^TMP("IBQLPL",$JOB,ENRLL))
if ENRLL=""
QUIT
DO DISCH
+6 QUIT
DISCH SET IBENRLL=$SELECT(ENRLL="AA":"*NEITHER*",ENRLL="ZL":"LOCAL",(ENRLL="N")!(ENRLL="B"):"NATIONAL",1:"")
+1 SET IBDDT=""
FOR
SET IBDDT=$ORDER(^TMP("IBQLPL",$JOB,ENRLL,IBDDT))
if IBDDT=""
QUIT
Begin DoDot:1
+2 SET SSN=""
FOR
SET SSN=$ORDER(^TMP("IBQLPL",$JOB,ENRLL,IBDDT,SSN))
if SSN=""
QUIT
Begin DoDot:2
+3 SET X=^TMP("IBQLPL",$JOB,ENRLL,IBDDT,SSN)
SET IBNAM=$PIECE(X,"^")
+4 DO CHKL
if IBQUIT
QUIT
+5 if IBRPT="M"
WRITE !
WRITE !,SSN,?20,IBNAM,?45
SET Y=IBDDT
XECUTE ^DD("DD")
WRITE Y
WRITE ?70,IBENRLL
+6 IF $ORDER(^TMP("IBQLPL",$JOB,ENRLL,IBDDT,SSN,0))
SET IBDAY=0
FOR
SET IBDAY=$ORDER(^TMP("IBQLPL",$JOB,ENRLL,IBDDT,SSN,IBDAY))
if 'IBDAY
QUIT
Begin DoDot:3
+7 DO CHKL
if IBQUIT
QUIT
+8 WRITE !?5,^TMP("IBQLPL",$JOB,ENRLL,IBDDT,SSN,IBDAY)
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+9 QUIT
+10 ;
HDR ; -- print headers
+1 if $EXTRACT(IOST,1,2)["C-"!(IBPAG>0)
WRITE @IOF
SET IBPAG=IBPAG+1
+2 WRITE !,IBTDT,?(IOM-$LENGTH(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
+3 WRITE !?(IOM-$LENGTH(IBHDR1)/2),IBHDR1
+4 WRITE !!,?45,"DISCHARGE DATE"
+5 WRITE !,"SSN",?20,"PATIENT NAME",?45,"FROM ACUTE CARE",?70,"ROLLUP"
+6 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+7 QUIT
+8 ;
CHKL ; -- check end of page
+1 IF IOSL<($Y+3)
IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^VALM1
if $DATA(DIRUT)
SET IBQUIT=1
if IBQUIT
QUIT
WRITE @IOF
DO HDR
QUIT
+2 IF IOSL<($Y+3)
DO HDR
+3 QUIT
+4 ;
DTC ;
+1 DO NOW^%DTC
DO YX^%DTC
SET IBTDT=Y
SET IBDRNG=+$EXTRACT(IBBDT,4,5)_"/"_+$EXTRACT(IBBDT,6,7)_"/"_+$EXTRACT(IBBDT,2,3)_" - "_+$EXTRACT(IBEDT,4,5)_"/"_+$EXTRACT(IBEDT,6,7)_"/"_+$EXTRACT(IBEDT,2,3)
+2 QUIT
