source: FOIAVistA/tag/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLR1A.m@ 628

IBQLR1A ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 13-JUL-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 D SVCTAB^IBQLR1B S (IBTEXT,IBDATA,IBTS,IBQUIT,IBHDR,IBSVC)="",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 S:IBTY="S" IBHDR1="SERVICE" S:IBTY="T" IBHDR1="TREATING SPECIALTY,(SERVICE)"
 ;
 F  S IBSVC=$O(^TMP("IBQLR1",$J,IBSVC)) Q:IBSVC=""  D TS Q:IBQUIT
 G END
TS F  S IBTS=$O(^TMP("IBQLR1",$J,IBSVC,IBTS)) Q:IBTS=""  D  Q:IBQUIT
 .I IBTS=999 S IBSUBH=$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
 .E  S IBSUBH=IBTS_",("_$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
 .D PLINE
 .F IBDAY=1,2 D  Q:IBQUIT
 ..S (IBCAT,IBCATF)=""
 ..F  S IBCAT=$O(^TMP("IBQLR1",$J,IBSVC,IBTS,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 !,?3,"CONTINUED STAY REVIEWS" S IBCATF=1
 S IBMONTH="" F  S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH  D  Q:IBQUIT
 .S IBRES=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH)) S:'IBRES IBRES=0 D MDATA
 D PLINE Q:IBQUIT
 Q
REASON ;
 S IBREA=""
 W:IBDAY=1 !,?3,"REASONS FOR NON-ACUTE ADMISSIONS" W:IBDAY=2 !,?3,"REASONS FOR NON-ACUTE CONTINUED STAYS"
 F  S IBREA=$O(^TMP("IBQLR1",$J,IBSVC,IBTS,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("IBQLR1",$J,IBSVC,IBTS,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,",",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:"")
 .S $P(IBDATA,",",1)=$S(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
 Q
 ;
PLINE ;
 I IBPAG=0 D HDR
 I $G(IBCAT)="" D 
 .W !!,IBSUBH,! S IBDATA=IBTEXT
 F I=1:1 Q:$P(IBDATA,",",I)=""  D
 .I I=1 W ! W:$G(IBCAT)="" ?3 W:$G(IBCAT)'="" ?5 W $P(IBDATA,","),?30
 .E  W $J($P(IBDATA,",",I),3)_"   "
 D CHKL Q:IBQUIT
 Q
HDR ; -- print headers
 W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
 W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
 W !?(IOM-$L(IBHDR1)/2),IBHDR1,!,?(IOM-$L(IBHDR2)/2),IBHDR2
 W !,$TR($J("",IOM)," ","-")
 Q
 ;
CHKL ; -- check end of page
 I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT  W @IOF D HDR Q
 I $E(IOST,1,2)'="C-",IOSL<($Y+5) D HDR
 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="ADMISSION REVIEWS"_","_IBTEXT
 Q