IBQLD2A ;LEB/MRY - PATIENT DOWNLOAD TO SPREADSHEET ; 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
 D HDR ;S IBHDR="UTILIZATION MANAGEMENT",IBHDR1="PATIENT REVIEWS FOR "_IBDRNG
 ;
 F  S IBSVC=$O(^TMP("IBQLD2",$J,IBSVC)) Q:IBSVC=""  D TS Q:IBQUIT
 G END
TS F  S IBTS=$O(^TMP("IBQLD2",$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"))_")"
 .I IBTY="I",'$D(IBTS(IBTS)) Q
 .D PLINE
 .S IBDDT="" F  S IBDDT=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT)) Q:'IBDDT  D  Q:IBQUIT
 ..S IBSSN="" F  S IBSSN=$O(^TMP("IBQLD2",$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("IBQLD2",$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("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"LOS"))
 S IBSACNT=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-AC"))
 S IBSNCNT=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-NAC"))
 K IBRSY S IBRSY=""
 F  S IBRSY=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)) Q:'IBRSY  D
 .S IBRSYCNT=^TMP("IBQLD2",$J,IBSVC,IBTS,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),"^",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)
 ;S RCNT="" F  S RCNT=$O(IBRSY(RCNT)) Q:'RCNT  D  ; for Download rpt. use F  S RCNT=$O(...
 ;.W "^",IBRSY(RCNT),"^",(9999-RCNT)
 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