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

IBQLR3A.m

Go to the documentation of this file.
  1. IBQLR3A ;LEB/MRY - PROVIDER/PATIENT REPORT ; 1-SEP-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. ;
  1. PRINT S (IBDATA,IBQUIT,IBHDR,IBHDR1,IBPHY)="",IBPAG=0
  1. ; -- call to return header dates - IBTDT, IBDRNG
  1. D DTC^IBQLPL2
  1. S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="PATIENT REVIEWS FOR "_IBDRNG,IBHDR1="PROVIDER"
  1. ;
  1. I '$D(^TMP("IBQLR3",$J)) D HDR W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
  1. F S IBPHY=$O(^TMP("IBQLR3",$J,IBPHY)) Q:IBPHY="" D G:IBQUIT END
  1. .S IBSUBH=IBTYD_": "_IBPHY
  1. .D PLINE Q:IBQUIT
  1. .S IBDDT="" F S IBDDT=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT)) Q:'IBDDT D Q:IBQUIT
  1. ..S IBSSN="" F S IBSSN=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN)) Q:'IBSSN D DATA Q:IBQUIT
  1. Q
  1. ;
  1. END K IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD,IBCHK
  1. Q
  1. ;
  1. DATA ;
  1. S IBDATA=^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN)
  1. S IBADM=$P(IBDATA,"^"),IBADIAG=$P(IBDATA,"^",2),IBENRLL=$P(IBDATA,"^",3)
  1. S IBPHYAD=$P(IBDATA,"^",4),IBPHYAT=$P(IBDATA,"^",5),IBPHYRS=$P(IBDATA,"^",6)
  1. S IBAAD=$P(IBDATA,"^",7),IBNAD=$P(IBDATA,"^",8),IBRAD=$P(IBDATA,"^",9)
  1. S IBCHK=$P(IBDATA,"^",10) I IBCHK=1 D PLINE Q
  1. S IBLOS=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"LOS"))
  1. S IBSACNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-AC"))
  1. S IBSNCNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-NAC"))
  1. K IBRSY S IBRSY=""
  1. F S IBRSY=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
  1. .S IBRSYCNT=^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,IBRSY)
  1. .S IBRSY(9999-IBRSYCNT,IBRSY)=""
  1. D PLINE
  1. Q
  1. ;
  1. PLINE ;
  1. I IBPAG=0 D HDR
  1. D CHKL Q:IBQUIT
  1. I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
  1. W !,IBSSN,?11 S IBDT=IBADM D DTC W $J(IBDT,8) W ?20 S IBDT=IBDDT D DTC W $J(IBDT,8)
  1. W ?29,IBADIAG,?37,IBENRLL,?45,$P(IBRAD," "),?52,$P(IBRAD," ",2)
  1. I IBCHK=1 W ?58,"ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA." Q
  1. W ?58,$J(IBLOS,4),?63,$J(IBSACNT,4),?68,$J(IBSNCNT,4)
  1. W ?73 S (RCNT,CNT)="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT S REA="" D Q:CNT=4
  1. .F S REA=$O(IBRSY(RCNT,REA)) Q:REA="" D Q:CNT=4
  1. ..W ?($X+2),$J(REA_"/"_(9999-RCNT),8)," " S CNT=CNT+1
  1. ;W ?85 S RCNT="" F I=1:1:3 S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
  1. ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
  1. Q
  1. ;
  1. HDR ;
  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 !!,?11,"ADMIT",?20,"DISCH",?37,"ENRLL",?45,"ADM. REASONS",?63,"#AC",?68,"#N-AC"
  1. W ?76,"C O N T I N U E D S T A Y R E A S O N S"
  1. ;W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
  1. ;.W ?($X+2),$J("S-REA",6),?($X+2)," "
  1. W !,"SSN",?11,"DATE",?20,"DATE",?29,"DIAG",?37,"R-D-L",?45,"1",?52,"2",?58,"#LOS",?63,"DAYS",?68,"DAYS"
  1. W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
  1. .W ?($X+2),$J(I_"/CNT",6),?($X+2)," "
  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 IOSL<($Y+5) D HDR
  1. Q
  1. ;
  1. DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
  1. Q