IBQLD4 ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 17-MAY-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
I '$D(DT) D DT^DICRW
DATE W ! D DATE^IBOUTL
I IBBDT=""!(IBEDT="") G END
S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
DIAG S DIR(0)="SA^A:All Admitting Diagnosis;I:Individual Admitting Diagnosis",DIR("A")="Display ALL or INDIVIDUAL Admitting Diagnosis? [A/I]: "
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
S IBTY=Y G:IBTY="A" DEV
S DIR(0)="SA^R:Range;E:Exact Match",DIR("A")="Search by Range or Exact Match? [R/E]: "
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
S IBTY1=Y G:IBTY1="E" DIAGI
S DIC="^ICD9(",DIC(0)="AMEQZ"
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"
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
G DEV
DIAGI S DIR(0)="PO^80:AEQMZ",DIR("A")="Enter ADMITTING DIAGNOSIS"
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBDIAG(""))="" DIAGI G DEV
S IBDIAG(Y(0,0))="" G DIAGI
DEV ; -- select device, run option
W !!,"Set your Device settings to '0;255;9999'"
W ! D ^%ZIS G:POP END
S DIR(0)="FO",DIR("A")="Initiate File Capture Procedure and Press Return" D ^DIR I $D(DTOUT)!$D(DUOUT) G END
W !,"Working...",!
U IO
;
START ;
K ^TMP("IBQLD4",$J) S IBDDT=IBBDT-.01,(IBPAG,IBQUIT,IBMCT)=0
F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
.S IBMONTH=$E(IBDDT,1,5) I '$D(IBMONTH(IBMONTH)) S IBMONTH(IBMONTH)="",IBMCT=IBMCT+1
.S IBTRN="" F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
;
D PRINT^IBQLD4A
END ; -- Clean up
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
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
Q
;
DATA ;
; -- get Admission Review info.
D ADMIT^IBQL538 S IBQUIT=""
S IBDIAG=IB(.04),IBDIAG1=" "_IBDIAG Q:IBDIAG="" I IBTY="I" D Q:IBQUIT
.I IBTY1="E",($D(IBDIAG(IBDIAG))) Q
.I IBTY1="R",(IBDIAG]DG1)&(IBDIAG']DG6) Q
.S IBQUIT=1
; -- count acute admissions
I IB("ACUTE ADMISSION") D
.S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,1,"CNTA",$E(IBDDT,1,5)))+1
; -- count non-acute admissions
E D
.S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,1,"CNTN",$E(IBDDT,1,5)))+1
.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
; --continued stay days
S IBTRV=0 F S IBTRV=$O(^IBQ(538,IBTRN,13,IBTRV)) Q:'IBTRV D
.D STAY^IBQL538
.I IB("ACUTE STAY") D
..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,2,"CNTA",$E(IBDDT,1,5)))+1
.E D
..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLD4",$J,IBDIAG1,2,"CNTN",$E(IBDDT,1,5)))+1
..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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLD4 3068 printed Sep 23, 2025@20:17:18 Page 2
IBQLD4 ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 17-MAY-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 IF '$DATA(DT)
DO DT^DICRW
DATE WRITE !
DO DATE^IBOUTL
+1 IF IBBDT=""!(IBEDT="")
GOTO END
+2 SET X1=IBEDT
SET X2=IBBDT
DO ^%DTC
IF X>365
WRITE !,"<<< please report 1 years of information only. >>>"
GOTO DATE
DIAG SET DIR(0)="SA^A:All Admitting Diagnosis;I:Individual Admitting Diagnosis"
SET DIR("A")="Display ALL or INDIVIDUAL Admitting Diagnosis? [A/I]: "
+1 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
+2 SET IBTY=Y
if IBTY="A"
GOTO DEV
+3 SET DIR(0)="SA^R:Range;E:Exact Match"
SET DIR("A")="Search by Range or Exact Match? [R/E]: "
+4 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
+5 SET IBTY1=Y
if IBTY1="E"
GOTO DIAGI
+6 SET DIC="^ICD9("
SET DIC(0)="AMEQZ"
+7 SET DIC("A")="Start with ADMITTING DIAGNOSIS: "
DO ^DIC
if Y'>0
GOTO END
SET DG1=Y(0,0)
SET DG1=$EXTRACT(DG1,1,$LENGTH(DG1)-1)_$CHAR($ASCII(DG1,$LENGTH(DG1))-1)_"zzzzzz"
F SET DIC("A")="Go to ADMITTING DIAGNOSIS: "
DO ^DIC
if Y'>0
QUIT
SET DG6=Y(0,0)
IF DG6']DG1
WRITE !,"Must be after start code",!
GOTO F
+1 GOTO DEV
DIAGI SET DIR(0)="PO^80:AEQMZ"
SET DIR("A")="Enter ADMITTING DIAGNOSIS"
+1 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
IF X=""
if $ORDER(IBDIAG(""))=""
GOTO DIAGI
GOTO DEV
+2 SET IBDIAG(Y(0,0))=""
GOTO DIAGI
DEV ; -- select device, run option
+1 WRITE !!,"Set your Device settings to '0;255;9999'"
+2 WRITE !
DO ^%ZIS
if POP
GOTO END
+3 SET DIR(0)="FO"
SET DIR("A")="Initiate File Capture Procedure and Press Return"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO END
+4 WRITE !,"Working...",!
+5 USE IO
+6 ;
START ;
+1 KILL ^TMP("IBQLD4",$JOB)
SET IBDDT=IBBDT-.01
SET (IBPAG,IBQUIT,IBMCT)=0
+2 FOR
SET IBDDT=$ORDER(^IBQ(538,"ADIS",IBDDT))
if 'IBDDT!(IBDDT>IBEDT)
QUIT
Begin DoDot:1
+3 SET IBMONTH=$EXTRACT(IBDDT,1,5)
IF '$DATA(IBMONTH(IBMONTH))
SET IBMONTH(IBMONTH)=""
SET IBMCT=IBMCT+1
+4 SET IBTRN=""
FOR
SET IBTRN=$ORDER(^IBQ(538,"ADIS",IBDDT,IBTRN))
if 'IBTRN
QUIT
DO DATA
End DoDot:1
+5 ;
+6 DO PRINT^IBQLD4A
END ; -- Clean up
+1 WRITE !
KILL ^TMP("IBQLD4",$JOB),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
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 DO ^%ZISC
+4 QUIT
+5 ;
DATA ;
+1 ; -- get Admission Review info.
+2 DO ADMIT^IBQL538
SET IBQUIT=""
+3 SET IBDIAG=IB(.04)
SET IBDIAG1=" "_IBDIAG
if IBDIAG=""
QUIT
IF IBTY="I"
Begin DoDot:1
+4 IF IBTY1="E"
IF ($DATA(IBDIAG(IBDIAG)))
QUIT
+5 IF IBTY1="R"
IF (IBDIAG]DG1)&(IBDIAG']DG6)
QUIT
+6 SET IBQUIT=1
End DoDot:1
if IBQUIT
QUIT
+7 ; -- count acute admissions
+8 IF IB("ACUTE ADMISSION")
Begin DoDot:1
+9 SET ^($EXTRACT(IBDDT,1,5))=$GET(^TMP("IBQLD4",$JOB,IBDIAG1,1,"CNTA",$EXTRACT(IBDDT,1,5)))+1
End DoDot:1
+10 ; -- count non-acute admissions
+11 IF '$TEST
Begin DoDot:1
+12 SET ^($EXTRACT(IBDDT,1,5))=$GET(^TMP("IBQLD4",$JOB,IBDIAG1,1,"CNTN",$EXTRACT(IBDDT,1,5)))+1
+13 FOR I=1:1
SET IBR=$PIECE(IB(1.03)," ",I)
if 'IBR
QUIT
SET ^($EXTRACT(IBDDT,1,5))=$GET(^TMP("IBQLD4",$JOB,IBDIAG1,1,"REA",IBR,$EXTRACT(IBDDT,1,5)))+1
End DoDot:1
+14 ; --continued stay days
+15 SET IBTRV=0
FOR
SET IBTRV=$ORDER(^IBQ(538,IBTRN,13,IBTRV))
if 'IBTRV
QUIT
Begin DoDot:1
+16 DO STAY^IBQL538
+17 IF IB("ACUTE STAY")
Begin DoDot:2
+18 SET ^($EXTRACT(IBDDT,1,5))=$GET(^TMP("IBQLD4",$JOB,IBDIAG1,2,"CNTA",$EXTRACT(IBDDT,1,5)))+1
End DoDot:2
+19 IF '$TEST
Begin DoDot:2
+20 SET ^($EXTRACT(IBDDT,1,5))=$GET(^TMP("IBQLD4",$JOB,IBDIAG1,2,"CNTN",$EXTRACT(IBDDT,1,5)))+1
+21 FOR I=1:1
SET IBR=$PIECE(IB(13.06)," ",I)
if 'IBR
QUIT
SET ^($EXTRACT(IBDDT,1,5))=$GET(^TMP("IBQLD4",$JOB,IBDIAG1,2,"REA",IBR,$EXTRACT(IBDDT,1,5)))+1
End DoDot:2
End DoDot:1
+22 QUIT
