| 1 | IBQLD2A ;LEB/MRY - PATIENT DOWNLOAD TO SPREADSHEET ; 1-JUN-95
|
|---|
| 2 | ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | PRINT D SVCTAB^IBQLR1B S (IBDATA,IBTS,IBQUIT,IBHDR,IBHDR1,IBSVC)="",IBPAG=0
|
|---|
| 6 | ; -- call to return header dates - IBTDT, IBDRNG
|
|---|
| 7 | D DTC^IBQLPL2
|
|---|
| 8 | D HDR ;S IBHDR="UTILIZATION MANAGEMENT",IBHDR1="PATIENT REVIEWS FOR "_IBDRNG
|
|---|
| 9 | ;
|
|---|
| 10 | F S IBSVC=$O(^TMP("IBQLD2",$J,IBSVC)) Q:IBSVC="" D TS Q:IBQUIT
|
|---|
| 11 | G END
|
|---|
| 12 | TS F S IBTS=$O(^TMP("IBQLD2",$J,IBSVC,IBTS)) Q:IBTS="" D Q:IBQUIT
|
|---|
| 13 | .I IBTS=999 S IBSUBH=$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
|
|---|
| 14 | .E S IBSUBH=IBTS_",("_$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
|
|---|
| 15 | .I IBTY="I",'$D(IBTS(IBTS)) Q
|
|---|
| 16 | .D PLINE
|
|---|
| 17 | .S IBDDT="" F S IBDDT=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT)) Q:'IBDDT D Q:IBQUIT
|
|---|
| 18 | ..S IBSSN="" F S IBSSN=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN)) Q:'IBSSN D DATA Q:IBQUIT
|
|---|
| 19 | Q
|
|---|
| 20 | ;
|
|---|
| 21 | END K IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD
|
|---|
| 22 | Q
|
|---|
| 23 | ;
|
|---|
| 24 | DATA ;
|
|---|
| 25 | S IBDATA=^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN)
|
|---|
| 26 | S IBADM=$P(IBDATA,"^"),IBADIAG=$P(IBDATA,"^",2),IBENRLL=$P(IBDATA,"^",3)
|
|---|
| 27 | S IBPHYAD=$P(IBDATA,"^",4),IBPHYAT=$P(IBDATA,"^",5),IBPHYRS=$P(IBDATA,"^",6)
|
|---|
| 28 | S IBAAD=$P(IBDATA,"^",7),IBNAD=$P(IBDATA,"^",8),IBRAD=$P(IBDATA,"^",9)
|
|---|
| 29 | S IBLOS=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"LOS"))
|
|---|
| 30 | S IBSACNT=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-AC"))
|
|---|
| 31 | S IBSNCNT=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-NAC"))
|
|---|
| 32 | K IBRSY S IBRSY=""
|
|---|
| 33 | F S IBRSY=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
|
|---|
| 34 | .S IBRSYCNT=^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)
|
|---|
| 35 | .S IBRSY(9999-IBRSYCNT,IBRSY)=""
|
|---|
| 36 | D PLINE
|
|---|
| 37 | Q
|
|---|
| 38 | ;
|
|---|
| 39 | PLINE ;
|
|---|
| 40 | I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
|
|---|
| 41 | W !,IBSSN,"^" S IBDT=IBADM D DTC W IBDT W "^" S IBDT=IBDDT D DTC W IBDT
|
|---|
| 42 | W "^",IBADIAG,"^",IBENRLL,"^",IBAAD,"^",IBNAD,"^",$P(IBRAD," "),"^",$P(IBRAD," ",2),"^",$P(IBRAD," ",3),"^",IBLOS,"^",IBSACNT,"^",IBSNCNT
|
|---|
| 43 | S RCNT="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT S REA="" D
|
|---|
| 44 | .F S REA=$O(IBRSY(RCNT,REA)) Q:REA="" D
|
|---|
| 45 | ..W "^",REA,"^",(9999-RCNT)
|
|---|
| 46 | ;S RCNT="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
|
|---|
| 47 | ;.W "^",IBRSY(RCNT),"^",(9999-RCNT)
|
|---|
| 48 | Q
|
|---|
| 49 | ;
|
|---|
| 50 | HDR ;
|
|---|
| 51 | W !!,"^ADMIT^DISCH^^ENRLL^^^A-REA^A-REA^A-REA^^#AC^#N-AC"
|
|---|
| 52 | F I=1:1:IBLVH D ; for Download rpt. use F I=1:1:IBLVH
|
|---|
| 53 | .W "^",$J("S-REA",6),"^"
|
|---|
| 54 | W !,"SSN^DATE^DATE^DIAG^R-D-L^A^N^1^2^3^#LOS^DAYS^DAYS"
|
|---|
| 55 | F I=1:1:IBLVH D ; for Download rpt. use F I=1:1:IBLVH
|
|---|
| 56 | .W "^",$J(I,1),"^",$J("CNT",3)
|
|---|
| 57 | Q
|
|---|
| 58 | ;
|
|---|
| 59 | DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
|
|---|
| 60 | Q
|
|---|
