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

IBQLR4.m

Go to the documentation of this file.
  1. IBQLR4 ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 17-MAY-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. 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. DIAG S DIR(0)="SA^A:All Admitting Diagnosis;I:Individual Admitting Diagnosis",DIR("A")="Display ALL or INDIVIDUAL Admitting Diagnosis? [A/I]: "
  1. D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
  1. S IBTY=Y G:IBTY="A" DEV
  1. S DIR(0)="SA^R:Range;E:Exact Match",DIR("A")="Search by Range or Exact Match? [R/E]: "
  1. D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
  1. S IBTY1=Y G:IBTY1="E" DIAGI
  1. S DIC="^ICD9(",DIC(0)="AMEQZ"
  1. 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"
  1. 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
  1. G DEV
  1. DIAGI S DIR(0)="PO^80:AEQMZ",DIR("A")="Enter ADMITTING DIAGNOSIS"
  1. D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBDIAG(""))="" DIAGI G DEV
  1. S IBDIAG(Y(0,0))="" G DIAGI
  1. DEV ; -- select device, run option
  1. W ! S %ZIS="QM" D ^%ZIS G:POP END
  1. I $D(IO("Q")) F I="DG1","DG6","IBTY","IBBDT","IBEDT","IBDIAG(","IBTY1" S ZTSAVE(I)=""
  1. I $D(IO("Q")) S ZTRTN="START^IBQLR4",ZTDESC="UM - ACUTE REPORT" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
  1. U IO
  1. ;
  1. START ;
  1. K ^TMP("IBQLR4",$J) S IBDDT=IBBDT-.01,(IBPAG,IBQUIT,IBMCT)=0
  1. F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
  1. .S IBMONTH=$E(IBDDT,1,5) I '$D(IBMONTH(IBMONTH)) S IBMONTH(IBMONTH)="",IBMCT=IBMCT+1
  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^IBQLR4A
  1. END ; -- Clean up
  1. W ! K ^TMP("IBQLR4",$J),IB,IBMONTH,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBTRV,IBMONTH,MSTRING,IBREA,I,N,X,IBRES,IBCAT,IBMTH,IBMD,IBDIAG
  1. I $D(ZTQUEUED) S ZTREQ="@" Q
  1. D ^%ZISC
  1. Q
  1. ;
  1. DATA ;
  1. ; -- get Admission Review info.
  1. D ADMIT^IBQL538 S IBQUIT=""
  1. S IBDIAG=IB(.04),IBDIAG1=" "_IBDIAG Q:IBDIAG="" I IBTY="I" D Q:IBQUIT
  1. .I IBTY1="E",($D(IBDIAG(IBDIAG))) Q
  1. .I IBTY1="R",(IBDIAG]DG1)&(IBDIAG']DG6) Q
  1. .S IBQUIT=1
  1. ; -- count acute admissions
  1. I IB("ACUTE ADMISSION") D
  1. .S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$J,IBDIAG1,1,"CNTA",$E(IBDDT,1,5)))+1
  1. ; -- count non-acute admissions
  1. E D
  1. .S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$J,IBDIAG1,1,"CNTN",$E(IBDDT,1,5)))+1
  1. .F I=1:1 S IBR=$P(IB(1.03)," ",I) Q:'IBR S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$J,IBDIAG1,1,"REA",IBR,$E(IBDDT,1,5)))+1
  1. ; --continued stay days
  1. S IBTRV=0 F S IBTRV=$O(^IBQ(538,IBTRN,13,IBTRV)) Q:'IBTRV D
  1. .D STAY^IBQL538
  1. .I IB("ACUTE STAY") D
  1. ..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$J,IBDIAG1,2,"CNTA",$E(IBDDT,1,5)))+1
  1. .E D
  1. ..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$J,IBDIAG1,2,"CNTN",$E(IBDDT,1,5)))+1
  1. ..F I=1:1 S IBR=$P(IB(13.06)," ",I) Q:'IBR S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$J,IBDIAG1,2,"REA",IBR,$E(IBDDT,1,5)))+1
  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 ZTEQ I $G(IBPAG) W !,"***TASK STOPPED BY USER***"
  1. Q +$G(ZTSTOP)