- IBQLR4 ;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 ! S %ZIS="QM" D ^%ZIS G:POP END
- I $D(IO("Q")) F I="DG1","DG6","IBTY","IBBDT","IBEDT","IBDIAG(","IBTY1" S ZTSAVE(I)=""
- I $D(IO("Q")) S ZTRTN="START^IBQLR4",ZTDESC="UM - ACUTE REPORT" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
- U IO
- ;
- START ;
- K ^TMP("IBQLR4",$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
- ;
- I $$STOP,$G(ZTSTOP) G END
- D PRINT^IBQLR4A
- END ; -- Clean up
- 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
- 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("IBQLR4",$J,IBDIAG1,1,"CNTA",$E(IBDDT,1,5)))+1
- ; -- count non-acute admissions
- E D
- .S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$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("IBQLR4",$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("IBQLR4",$J,IBDIAG1,2,"CNTA",$E(IBDDT,1,5)))+1
- .E D
- ..S ^($E(IBDDT,1,5))=$G(^TMP("IBQLR4",$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("IBQLR4",$J,IBDIAG1,2,"REA",IBR,$E(IBDDT,1,5)))+1
- Q
- ;
- STOP() ; determine if user has requested the queued report to stop
- I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTEQ I $G(IBPAG) W !,"***TASK STOPPED BY USER***"
- Q +$G(ZTSTOP)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLR4 3298 printed Feb 19, 2025@00:07:47 Page 2
- IBQLR4 ;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 %ZIS="QM"
- DO ^%ZIS
- if POP
- GOTO END
- +2 IF $DATA(IO("Q"))
- FOR I="DG1","DG6","IBTY","IBBDT","IBEDT","IBDIAG(","IBTY1"
- SET ZTSAVE(I)=""
- +3 IF $DATA(IO("Q"))
- SET ZTRTN="START^IBQLR4"
- SET ZTDESC="UM - ACUTE REPORT"
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- DO HOME^%ZIS
- GOTO END
- +4 USE IO
- +5 ;
- START ;
- +1 KILL ^TMP("IBQLR4",$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 IF $$STOP
- IF $GET(ZTSTOP)
- GOTO END
- +7 DO PRINT^IBQLR4A
- END ; -- Clean up
- +1 WRITE !
- KILL ^TMP("IBQLR4",$JOB),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
- +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("IBQLR4",$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("IBQLR4",$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("IBQLR4",$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("IBQLR4",$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("IBQLR4",$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("IBQLR4",$JOB,IBDIAG1,2,"REA",IBR,$EXTRACT(IBDDT,1,5)))+1
- End DoDot:2
- End DoDot:1
- +22 QUIT
- +23 ;
- STOP() ; determine if user has requested the queued report to stop
- +1 IF $DATA(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET ZTSTOP=1
- KILL ZTEQ
- IF $GET(IBPAG)
- WRITE !,"***TASK STOPPED BY USER***"
- +2 QUIT +$GET(ZTSTOP)