source: WorldVistAEHR/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLD4A.m@ 1000

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1IBQLD4A ;LEB/MRY - ACUTE/NON-ACUTE DOWNLOAD ; 17-MAY-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 ; -- called from IBQLR1
5PRINT S (IBTEXT,IBDATA,IBQUIT,IBHDR,IBDIAG)="",IBPAG=0 D MONTH
6 ; -- call to return header dates, IBTDT, IBDRNG
7 D DTC^IBQLPL2
8 S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="ACUTE AND NON-ACUTE REPORT FOR "_IBDRNG,IBHDR1="ADMITTING DIAGNOSIS"
9 ;
10 I '$D(^TMP("IBQLD4",$J)) W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
11DIAG F S IBDIAG=$O(^TMP("IBQLD4",$J,IBDIAG)) Q:IBDIAG="" D Q:IBQUIT
12 .S IBSUBH="ADMITTING DIAGNOSIS: "_IBDIAG
13 .D PLINE
14 .F IBDAY=1,2 D Q:IBQUIT
15 ..S (IBCAT,IBCATF)=""
16 ..F S IBCAT=$O(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT)) Q:IBCAT="" D Q:IBQUIT
17 ...I $E(IBCAT,1)="C" D ACUTE
18 ...I $E(IBCAT,1)="R" D REASON
19 Q
20 ;
21END K IBTS,IBTEXT,IBDATA,IBQUIT,IBHDR,IBMONTH,IBMD,IBMTH,IBCAT,MSTRING,N,I,X,IBDAY,IBRES,IBCATF
22 Q
23ACUTE ;
24 S IBMONTH=""
25 I IBDAY=2&('IBCATF) W !,"CONTINUED STAY DAYS" S IBCATF=1
26 S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
27 .S IBRES=$G(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT,IBMONTH)) S:'IBRES IBRES=0 D MDATA
28 D PLINE Q:IBQUIT
29 Q
30REASON ;
31 S IBREA=""
32 W:IBDAY=1 !,"REASONS FOR NON-ACUTE ADMISSIONS" W:IBDAY=2 !,"REASONS FOR NON-ACUTE STAY DAYS"
33 F S IBREA=$O(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT,IBREA)) Q:'IBREA D Q:IBQUIT
34 .S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
35 ..S IBRES=$G(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT,IBREA,IBMONTH)) S:'IBRES IBRES=0 D MDATA
36 .D PLINE Q:IBQUIT
37 Q
38MDATA ;
39 S IBMTH=+$E(IBMONTH,4,5),IBMD=$P(MSTRING,"^",IBMTH)
40 F I=1:1 S X=$P(IBTEXT,"^",I) Q:X=""!(X=IBMD)
41 I X'="" D
42 .S $P(IBDATA,"^",I)=IBRES
43 .S $P(IBDATA,"^",1)=$S(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
44 Q
45 ;
46PLINE ;
47 I $G(IBCAT)="" D
48 .W !!,IBSUBH,! S IBDATA=IBTEXT
49 W !,IBDATA
50 Q
51 ;
52MONTH ;
53 S MSTRING="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",X=""
54 F I=1:1 S X=$O(IBMONTH(X)) Q:'X D
55 .S IBTEXT=IBTEXT_$P(MSTRING,"^",+$E(X,4,5))_"^"
56 S IBTEXT="ADMISSIONS^"_IBTEXT
57 Q
Note: See TracBrowser for help on using the repository browser.