source: FOIAVistA/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLR2A.m@ 1183

IBQLR2A ;LEB/MRY - PATIENT REPORT ; 1-JUN-95
 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PRINT D SVCTAB^IBQLR1B S (IBDATA,IBTS,IBQUIT,IBHDR,IBHDR1,IBSVC)="",IBPAG=0
 ; -- call to return header dates - IBTDT, IBDRNG
 D DTC^IBQLPL2
 S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="PATIENT REVIEWS FOR "_IBDRNG S:IBTY="S" IBHDR1="SERVICE" S:IBTY="T" IBHDR1="TREATING SPECIALTY,(SERVICE)"
 ;
 I '$D(^TMP("IBQLR2",$J)) D HDR W !!,?20,"<<<   NO PATIENTS TO PRINT   >>>" Q
 F  S IBSVC=$O(^TMP("IBQLR2",$J,IBSVC)) Q:IBSVC=""  D TS Q:IBQUIT
 G END
TS F  S IBTS=$O(^TMP("IBQLR2",$J,IBSVC,IBTS)) Q:IBTS=""  D  Q:IBQUIT
 .I IBTS=999 S IBSUBH=$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
 .E  S IBSUBH=IBTS_",("_$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
 .D PLINE
 .S IBDDT="" F  S IBDDT=$O(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT)) Q:'IBDDT  D  Q:IBQUIT
 ..S IBSSN="" F  S IBSSN=$O(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN)) Q:'IBSSN  D DATA Q:IBQUIT
 Q
 ;
END K IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD
 Q
 ;
DATA ;
 S IBDATA=^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN)
 S IBADM=$P(IBDATA,"^"),IBADIAG=$P(IBDATA,"^",2),IBENRLL=$P(IBDATA,"^",3)
 S IBPHYAD=$P(IBDATA,"^",4),IBPHYAT=$P(IBDATA,"^",5),IBPHYRS=$P(IBDATA,"^",6)
 S IBAAD=$P(IBDATA,"^",7),IBNAD=$P(IBDATA,"^",8),IBRAD=$P(IBDATA,"^",9)
 S IBLOS=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,"LOS"))
 S IBSACNT=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-AC"))
 S IBSNCNT=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-NAC"))
 K IBRSY S IBRSY=""
 F  S IBRSY=$O(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)) Q:'IBRSY  D
 .S IBRSYCNT=^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)
 .S IBRSY(9999-IBRSYCNT,IBRSY)=""
 D PLINE
 Q
 ;
PLINE ;
 I IBPAG=0 D HDR
 D CHKL Q:IBQUIT
 I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
 W !,IBSSN,?11 S IBDT=IBADM D DTC W $J(IBDT,8) W ?20 S IBDT=IBDDT D DTC W $J(IBDT,8)
 W ?29,IBADIAG,?37,IBENRLL,?45,$P(IBRAD," "),?52,$P(IBRAD," ",2),?58,$J(IBLOS,4),?63,$J(IBSACNT,4),?68,$J(IBSNCNT,4)
 W ?73 S (RCNT,CNT)="" F  S RCNT=$O(IBRSY(RCNT)) Q:'RCNT  S REA="" D  Q:CNT=4
 .F  S REA=$O(IBRSY(RCNT,REA)) Q:REA=""  D  Q:CNT=4
 ..W ?($X+2),$J(REA_"/"_(9999-RCNT),8),"   " S CNT=CNT+1
 ;W ?85 S RCNT="" F I=1:1:3 S RCNT=$O(IBRSY(RCNT)) Q:'RCNT  D  ; for Download rpt. use F  S RCNT=$O(...
 ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
 Q
 ;
HDR ;
 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,!,?(IOM-$L(IBHDR2)/2),IBHDR2
 W !!,?11,"ADMIT",?20,"DISCH",?37,"ENRLL",?45,"ADM. REASONS",?63,"#AC",?68,"#N-AC"
 W ?76,"C O N T I N U E D   S T A Y   R E A S O N S"
 ;W ?73 F I=1:1:4 D  ; for Download rpt. use F I=1:1:IBLVH
 ;.W ?($X+2),$J("S-REA",6),?($X+2),"   "
 W !,"SSN",?11,"DATE",?20,"DATE",?29,"DIAG",?37,"R-D-L",?45,"1",?52,"2",?58,"#LOS",?63,"DAYS",?68,"DAYS"
 W ?73 F I=1:1:4 D  ; for Download rpt. use F I=1:1:IBLVH
 .W ?($X+2),$J(I_"/CNT",6),?($X+2),"   "
 W !,$TR($J("",IOM)," ","-")
 Q
 ;
CHKL ; -- check end of page
 I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT  W @IOF D HDR Q
 I IOSL<($Y+5) D HDR
 Q
 ;
DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
 Q