58 lines
2.0 KiB
Mathematica
58 lines
2.0 KiB
Mathematica
IBQLD4A ;LEB/MRY - ACUTE/NON-ACUTE DOWNLOAD ; 17-MAY-95
|
|
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
; -- called from IBQLR1
|
|
PRINT S (IBTEXT,IBDATA,IBQUIT,IBHDR,IBDIAG)="",IBPAG=0 D MONTH
|
|
; -- call to return header dates, IBTDT, IBDRNG
|
|
D DTC^IBQLPL2
|
|
S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="ACUTE AND NON-ACUTE REPORT FOR "_IBDRNG,IBHDR1="ADMITTING DIAGNOSIS"
|
|
;
|
|
I '$D(^TMP("IBQLD4",$J)) W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
|
|
DIAG F S IBDIAG=$O(^TMP("IBQLD4",$J,IBDIAG)) Q:IBDIAG="" D Q:IBQUIT
|
|
.S IBSUBH="ADMITTING DIAGNOSIS: "_IBDIAG
|
|
.D PLINE
|
|
.F IBDAY=1,2 D Q:IBQUIT
|
|
..S (IBCAT,IBCATF)=""
|
|
..F S IBCAT=$O(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT)) Q:IBCAT="" D Q:IBQUIT
|
|
...I $E(IBCAT,1)="C" D ACUTE
|
|
...I $E(IBCAT,1)="R" D REASON
|
|
Q
|
|
;
|
|
END K IBTS,IBTEXT,IBDATA,IBQUIT,IBHDR,IBMONTH,IBMD,IBMTH,IBCAT,MSTRING,N,I,X,IBDAY,IBRES,IBCATF
|
|
Q
|
|
ACUTE ;
|
|
S IBMONTH=""
|
|
I IBDAY=2&('IBCATF) W !,"CONTINUED STAY DAYS" S IBCATF=1
|
|
S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
|
|
.S IBRES=$G(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT,IBMONTH)) S:'IBRES IBRES=0 D MDATA
|
|
D PLINE Q:IBQUIT
|
|
Q
|
|
REASON ;
|
|
S IBREA=""
|
|
W:IBDAY=1 !,"REASONS FOR NON-ACUTE ADMISSIONS" W:IBDAY=2 !,"REASONS FOR NON-ACUTE STAY DAYS"
|
|
F S IBREA=$O(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT,IBREA)) Q:'IBREA D Q:IBQUIT
|
|
.S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
|
|
..S IBRES=$G(^TMP("IBQLD4",$J,IBDIAG,IBDAY,IBCAT,IBREA,IBMONTH)) S:'IBRES IBRES=0 D MDATA
|
|
.D PLINE Q:IBQUIT
|
|
Q
|
|
MDATA ;
|
|
S IBMTH=+$E(IBMONTH,4,5),IBMD=$P(MSTRING,"^",IBMTH)
|
|
F I=1:1 S X=$P(IBTEXT,"^",I) Q:X=""!(X=IBMD)
|
|
I X'="" D
|
|
.S $P(IBDATA,"^",I)=IBRES
|
|
.S $P(IBDATA,"^",1)=$S(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
|
|
Q
|
|
;
|
|
PLINE ;
|
|
I $G(IBCAT)="" D
|
|
.W !!,IBSUBH,! S IBDATA=IBTEXT
|
|
W !,IBDATA
|
|
Q
|
|
;
|
|
MONTH ;
|
|
S MSTRING="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",X=""
|
|
F I=1:1 S X=$O(IBMONTH(X)) Q:'X D
|
|
.S IBTEXT=IBTEXT_$P(MSTRING,"^",+$E(X,4,5))_"^"
|
|
S IBTEXT="ADMISSIONS^"_IBTEXT
|
|
Q
|