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

IBQLR2.m

Go to the documentation of this file.
  1. IBQLR2 ;LEB/MRY - PATIENT REPORT ; 17-MAY-95
  1. ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;Oct 01, 1995
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. I '$D(DT) D DT^DICRW
  1. DATE W ! D DATE^IBOUTL
  1. I IBBDT=""!(IBEDT="") G END
  1. S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
  1. S DIR(0)="SA^S:Services;T:Treating Specialties;P:Providers",DIR("A")="Display Services,Treating Specialties, or Providers? [S/T/P]: "
  1. W ! D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
  1. S IBTY=Y G:IBTY="P" PHY^IBQLR3
  1. I IBTY="S" S DIR(0)="SA^A:All Services;I:Individual Services",DIR("A")="Display ALL or INDIVIDUAL Services? [A/I]: "
  1. I IBTY="T" S DIR(0)="SA^A:All Treating Specialties;I:Individual Treating Specialties",DIR("A")="Display ALL or INDIVIDUAL Treating Specialties? [A/I]: "
  1. D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
  1. S IBTY1=Y G:IBTY1="A" DEV
  1. I IBTY="T" G TSI
  1. SVCI S DIR(0)="42.4,3O",DIR("A")="Enter SERVICE"
  1. D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBSVC(""))="" SVCI G DEV
  1. S IBSVC(Y)=Y(0) G SVCI
  1. TSI S DIR(0)="PO^45.7:AEQZ",DIR("A")="Enter TREATING SPECIALTY"
  1. D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBTS(""))="" TSI G DEV
  1. S IBTS(Y(0,0))="" G TSI
  1. DEV ; -- select device, run option
  1. W ! S %ZIS="QM" D ^%ZIS G:POP END
  1. I $D(IO("Q")) F I="IBTY","IBBDT","IBEDT","IBTS(","IBSVC(","IBTY1" S ZTSAVE(I)=""
  1. I $D(IO("Q")) S ZTRTN="START^IBQLR2",ZTDESC="UM - ACUTE REPORT" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
  1. U IO
  1. ;
  1. START ;
  1. K ^TMP("IBQLR2",$J) S IBDDT=IBBDT-.01,(IBPAG,IBQUIT,IBLVH)=0
  1. F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
  1. .S IBTRN="" F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
  1. ;
  1. I $$STOP,$G(ZTSTOP) G END
  1. D PRINT^IBQLR2A
  1. END ; -- Clean up
  1. W ! K ^TMP("IBQLR2",$J),IB,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTS,IBTY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBREA,IBLV,IBLVH,I,N,X,IBSVC
  1. I $D(ZTQUEUED) S ZTREQ="@" Q
  1. D ^%ZISC
  1. Q
  1. ;
  1. DATA ;
  1. ADMIT ; -- get Admission Review info.
  1. S IBLV=0 D ADMIT^IBQL538
  1. S IBSVC=IB(1.07),IBTS=IB(.12) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
  1. I IBTY1="I" G:IBTY="S"&('$D(IBSVC(IBSVC))) STAY G:IBTY="T"&('$D(IBTS(IBTS))) STAY
  1. S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_IB("ACUTE ADMISSION")_"^"_$S('IB("ACUTE ADMISSION"):1,1:"")_"^"_IB(1.03)
  1. S ^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
  1. S ^("LOS")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
  1. I IB("ACUTE ADMISSION") S ^("S-AC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
  1. E S ^("S-NAC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
  1. STAY ; -- get Stay Review info.
  1. S IBTRV=0 F S IBTRV=$O(^IBQ(538,IBTRN,13,IBTRV)) Q:'IBTRV D
  1. .D STAY^IBQL538
  1. .S IBSVC=IB(13.08),IBTS=IB(13.07) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
  1. .I IBTY1="I" Q:IBTY="S"&('$D(IBSVC(IBSVC))) Q:IBTY="T"&('$D(IBTS(IBTS)))
  1. .I '$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03))) D
  1. ..S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_"^"_"^"
  1. ..S ^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
  1. .F I=1:1:3 S REA=$P(IB(13.06)," ",I) Q:'REA D
  1. ..I '$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),+REA)) S IBLV=IBLV+1
  1. ..S ^(+REA)=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),+REA))+1
  1. .S ^("LOS")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
  1. .I IB("ACUTE STAY") S ^("S-AC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
  1. .E S ^("S-NAC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
  1. .I IBLV>IBLVH S IBLVH=IBLV
  1. Q
  1. ;
  1. STOP() ; determine if user has requested the queued report to stop
  1. I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPAG) W !,"***TASK STOPPED BY USER***"
  1. Q +$G(ZTSTOP)