Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBQLR4A

IBQLR4A.m

Go to the documentation of this file.
  1. IBQLR4A ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 13-JUL-95
  1. ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ; -- called from IBQLR1
  1. PRINT S (IBTEXT,IBDATA,IBQUIT,IBHDR,IBDIAG)="",IBPAG=0 D MONTH
  1. ; -- call to return header dates, IBTDT, IBDRNG
  1. D DTC^IBQLPL2
  1. S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="ACUTE AND NON-ACUTE REPORT FOR "_IBDRNG,IBHDR1="ADMITTING DIAGNOSIS"
  1. ;
  1. I '$D(^TMP("IBQLR4",$J)) D HDR W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
  1. DIAG F S IBDIAG=$O(^TMP("IBQLR4",$J,IBDIAG)) Q:IBDIAG="" D Q:IBQUIT
  1. .S IBSUBH="ADMITTING DIAGNOSIS: "_IBDIAG
  1. .D PLINE
  1. .F IBDAY=1,2 D Q:IBQUIT
  1. ..S (IBCAT,IBCATF)=""
  1. ..F S IBCAT=$O(^TMP("IBQLR4",$J,IBDIAG,IBDAY,IBCAT)) Q:IBCAT="" D Q:IBQUIT
  1. ...I $E(IBCAT,1)="C" D ACUTE
  1. ...I $E(IBCAT,1)="R" D REASON
  1. Q
  1. ;
  1. END K IBTS,IBTEXT,IBDATA,IBQUIT,IBHDR,IBMONTH,IBMD,IBMTH,IBCAT,MSTRING,N,I,X,IBDAY,IBRES,IBCATF
  1. Q
  1. ACUTE ;
  1. S IBMONTH=""
  1. I IBDAY=2&('IBCATF) W !,?3,"CONTINUED STAY REVIEWS" S IBCATF=1
  1. S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
  1. .S IBRES=$G(^TMP("IBQLR4",$J,IBDIAG,IBDAY,IBCAT,IBMONTH)) S:'IBRES IBRES=0 D MDATA
  1. D PLINE Q:IBQUIT
  1. Q
  1. REASON ;
  1. S IBREA=""
  1. W:IBDAY=1 !,?3,"REASONS FOR NON-ACUTE ADMISSIONS" W:IBDAY=2 !,?3,"REASONS FOR NON-ACUTE CONTINUED STAYS"
  1. F S IBREA=$O(^TMP("IBQLR4",$J,IBDIAG,IBDAY,IBCAT,IBREA)) Q:'IBREA D Q:IBQUIT
  1. .S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
  1. ..S IBRES=$G(^TMP("IBQLR4",$J,IBDIAG,IBDAY,IBCAT,IBREA,IBMONTH)) S:'IBRES IBRES=0 D MDATA
  1. .D PLINE Q:IBQUIT
  1. Q
  1. MDATA ;
  1. S IBMTH=+$E(IBMONTH,4,5),IBMD=$P(MSTRING,"^",IBMTH)
  1. F I=1:1 S X=$P(IBTEXT,",",I) Q:X=""!(X=IBMD)
  1. I X'="" D
  1. .S $P(IBDATA,",",I)=IBRES
  1. .;.S $P(IBDATA,",",I)=$S($E(IBCAT,1)="C":^TMP("IBQLR4",$J,IBDIAG,IBDAY,IBCAT,IBMONTH),$E(IBCAT,1)="R":^TMP("IBQLR4",$J,IBDIAG,IBDAY,IBCAT,IBREA,IBMONTH),1:"")
  1. .S $P(IBDATA,",",1)=$S(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
  1. Q
  1. ;
  1. PLINE ;
  1. I IBPAG=0 D HDR
  1. I $G(IBCAT)="" D
  1. .W !!,IBSUBH,! S IBDATA=IBTEXT
  1. F I=1:1 Q:$P(IBDATA,",",I)="" D
  1. .I I=1 W ! W:$G(IBCAT)="" ?3 W:$G(IBCAT)'="" ?5 W $P(IBDATA,","),?30
  1. .E W $J($P(IBDATA,",",I),3)_" "
  1. D CHKL Q:IBQUIT
  1. Q
  1. HDR ; -- print headers
  1. W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
  1. W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
  1. W !?(IOM-$L(IBHDR1)/2),IBHDR1,!,?(IOM-$L(IBHDR2)/2),IBHDR2
  1. W !,$TR($J("",IOM)," ","-")
  1. Q
  1. ;
  1. CHKL ; -- check end of page
  1. I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT W @IOF D HDR Q
  1. I $E(IOST,1,2)'="C-",IOSL<($Y+5) D HDR
  1. Q
  1. ;
  1. MONTH ;
  1. S MSTRING="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",X=""
  1. F I=1:1 S X=$O(IBMONTH(X)) Q:'X D
  1. .S IBTEXT=IBTEXT_$P(MSTRING,"^",+$E(X,4,5))_","
  1. S IBTEXT="ADMISSION REVIEWS"_","_IBTEXT
  1. Q