- 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 Mar 13, 2025@21:46:15 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)
