source: WorldVistAEHR/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLR1.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1IBQLR1 ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 17-MAY-95
2 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;Oct 01, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 I '$D(DT) D DT^DICRW
6DATE W ! D DATE^IBOUTL
7 I IBBDT=""!(IBEDT="") G END
8 S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
9 S DIR(0)="SA^S:Services;T:Treating Specialties;A:Admitting Diagnosis",DIR("A")="Display Services, Treating Specialties, or Admitting Diagnosis? [S/T/A]: "
10 W ! D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
11 S IBTY=Y I IBTY="A" G DIAG^IBQLR4
12 I IBTY="S" S DIR(0)="SA^A:All Services;I:Individual Services",DIR("A")="Display ALL or INDIVIDUAL Services? [A/I]: "
13 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]: "
14 D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
15 S IBTY1=Y G:IBTY1="A" DEV
16 I IBTY="T" G TSI
17SVCI S DIR(0)="42.4,3O",DIR("A")="Enter SERVICE"
18 D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBSVC(""))="" SVCI G DEV
19 S IBSVC(Y)=Y(0) G SVCI
20TSI S DIR(0)="PO^45.7:AEQZ",DIR("A")="Enter TREATING SPECIALTY"
21 D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBTS(""))="" TSI G DEV
22 S IBTS(Y(0,0))="" G TSI
23DEV ; -- select device, run option
24 W ! S %ZIS="QM" D ^%ZIS G:POP END
25 I $D(IO("Q")) F I="IBTY","IBBDT","IBEDT","IBTS(","IBSVC(","IBTY1" S ZTSAVE(I)=""
26 I $D(IO("Q")) S ZTRTN="START^IBQLR1",ZTDESC="UM - ACUTE REPORT" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
27 U IO
28 ;
29START ;
30 K ^TMP("IBQLR1",$J) S IBDDT=IBBDT-.01,(IBPAG,IBQUIT,IBMCT)=0
31 F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
32 .S IBMONTH=$E(IBDDT,1,5) I '$D(IBMONTH(IBMONTH)) S IBMONTH(IBMONTH)="",IBMCT=IBMCT+1
33 .S IBTRN="" F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
34 ;
35 I $$STOP,$G(ZTSTOP) G END
36 D PRINT^IBQLR1A
37END ; -- Clean up
38 W ! K ^TMP("IBQLR1",$J),IB,IBMONTH,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTS,IBTY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBTRV,IBMONTH,MSTRING,IBREA,I,N,X,IBRES,IBCAT,IBMTH,IBMD,IBSVC
39 I $D(ZTQUEUED) S ZTREQ="@" Q
40 D ^%ZISC
41 Q
42 ;
43DATA ;
44ADMIT ; -- get Admission Review info.
45 D ADMIT^IBQL538
46 S IBSVC=IB(1.07),IBTS=IB(.12) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
47 I IBTY1="I" G:IBTY="S"&('$D(IBSVC(IBSVC))) STAY G:IBTY="T"&('$D(IBTS(IBTS))) STAY
48 ; -- count acute admissions
49 I IB("ACUTE ADMISSION") D
50 .S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,1,"CNTA",$E(IBDDT,1,5)))+1
51 ; -- count non-acute admissions
52 E D
53 .S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,1,"CNTN",$E(IBDDT,1,5)))+1
54 .F I=1:1 S IBR=$P(IB(1.03)," ",I) Q:'IBR S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,1,"REA",IBR,$E(IBDDT,1,5)))+1
55STAY ; --continued stay days
56 S IBTRV=0 F S IBTRV=$O(^IBQ(538,IBTRN,13,IBTRV)) Q:'IBTRV D
57 .D STAY^IBQL538
58 .S IBSVC=IB(13.08),IBTS=IB(13.07) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
59 .I IBTY1="I" Q:IBTY="S"&('$D(IBSVC(IBSVC))) Q:IBTY="T"&('$D(IBTS(IBTS)))
60 .I IB("ACUTE STAY") D
61 ..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,2,"CNTA",$E(IBDDT,1,5)))+1
62 .E D
63 ..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,2,"CNTN",$E(IBDDT,1,5)))+1
64 ..F I=1:1 S IBR=$P(IB(13.06)," ",I) Q:'IBR S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,2,"REA",IBR,$E(IBDDT,1,5)))+1
65 Q
66 ;
67STOP() ; determine if user has requested the queued report to stop
68 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTEQ I $G(IBPAG) W !,"***TASK STOPPED BY USER***"
69 Q +$G(ZTSTOP)
Note: See TracBrowser for help on using the repository browser.