| 1 | IBQLD4 ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 17-MAY-95
|
|---|
| 2 | ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | I '$D(DT) D DT^DICRW
|
|---|
| 6 | DATE 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 | DIAG S DIR(0)="SA^A:All Admitting Diagnosis;I:Individual Admitting Diagnosis",DIR("A")="Display ALL or INDIVIDUAL Admitting Diagnosis? [A/I]: "
|
|---|
| 10 | D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
|
|---|
| 11 | S IBTY=Y G:IBTY="A" DEV
|
|---|
| 12 | S DIR(0)="SA^R:Range;E:Exact Match",DIR("A")="Search by Range or Exact Match? [R/E]: "
|
|---|
| 13 | D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
|
|---|
| 14 | S IBTY1=Y G:IBTY1="E" DIAGI
|
|---|
| 15 | S DIC="^ICD9(",DIC(0)="AMEQZ"
|
|---|
| 16 | S DIC("A")="Start with ADMITTING DIAGNOSIS: " D ^DIC G END:Y'>0 S DG1=Y(0,0),DG1=$E(DG1,1,$L(DG1)-1)_$C($A(DG1,$L(DG1))-1)_"zzzzzz"
|
|---|
| 17 | F S DIC("A")="Go to ADMITTING DIAGNOSIS: " D ^DIC Q:Y'>0 S DG6=Y(0,0) I DG6']DG1 W !,"Must be after start code",! G F
|
|---|
| 18 | G DEV
|
|---|
| 19 | DIAGI S DIR(0)="PO^80:AEQMZ",DIR("A")="Enter ADMITTING DIAGNOSIS"
|
|---|
| 20 | D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBDIAG(""))="" DIAGI G DEV
|
|---|
| 21 | S IBDIAG(Y(0,0))="" G DIAGI
|
|---|
| 22 | DEV ; -- select device, run option
|
|---|
| 23 | W !!,"Set your Device settings to '0;255;9999'"
|
|---|
| 24 | W ! D ^%ZIS G:POP END
|
|---|
| 25 | S DIR(0)="FO",DIR("A")="Initiate File Capture Procedure and Press Return" D ^DIR I $D(DTOUT)!$D(DUOUT) G END
|
|---|
| 26 | W !,"Working...",!
|
|---|
| 27 | U IO
|
|---|
| 28 | ;
|
|---|
| 29 | START ;
|
|---|
| 30 | K ^TMP("IBQLD4",$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 | D PRINT^IBQLD4A
|
|---|
| 36 | END ; -- Clean up
|
|---|
| 37 | W ! K ^TMP("IBQLD4",$J),IB,IBMONTH,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTY,IBTY1,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBTRV,IBMONTH,MSTRING,IBREA,I,N,X,IBRES,IBCAT,IBMTH,IBMD,IBDIAG
|
|---|
| 38 | I $D(ZTQUEUED) S ZTREQ="@" Q
|
|---|
| 39 | D ^%ZISC
|
|---|
| 40 | Q
|
|---|
| 41 | ;
|
|---|
| 42 | DATA ;
|
|---|
| 43 | ; -- get Admission Review info.
|
|---|
| 44 | D ADMIT^IBQL538 S IBQUIT=""
|
|---|
| 45 | S IBDIAG=IB(.04),IBDIAG1=" "_IBDIAG Q:IBDIAG="" I IBTY="I" D Q:IBQUIT
|
|---|
| 46 | .I IBTY1="E",($D(IBDIAG(IBDIAG))) Q
|
|---|
| 47 | .I IBTY1="R",(IBDIAG]DG1)&(IBDIAG']DG6) Q
|
|---|
| 48 | .S IBQUIT=1
|
|---|
| 49 | ; -- count acute admissions
|
|---|
| 50 | I IB("ACUTE ADMISSION") D
|
|---|
| 51 | .S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,1,"CNTA",$E(IBDDT,1,5)))+1
|
|---|
| 52 | ; -- count non-acute admissions
|
|---|
| 53 | E D
|
|---|
| 54 | .S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,1,"CNTN",$E(IBDDT,1,5)))+1
|
|---|
| 55 | .F I=1:1 S IBR=$P(IB(1.03)," ",I) Q:'IBR S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,1,"REA",IBR,$E(IBDDT,1,5)))+1
|
|---|
| 56 | ; --continued stay days
|
|---|
| 57 | S IBTRV=0 F S IBTRV=$O(^IBQ(538,IBTRN,13,IBTRV)) Q:'IBTRV D
|
|---|
| 58 | .D STAY^IBQL538
|
|---|
| 59 | .I IB("ACUTE STAY") D
|
|---|
| 60 | ..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,2,"CNTA",$E(IBDDT,1,5)))+1
|
|---|
| 61 | .E D
|
|---|
| 62 | ..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,2,"CNTN",$E(IBDDT,1,5)))+1
|
|---|
| 63 | ..F I=1:1 S IBR=$P(IB(13.06)," ",I) Q:'IBR S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,2,"REA",IBR,$E(IBDDT,1,5)))+1
|
|---|
| 64 | Q
|
|---|
