source: WorldVistAEHR/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLD2A.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1IBQLD2A ;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 ;
5PRINT 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
12TS 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 ;
21END 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 ;
24DATA ;
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 ;
39PLINE ;
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 ;
50HDR ;
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 ;
59DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
60 Q
Note: See TracBrowser for help on using the repository browser.