source: WorldVistAEHR/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLR3A.m@ 1361

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

initial load of WorldVistAEHR
File size: 3.1 KB
Line 
1IBQLR3A ;LEB/MRY - PROVIDER/PATIENT REPORT ; 1-SEP-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 S (IBDATA,IBQUIT,IBHDR,IBHDR1,IBPHY)="",IBPAG=0
6 ; -- call to return header dates - IBTDT, IBDRNG
7 D DTC^IBQLPL2
8 S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="PATIENT REVIEWS FOR "_IBDRNG,IBHDR1="PROVIDER"
9 ;
10 I '$D(^TMP("IBQLR3",$J)) D HDR W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
11 F S IBPHY=$O(^TMP("IBQLR3",$J,IBPHY)) Q:IBPHY="" D G:IBQUIT END
12 .S IBSUBH=IBTYD_": "_IBPHY
13 .D PLINE Q:IBQUIT
14 .S IBDDT="" F S IBDDT=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT)) Q:'IBDDT D Q:IBQUIT
15 ..S IBSSN="" F S IBSSN=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN)) Q:'IBSSN D DATA Q:IBQUIT
16 Q
17 ;
18END K IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD,IBCHK
19 Q
20 ;
21DATA ;
22 S IBDATA=^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN)
23 S IBADM=$P(IBDATA,"^"),IBADIAG=$P(IBDATA,"^",2),IBENRLL=$P(IBDATA,"^",3)
24 S IBPHYAD=$P(IBDATA,"^",4),IBPHYAT=$P(IBDATA,"^",5),IBPHYRS=$P(IBDATA,"^",6)
25 S IBAAD=$P(IBDATA,"^",7),IBNAD=$P(IBDATA,"^",8),IBRAD=$P(IBDATA,"^",9)
26 S IBCHK=$P(IBDATA,"^",10) I IBCHK=1 D PLINE Q
27 S IBLOS=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"LOS"))
28 S IBSACNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-AC"))
29 S IBSNCNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-NAC"))
30 K IBRSY S IBRSY=""
31 F S IBRSY=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
32 .S IBRSYCNT=^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,IBRSY)
33 .S IBRSY(9999-IBRSYCNT,IBRSY)=""
34 D PLINE
35 Q
36 ;
37PLINE ;
38 I IBPAG=0 D HDR
39 D CHKL Q:IBQUIT
40 I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
41 W !,IBSSN,?11 S IBDT=IBADM D DTC W $J(IBDT,8) W ?20 S IBDT=IBDDT D DTC W $J(IBDT,8)
42 W ?29,IBADIAG,?37,IBENRLL,?45,$P(IBRAD," "),?52,$P(IBRAD," ",2)
43 I IBCHK=1 W ?58,"ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA." Q
44 W ?58,$J(IBLOS,4),?63,$J(IBSACNT,4),?68,$J(IBSNCNT,4)
45 W ?73 S (RCNT,CNT)="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT S REA="" D Q:CNT=4
46 .F S REA=$O(IBRSY(RCNT,REA)) Q:REA="" D Q:CNT=4
47 ..W ?($X+2),$J(REA_"/"_(9999-RCNT),8)," " S CNT=CNT+1
48 ;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(...
49 ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
50 Q
51 ;
52HDR ;
53 W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
54 W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
55 W !,?(IOM-$L(IBHDR1)/2),IBHDR1,!,?(IOM-$L(IBHDR2)/2),IBHDR2
56 W !!,?11,"ADMIT",?20,"DISCH",?37,"ENRLL",?45,"ADM. REASONS",?63,"#AC",?68,"#N-AC"
57 W ?76,"C O N T I N U E D S T A Y R E A S O N S"
58 ;W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
59 ;.W ?($X+2),$J("S-REA",6),?($X+2)," "
60 W !,"SSN",?11,"DATE",?20,"DATE",?29,"DIAG",?37,"R-D-L",?45,"1",?52,"2",?58,"#LOS",?63,"DAYS",?68,"DAYS"
61 W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
62 .W ?($X+2),$J(I_"/CNT",6),?($X+2)," "
63 W !,$TR($J("",IOM)," ","-")
64 Q
65 ;
66CHKL ; -- check end of page
67 I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT W @IOF D HDR Q
68 I IOSL<($Y+5) D HDR
69 Q
70 ;
71DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
72 Q
Note: See TracBrowser for help on using the repository browser.