IBQLD3A ;LEB/MRY - PROVIDER/PATIENT DOWNLOAD ; 1-SEP-95
 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PRINT S (IBDATA,IBQUIT,IBHDR,IBHDR1,IBPHY)="",IBPAG=0
 ; -- call to return header dates - IBTDT, IBDRNG
 D DTC^IBQLPL2
 D HDR I '$D(^TMP("IBQLD3",$J)) W !!,?20,"<<<   NO PATIENTS TO PRINT   >>>" Q
 ;
 F  S IBPHY=$O(^TMP("IBQLD3",$J,IBPHY)) Q:IBPHY=""  D  Q:IBQUIT
 .S IBSUBH=IBTYD_": "_IBPHY
 .D PLINE
 .S IBDDT="" F  S IBDDT=$O(^TMP("IBQLD3",$J,IBPHY,IBDDT)) Q:'IBDDT  D  Q:IBQUIT
 ..S IBSSN="" F  S IBSSN=$O(^TMP("IBQLD3",$J,IBPHY,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("IBQLD3",$J,IBPHY,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 IBCHK=$P(IBDATA,"^",10) I IBCHK=1 D PLINE Q
 S IBLOS=$G(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"LOS"))
 S IBSACNT=$G(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"S-AC"))
 S IBSNCNT=$G(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"S-NAC"))
 K IBRSY S IBRSY=""
 F  S IBRSY=$O(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,IBRSY)) Q:'IBRSY  D
 .S IBRSYCNT=^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,IBRSY)
 .S IBRSY(9999-IBRSYCNT,IBRSY)=""
 D PLINE
 Q
 ;
PLINE ;
 I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
 W !,IBSSN,"^" S IBDT=IBADM D DTC W IBDT W "^" S IBDT=IBDDT D DTC W IBDT
 W "^",IBADIAG,"^",IBENRLL,"^",IBAAD,"^",IBNAD,"^",$P(IBRAD," "),"^",$P(IBRAD," ",2),"^",$P(IBRAD," ",3)
 I IBCHK=1 W "^ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA." Q
 W "^",IBLOS,"^",IBSACNT,"^",IBSNCNT
 S RCNT="" F  S RCNT=$O(IBRSY(RCNT)) Q:'RCNT  S REA="" D
 .F  S REA=$O(IBRSY(RCNT,REA)) Q:REA=""  D
 ..W "^",REA,"^",(9999-RCNT)
 ;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 !!,"^ADMIT^DISCH^^ENRLL^^^A-REA^A-REA^A-REA^^#AC^#N-AC"
 F I=1:1:IBLVH D  ; for Download rpt. use F I=1:1:IBLVH
 .W "^",$J("S-REA",6),"^"
 W !,"SSN^DATE^DATE^DIAG^R-D-L^A^N^1^2^3^#LOS^DAYS^DAYS"
 F I=1:1:IBLVH D  ; for Download rpt. use F I=1:1:IBLVH
 .W "^",$J(I,1),"^",$J("CNT",3)
 Q
 ;
DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
 Q