IBQLR3 ;LEB/MRY - PATIENT/PROVIDER REVIEW REPORT ; 1-SEP-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
PHY S DIR(0)="SA^A:Admitting Provider;T:Attending Provider;R:Resident Provider",DIR("A")="Provider Type? [A/T/R]: "
W ! D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
S IBTY=Y,IBTYD=Y(0)
S IBTY2=$S(IBTY="T":1,IBTY="R":2,IBTY="A":3)
S DIR(0)="SA^A:All "_IBTYD_";I:Individual "_IBTYD,DIR("A")="Display ALL or INDIVIDUAL "_IBTYD_"? [A/I]: "
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
S IBTY1=Y G:IBTY1="A" DEV
PHYI S DIR(0)="PO^200:AEQZ",DIR("A")="Enter "_IBTYD
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBPHY(""))="" PHYI G DEV
S IBPHY(+Y)="" G PHYI
DEV ; -- select device, run option
W ! S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) F I="IBTY","IBTYD","IBBDT","IBEDT","IBPHY(","IBTY1","IBTY2" S ZTSAVE(I)=""
I $D(IO("Q")) S ZTRTN="START^IBQLR3",ZTDESC="UM - PROVIDER REPORT" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
U IO
;
START ;
K ^TMP("IBQLR3",$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^IBQLR3A
END ; -- Clean up
W ! K ^TMP("IBQLR3",$J),IB,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTY,IBTY1,IBPHY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBREA,IBLV,IBLVH,I,N,X,IBIEN,IBQLR3,IBORDER,DGPM,IBPHYN,IBPHYZ,IBPHYD
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
Q
;
DATA ;
; -- get Admission Review info.
S IBLV=0 D ADMIT^IBQL538 S IBIEN=$E(IB(.01),4,999)
S IBQUIT=0,IBQLR3=1,IBTRNSV=IBTRN,IBTRN=IBIEN D ORDCHK^IBQLLD2 S IBTRN=IBTRNSV K IBTRNSV
D PHYZ S IBRIEN=IBORDER(1) D PHYZR
G:'IBPHY STAY G:IBTY1="I"&('$D(IBPHY(IBPHY))) 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("IBQLR3",$J,IBPHY,IB(.1),IB(.03))=IBDATA
S ^("LOS")=$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),"LOS"))+1
I IB("ACUTE ADMISSION") S ^("S-AC")=$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),"S-AC"))+1
E S ^("S-NAC")=$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),"S-NAC"))+1
STAY ; -- get Stay Review info.
S IBRN=1,IBTRV=0 F S IBRN=$O(IBORDER(IBRN)) Q:'IBRN S IBRIEN=IBORDER(IBRN) D
.S IBTRV=IBTRV+1 D STAY^IBQL538
.D PHYZR Q:'IBPHY I IBTY1="I",'$D(IBPHY(IBPHY)) Q
.I '$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03))) D
..S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_"^"_"^"
..S ^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03))=IBDATA
.F I=1:1:3 S REA=$P(IB(13.06)," ",I) Q:'REA D
..I '$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),+REA)) S IBLV=IBLV+1
..S ^(+REA)=$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),+REA))+1
.S ^("LOS")=$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),"LOS"))+1
.I IB("ACUTE STAY") S ^("S-AC")=$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),"S-AC"))+1
.E S ^("S-NAC")=$G(^TMP("IBQLR3",$J,IBPHY,IB(.1),IB(.03),"S-NAC"))+1
.I IBLV>IBLVH S IBLVH=IBLV
Q
;
PHYZ ; -- organize requested providers in array IBPHYZ
S DGPM=$P(^IBT(356,IBIEN,0),"^",5)
S IBPHYN=0 K IBPHYZ
F S IBPHYN=$O(^IBT(356.94,"C",DGPM,IBPHYN)) Q:'IBPHYN S IBPHYD=$G(^IBT(356.94,IBPHYN,0)) D
.I 'IBPHYD!('$P(IBPHYD,"^"))!('$P(IBPHYD,"^",3))!('$P(IBPHYD,"^",4)) Q
.S IBPHYZ($P(IBPHYD,"^",4),$P(IBPHYD,"^"))=$P(IBPHYD,"^",3)
I IBTY2=1 D
.S IB1=$O(IBPHYZ(1,"")) Q:'IB1 S IB3=$O(IBPHYZ(3,"")) Q:'IB3
.I IB1'=IB3 Q
.S X1=IB1,X2=1 D C^%DTC S IBPHYZ(1,X)=IBPHYZ(1,IB1) K IBPHYZ(1,IB1)
I IBTY2=3 D
.S IB1=$O(IBPHYZ(1,"")) Q:'IB1 S IB3=$O(IBPHYZ(3,"")) Q:'IB3
.I IB3=IB1 D
..S X1=IB3,X2=1 D C^%DTC S IBPHYZ(3,X)=""
.I IB1'=IB3 S IBPHYZ(3,IB1)=""
K IBPHYN,IBPHYD,X,IB1,IB3 Q
;
PHYZR ; -- return requested provider.
S VAINDT=$$VNDT^IBTRV(IBRIEN),VAINDT=$P(VAINDT,".")
S (IBPHY,IBPHYDT)=""
F S IBPHYDT=$O(IBPHYZ(IBTY2,IBPHYDT)) Q:'IBPHYDT D
.I IBPHYDT>VAINDT Q
.S IBPHY=$P(IBPHYZ(IBTY2,IBPHYDT),"^")
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[HIBQLR3 4414 printed Dec 13, 2024@02:41:30 Page 2
IBQLR3 ;LEB/MRY - PATIENT/PROVIDER REVIEW REPORT ; 1-SEP-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
PHY SET DIR(0)="SA^A:Admitting Provider;T:Attending Provider;R:Resident Provider"
SET DIR("A")="Provider Type? [A/T/R]: "
+1 WRITE !
DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
+2 SET IBTY=Y
SET IBTYD=Y(0)
+3 SET IBTY2=$SELECT(IBTY="T":1,IBTY="R":2,IBTY="A":3)
+4 SET DIR(0)="SA^A:All "_IBTYD_";I:Individual "_IBTYD
SET DIR("A")="Display ALL or INDIVIDUAL "_IBTYD_"? [A/I]: "
+5 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
+6 SET IBTY1=Y
if IBTY1="A"
GOTO DEV
PHYI SET DIR(0)="PO^200:AEQZ"
SET DIR("A")="Enter "_IBTYD
+1 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
KILL DIR
IF X=""
if $ORDER(IBPHY(""))=""
GOTO PHYI
GOTO DEV
+2 SET IBPHY(+Y)=""
GOTO PHYI
DEV ; -- select device, run option
+1 WRITE !
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+2 IF $DATA(IO("Q"))
FOR I="IBTY","IBTYD","IBBDT","IBEDT","IBPHY(","IBTY1","IBTY2"
SET ZTSAVE(I)=""
+3 IF $DATA(IO("Q"))
SET ZTRTN="START^IBQLR3"
SET ZTDESC="UM - PROVIDER REPORT"
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO HOME^%ZIS
GOTO END
+4 USE IO
+5 ;
START ;
+1 KILL ^TMP("IBQLR3",$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^IBQLR3A
END ; -- Clean up
+1 WRITE !
KILL ^TMP("IBQLR3",$JOB),IB,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTY,IBTY1,IBPHY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBREA,IBLV,IBLVH,I,N,X,IBIEN,IBQLR3,IBORDER,DGPM,IBPHYN,IBPHYZ,IBPHYD
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 DO ^%ZISC
+4 QUIT
+5 ;
DATA ;
+1 ; -- get Admission Review info.
+2 SET IBLV=0
DO ADMIT^IBQL538
SET IBIEN=$EXTRACT(IB(.01),4,999)
+3 SET IBQUIT=0
SET IBQLR3=1
SET IBTRNSV=IBTRN
SET IBTRN=IBIEN
DO ORDCHK^IBQLLD2
SET IBTRN=IBTRNSV
KILL IBTRNSV
+4 DO PHYZ
SET IBRIEN=IBORDER(1)
DO PHYZR
+5 if 'IBPHY
GOTO STAY
if IBTY1="I"&('$DATA(IBPHY(IBPHY)))
GOTO STAY
+6 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)
+7 SET ^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03))=IBDATA
+8 SET ^("LOS")=$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),"LOS"))+1
+9 IF IB("ACUTE ADMISSION")
SET ^("S-AC")=$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),"S-AC"))+1
+10 IF '$TEST
SET ^("S-NAC")=$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),"S-NAC"))+1
STAY ; -- get Stay Review info.
+1 SET IBRN=1
SET IBTRV=0
FOR
SET IBRN=$ORDER(IBORDER(IBRN))
if 'IBRN
QUIT
SET IBRIEN=IBORDER(IBRN)
Begin DoDot:1
+2 SET IBTRV=IBTRV+1
DO STAY^IBQL538
+3 DO PHYZR
if 'IBPHY
QUIT
IF IBTY1="I"
IF '$DATA(IBPHY(IBPHY))
QUIT
+4 IF '$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03)))
Begin DoDot:2
+5 SET IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_"^"_"^"
+6 SET ^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03))=IBDATA
End DoDot:2
+7 FOR I=1:1:3
SET REA=$PIECE(IB(13.06)," ",I)
if 'REA
QUIT
Begin DoDot:2
+8 IF '$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),+REA))
SET IBLV=IBLV+1
+9 SET ^(+REA)=$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),+REA))+1
End DoDot:2
+10 SET ^("LOS")=$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),"LOS"))+1
+11 IF IB("ACUTE STAY")
SET ^("S-AC")=$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),"S-AC"))+1
+12 IF '$TEST
SET ^("S-NAC")=$GET(^TMP("IBQLR3",$JOB,IBPHY,IB(.1),IB(.03),"S-NAC"))+1
+13 IF IBLV>IBLVH
SET IBLVH=IBLV
End DoDot:1
+14 QUIT
+15 ;
PHYZ ; -- organize requested providers in array IBPHYZ
+1 SET DGPM=$PIECE(^IBT(356,IBIEN,0),"^",5)
+2 SET IBPHYN=0
KILL IBPHYZ
+3 FOR
SET IBPHYN=$ORDER(^IBT(356.94,"C",DGPM,IBPHYN))
if 'IBPHYN
QUIT
SET IBPHYD=$GET(^IBT(356.94,IBPHYN,0))
Begin DoDot:1
+4 IF 'IBPHYD!('$PIECE(IBPHYD,"^"))!('$PIECE(IBPHYD,"^",3))!('$PIECE(IBPHYD,"^",4))
QUIT
+5 SET IBPHYZ($PIECE(IBPHYD,"^",4),$PIECE(IBPHYD,"^"))=$PIECE(IBPHYD,"^",3)
End DoDot:1
+6 IF IBTY2=1
Begin DoDot:1
+7 SET IB1=$ORDER(IBPHYZ(1,""))
if 'IB1
QUIT
SET IB3=$ORDER(IBPHYZ(3,""))
if 'IB3
QUIT
+8 IF IB1'=IB3
QUIT
+9 SET X1=IB1
SET X2=1
DO C^%DTC
SET IBPHYZ(1,X)=IBPHYZ(1,IB1)
KILL IBPHYZ(1,IB1)
End DoDot:1
+10 IF IBTY2=3
Begin DoDot:1
+11 SET IB1=$ORDER(IBPHYZ(1,""))
if 'IB1
QUIT
SET IB3=$ORDER(IBPHYZ(3,""))
if 'IB3
QUIT
+12 IF IB3=IB1
Begin DoDot:2
+13 SET X1=IB3
SET X2=1
DO C^%DTC
SET IBPHYZ(3,X)=""
End DoDot:2
+14 IF IB1'=IB3
SET IBPHYZ(3,IB1)=""
End DoDot:1
+15 KILL IBPHYN,IBPHYD,X,IB1,IB3
QUIT
+16 ;
PHYZR ; -- return requested provider.
+1 SET VAINDT=$$VNDT^IBTRV(IBRIEN)
SET VAINDT=$PIECE(VAINDT,".")
+2 SET (IBPHY,IBPHYDT)=""
+3 FOR
SET IBPHYDT=$ORDER(IBPHYZ(IBTY2,IBPHYDT))
if 'IBPHYDT
QUIT
Begin DoDot:1
+4 IF IBPHYDT>VAINDT
QUIT
+5 SET IBPHY=$PIECE(IBPHYZ(IBTY2,IBPHYDT),"^")
End DoDot:1
+6 QUIT
+7 ;
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)
