- 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 Feb 19, 2025@00:07:36 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