| 1 | IBQLR1A ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 13-JUL-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
|
|---|
| 5 | PRINT D SVCTAB^IBQLR1B S (IBTEXT,IBDATA,IBTS,IBQUIT,IBHDR,IBSVC)="",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 S:IBTY="S" IBHDR1="SERVICE" S:IBTY="T" IBHDR1="TREATING SPECIALTY,(SERVICE)"
|
|---|
| 9 | ;
|
|---|
| 10 | F S IBSVC=$O(^TMP("IBQLR1",$J,IBSVC)) Q:IBSVC="" D TS Q:IBQUIT
|
|---|
| 11 | G END
|
|---|
| 12 | TS F S IBTS=$O(^TMP("IBQLR1",$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 | .D PLINE
|
|---|
| 16 | .F IBDAY=1,2 D Q:IBQUIT
|
|---|
| 17 | ..S (IBCAT,IBCATF)=""
|
|---|
| 18 | ..F S IBCAT=$O(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT)) Q:IBCAT="" D Q:IBQUIT
|
|---|
| 19 | ...I $E(IBCAT,1)="C" D ACUTE
|
|---|
| 20 | ...I $E(IBCAT,1)="R" D REASON
|
|---|
| 21 | Q
|
|---|
| 22 | ;
|
|---|
| 23 | END K IBTS,IBTEXT,IBDATA,IBQUIT,IBHDR,IBMONTH,IBMD,IBMTH,IBCAT,MSTRING,N,I,X,IBDAY,IBRES,IBCATF
|
|---|
| 24 | Q
|
|---|
| 25 | ACUTE ;
|
|---|
| 26 | S IBMONTH=""
|
|---|
| 27 | I IBDAY=2&('IBCATF) W !,?3,"CONTINUED STAY REVIEWS" S IBCATF=1
|
|---|
| 28 | S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
|
|---|
| 29 | .S IBRES=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH)) S:'IBRES IBRES=0 D MDATA
|
|---|
| 30 | D PLINE Q:IBQUIT
|
|---|
| 31 | Q
|
|---|
| 32 | REASON ;
|
|---|
| 33 | S IBREA=""
|
|---|
| 34 | W:IBDAY=1 !,?3,"REASONS FOR NON-ACUTE ADMISSIONS" W:IBDAY=2 !,?3,"REASONS FOR NON-ACUTE CONTINUED STAYS"
|
|---|
| 35 | F S IBREA=$O(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBREA)) Q:'IBREA D Q:IBQUIT
|
|---|
| 36 | .S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
|
|---|
| 37 | ..S IBRES=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBREA,IBMONTH)) S:'IBRES IBRES=0 D MDATA
|
|---|
| 38 | .D PLINE Q:IBQUIT
|
|---|
| 39 | Q
|
|---|
| 40 | MDATA ;
|
|---|
| 41 | S IBMTH=+$E(IBMONTH,4,5),IBMD=$P(MSTRING,"^",IBMTH)
|
|---|
| 42 | F I=1:1 S X=$P(IBTEXT,",",I) Q:X=""!(X=IBMD)
|
|---|
| 43 | I X'="" D
|
|---|
| 44 | .S $P(IBDATA,",",I)=IBRES
|
|---|
| 45 | .;.S $P(IBDATA,",",I)=$S($E(IBCAT,1)="C":^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH),$E(IBCAT,1)="R":^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBREA,IBMONTH),1:"")
|
|---|
| 46 | .S $P(IBDATA,",",1)=$S(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
|
|---|
| 47 | Q
|
|---|
| 48 | ;
|
|---|
| 49 | PLINE ;
|
|---|
| 50 | I IBPAG=0 D HDR
|
|---|
| 51 | I $G(IBCAT)="" D
|
|---|
| 52 | .W !!,IBSUBH,! S IBDATA=IBTEXT
|
|---|
| 53 | F I=1:1 Q:$P(IBDATA,",",I)="" D
|
|---|
| 54 | .I I=1 W ! W:$G(IBCAT)="" ?3 W:$G(IBCAT)'="" ?5 W $P(IBDATA,","),?30
|
|---|
| 55 | .E W $J($P(IBDATA,",",I),3)_" "
|
|---|
| 56 | D CHKL Q:IBQUIT
|
|---|
| 57 | Q
|
|---|
| 58 | HDR ; -- print headers
|
|---|
| 59 | W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
|
|---|
| 60 | W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
|
|---|
| 61 | W !?(IOM-$L(IBHDR1)/2),IBHDR1,!,?(IOM-$L(IBHDR2)/2),IBHDR2
|
|---|
| 62 | W !,$TR($J("",IOM)," ","-")
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | CHKL ; -- check end of page
|
|---|
| 66 | I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT W @IOF D HDR Q
|
|---|
| 67 | I $E(IOST,1,2)'="C-",IOSL<($Y+5) D HDR
|
|---|
| 68 | Q
|
|---|
| 69 | ;
|
|---|
| 70 | MONTH ;
|
|---|
| 71 | S MSTRING="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",X=""
|
|---|
| 72 | F I=1:1 S X=$O(IBMONTH(X)) Q:'X D
|
|---|
| 73 | .S IBTEXT=IBTEXT_$P(MSTRING,"^",+$E(X,4,5))_","
|
|---|
| 74 | S IBTEXT="ADMISSION REVIEWS"_","_IBTEXT
|
|---|
| 75 | Q
|
|---|
