IBQLR2 ;LEB/MRY - PATIENT REPORT ; 17-MAY-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;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
S DIR(0)="SA^S:Services;T:Treating Specialties;P:Providers",DIR("A")="Display Services,Treating Specialties, or Providers? [S/T/P]: "
W ! D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
S IBTY=Y G:IBTY="P" PHY^IBQLR3
I IBTY="S" S DIR(0)="SA^A:All Services;I:Individual Services",DIR("A")="Display ALL or INDIVIDUAL Services? [A/I]: "
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]: "
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
S IBTY1=Y G:IBTY1="A" DEV
I IBTY="T" G TSI
SVCI S DIR(0)="42.4,3O",DIR("A")="Enter SERVICE"
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBSVC(""))="" SVCI G DEV
S IBSVC(Y)=Y(0) G SVCI
TSI S DIR(0)="PO^45.7:AEQZ",DIR("A")="Enter TREATING SPECIALTY"
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBTS(""))="" TSI G DEV
S IBTS(Y(0,0))="" G TSI
DEV ; -- select device, run option
W ! S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) F I="IBTY","IBBDT","IBEDT","IBTS(","IBSVC(","IBTY1" S ZTSAVE(I)=""
I $D(IO("Q")) S ZTRTN="START^IBQLR2",ZTDESC="UM - ACUTE REPORT" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
U IO
;
START ;
K ^TMP("IBQLR2",$J) S IBDDT=IBBDT-.01,(IBPAG,IBQUIT,IBLVH)=0
F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
.S IBTRN="" F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
;
I $$STOP,$G(ZTSTOP) G END
D PRINT^IBQLR2A
END ; -- Clean up
W ! K ^TMP("IBQLR2",$J),IB,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTS,IBTY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBREA,IBLV,IBLVH,I,N,X,IBSVC
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
Q
;
DATA ;
ADMIT ; -- get Admission Review info.
S IBLV=0 D ADMIT^IBQL538
S IBSVC=IB(1.07),IBTS=IB(.12) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
I IBTY1="I" G:IBTY="S"&('$D(IBSVC(IBSVC))) STAY G:IBTY="T"&('$D(IBTS(IBTS))) STAY
S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_IB("ACUTE ADMISSION")_"^"_$S('IB("ACUTE ADMISSION"):1,1:"")_"^"_IB(1.03)
S ^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
S ^("LOS")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
I IB("ACUTE ADMISSION") S ^("S-AC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
E S ^("S-NAC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
STAY ; -- get Stay Review info.
S IBTRV=0 F S IBTRV=$O(^IBQ(538,IBTRN,13,IBTRV)) Q:'IBTRV D
.D STAY^IBQL538
.S IBSVC=IB(13.08),IBTS=IB(13.07) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
.I IBTY1="I" Q:IBTY="S"&('$D(IBSVC(IBSVC))) Q:IBTY="T"&('$D(IBTS(IBTS)))
.I '$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03))) D
..S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_"^"_"^"
..S ^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
.F I=1:1:3 S REA=$P(IB(13.06)," ",I) Q:'REA D
..I '$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),+REA)) S IBLV=IBLV+1
..S ^(+REA)=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),+REA))+1
.S ^("LOS")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
.I IB("ACUTE STAY") S ^("S-AC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
.E S ^("S-NAC")=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
.I IBLV>IBLVH S IBLVH=IBLV
Q
;
STOP() ; determine if user has requested the queued report to stop
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPAG) W !,"***TASK STOPPED BY USER***"
Q +$G(ZTSTOP)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLR2 3805 printed Apr 09, 2024@21:43:27 Page 2
IBQLR2 ;LEB/MRY - PATIENT REPORT ; 17-MAY-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;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
+3 SET DIR(0)="SA^S:Services;T:Treating Specialties;P:Providers"
SET DIR("A")="Display Services,Treating Specialties, or Providers? [S/T/P]: "
+4 WRITE !
DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
+5 SET IBTY=Y
if IBTY="P"
GOTO PHY^IBQLR3
+6 IF IBTY="S"
SET DIR(0)="SA^A:All Services;I:Individual Services"
SET DIR("A")="Display ALL or INDIVIDUAL Services? [A/I]: "
+7 IF IBTY="T"
SET DIR(0)="SA^A:All Treating Specialties;I:Individual Treating Specialties"
SET DIR("A")="Display ALL or INDIVIDUAL Treating Specialties? [A/I]: "
+8 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
+9 SET IBTY1=Y
if IBTY1="A"
GOTO DEV
+10 IF IBTY="T"
GOTO TSI
SVCI SET DIR(0)="42.4,3O"
SET DIR("A")="Enter SERVICE"
+1 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
IF X=""
if $ORDER(IBSVC(""))=""
GOTO SVCI
GOTO DEV
+2 SET IBSVC(Y)=Y(0)
GOTO SVCI
TSI SET DIR(0)="PO^45.7:AEQZ"
SET DIR("A")="Enter TREATING SPECIALTY"
+1 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
IF X=""
if $ORDER(IBTS(""))=""
GOTO TSI
GOTO DEV
+2 SET IBTS(Y(0,0))=""
GOTO TSI
DEV ; -- select device, run option
+1 WRITE !
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+2 IF $DATA(IO("Q"))
FOR I="IBTY","IBBDT","IBEDT","IBTS(","IBSVC(","IBTY1"
SET ZTSAVE(I)=""
+3 IF $DATA(IO("Q"))
SET ZTRTN="START^IBQLR2"
SET ZTDESC="UM - ACUTE REPORT"
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO HOME^%ZIS
GOTO END
+4 USE IO
+5 ;
START ;
+1 KILL ^TMP("IBQLR2",$JOB)
SET IBDDT=IBBDT-.01
SET (IBPAG,IBQUIT,IBLVH)=0
+2 FOR
SET IBDDT=$ORDER(^IBQ(538,"ADIS",IBDDT))
if 'IBDDT!(IBDDT>IBEDT)
QUIT
Begin DoDot:1
+3 SET IBTRN=""
FOR
SET IBTRN=$ORDER(^IBQ(538,"ADIS",IBDDT,IBTRN))
if 'IBTRN
QUIT
DO DATA
End DoDot:1
+4 ;
+5 IF $$STOP
IF $GET(ZTSTOP)
GOTO END
+6 DO PRINT^IBQLR2A
END ; -- Clean up
+1 WRITE !
KILL ^TMP("IBQLR2",$JOB),IB,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTS,IBTY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBREA,IBLV,IBLVH,I,N,X,IBSVC
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 DO ^%ZISC
+4 QUIT
+5 ;
DATA ;
ADMIT ; -- get Admission Review info.
+1 SET IBLV=0
DO ADMIT^IBQL538
+2 SET IBSVC=IB(1.07)
SET IBTS=IB(.12)
if IBTY="S"
SET IBTS=999
if IBSVC=""
SET IBSVC="UNK"
+3 IF IBTY1="I"
if IBTY="S"&('$DATA(IBSVC(IBSVC)))
GOTO STAY
if IBTY="T"&('$DATA(IBTS(IBTS)))
GOTO STAY
+4 SET IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_IB("ACUTE ADMISSION")_"^"_$SELECT('IB("ACUTE ADMISSION"):1,1:"")_"^"_IB(1.03)
+5 SET ^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
+6 SET ^("LOS")=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
+7 IF IB("ACUTE ADMISSION")
SET ^("S-AC")=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
+8 IF '$TEST
SET ^("S-NAC")=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
STAY ; -- get Stay Review info.
+1 SET IBTRV=0
FOR
SET IBTRV=$ORDER(^IBQ(538,IBTRN,13,IBTRV))
if 'IBTRV
QUIT
Begin DoDot:1
+2 DO STAY^IBQL538
+3 SET IBSVC=IB(13.08)
SET IBTS=IB(13.07)
if IBTY="S"
SET IBTS=999
if IBSVC=""
SET IBSVC="UNK"
+4 IF IBTY1="I"
if IBTY="S"&('$DATA(IBSVC(IBSVC)))
QUIT
if IBTY="T"&('$DATA(IBTS(IBTS)))
QUIT
+5 IF '$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03)))
Begin DoDot:2
+6 SET IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_"^"_"^"
+7 SET ^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
End DoDot:2
+8 FOR I=1:1:3
SET REA=$PIECE(IB(13.06)," ",I)
if 'REA
QUIT
Begin DoDot:2
+9 IF '$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),+REA))
SET IBLV=IBLV+1
+10 SET ^(+REA)=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),+REA))+1
End DoDot:2
+11 SET ^("LOS")=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
+12 IF IB("ACUTE STAY")
SET ^("S-AC")=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
+13 IF '$TEST
SET ^("S-NAC")=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
+14 IF IBLV>IBLVH
SET IBLVH=IBLV
End DoDot:1
+15 QUIT
+16 ;
STOP() ; determine if user has requested the queued report to stop
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
IF +$GET(IBPAG)
WRITE !,"***TASK STOPPED BY USER***"
+2 QUIT +$GET(ZTSTOP)
