- IBQLR3A ;LEB/MRY - PROVIDER/PATIENT 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.
- ;
- PRINT S (IBDATA,IBQUIT,IBHDR,IBHDR1,IBPHY)="",IBPAG=0
- ; -- call to return header dates - IBTDT, IBDRNG
- D DTC^IBQLPL2
- S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="PATIENT REVIEWS FOR "_IBDRNG,IBHDR1="PROVIDER"
- ;
- I '$D(^TMP("IBQLR3",$J)) D HDR W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
- F S IBPHY=$O(^TMP("IBQLR3",$J,IBPHY)) Q:IBPHY="" D G:IBQUIT END
- .S IBSUBH=IBTYD_": "_IBPHY
- .D PLINE Q:IBQUIT
- .S IBDDT="" F S IBDDT=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT)) Q:'IBDDT D Q:IBQUIT
- ..S IBSSN="" F S IBSSN=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN)) Q:'IBSSN D DATA Q:IBQUIT
- Q
- ;
- END K IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD,IBCHK
- Q
- ;
- DATA ;
- S IBDATA=^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN)
- S IBADM=$P(IBDATA,"^"),IBADIAG=$P(IBDATA,"^",2),IBENRLL=$P(IBDATA,"^",3)
- S IBPHYAD=$P(IBDATA,"^",4),IBPHYAT=$P(IBDATA,"^",5),IBPHYRS=$P(IBDATA,"^",6)
- S IBAAD=$P(IBDATA,"^",7),IBNAD=$P(IBDATA,"^",8),IBRAD=$P(IBDATA,"^",9)
- S IBCHK=$P(IBDATA,"^",10) I IBCHK=1 D PLINE Q
- S IBLOS=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"LOS"))
- S IBSACNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-AC"))
- S IBSNCNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-NAC"))
- K IBRSY S IBRSY=""
- F S IBRSY=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
- .S IBRSYCNT=^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,IBRSY)
- .S IBRSY(9999-IBRSYCNT,IBRSY)=""
- D PLINE
- Q
- ;
- PLINE ;
- I IBPAG=0 D HDR
- D CHKL Q:IBQUIT
- I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
- W !,IBSSN,?11 S IBDT=IBADM D DTC W $J(IBDT,8) W ?20 S IBDT=IBDDT D DTC W $J(IBDT,8)
- W ?29,IBADIAG,?37,IBENRLL,?45,$P(IBRAD," "),?52,$P(IBRAD," ",2)
- I IBCHK=1 W ?58,"ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA." Q
- W ?58,$J(IBLOS,4),?63,$J(IBSACNT,4),?68,$J(IBSNCNT,4)
- W ?73 S (RCNT,CNT)="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT S REA="" D Q:CNT=4
- .F S REA=$O(IBRSY(RCNT,REA)) Q:REA="" D Q:CNT=4
- ..W ?($X+2),$J(REA_"/"_(9999-RCNT),8)," " S CNT=CNT+1
- ;W ?85 S RCNT="" F I=1:1:3 S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
- ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
- Q
- ;
- HDR ;
- W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
- W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
- W !,?(IOM-$L(IBHDR1)/2),IBHDR1,!,?(IOM-$L(IBHDR2)/2),IBHDR2
- W !!,?11,"ADMIT",?20,"DISCH",?37,"ENRLL",?45,"ADM. REASONS",?63,"#AC",?68,"#N-AC"
- W ?76,"C O N T I N U E D S T A Y R E A S O N S"
- ;W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
- ;.W ?($X+2),$J("S-REA",6),?($X+2)," "
- W !,"SSN",?11,"DATE",?20,"DATE",?29,"DIAG",?37,"R-D-L",?45,"1",?52,"2",?58,"#LOS",?63,"DAYS",?68,"DAYS"
- W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
- .W ?($X+2),$J(I_"/CNT",6),?($X+2)," "
- W !,$TR($J("",IOM)," ","-")
- Q
- ;
- CHKL ; -- check end of page
- I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT W @IOF D HDR Q
- I IOSL<($Y+5) D HDR
- Q
- ;
- DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLR3A 3271 printed Feb 19, 2025@00:07:46 Page 2
- IBQLR3A ;LEB/MRY - PROVIDER/PATIENT 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 ;
- PRINT SET (IBDATA,IBQUIT,IBHDR,IBHDR1,IBPHY)=""
- SET IBPAG=0
- +1 ; -- call to return header dates - IBTDT, IBDRNG
- +2 DO DTC^IBQLPL2
- +3 SET IBHDR="UTILIZATION MANAGEMENT"
- SET IBHDR2="PATIENT REVIEWS FOR "_IBDRNG
- SET IBHDR1="PROVIDER"
- +4 ;
- +5 IF '$DATA(^TMP("IBQLR3",$JOB))
- DO HDR
- WRITE !!,?20,"<<< NO PATIENTS TO PRINT >>>"
- QUIT
- +6 FOR
- SET IBPHY=$ORDER(^TMP("IBQLR3",$JOB,IBPHY))
- if IBPHY=""
- QUIT
- Begin DoDot:1
- +7 SET IBSUBH=IBTYD_": "_IBPHY
- +8 DO PLINE
- if IBQUIT
- QUIT
- +9 SET IBDDT=""
- FOR
- SET IBDDT=$ORDER(^TMP("IBQLR3",$JOB,IBPHY,IBDDT))
- if 'IBDDT
- QUIT
- Begin DoDot:2
- +10 SET IBSSN=""
- FOR
- SET IBSSN=$ORDER(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN))
- if 'IBSSN
- QUIT
- DO DATA
- if IBQUIT
- QUIT
- End DoDot:2
- if IBQUIT
- QUIT
- End DoDot:1
- if IBQUIT
- GOTO END
- +11 QUIT
- +12 ;
- END KILL IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD,IBCHK
- +1 QUIT
- +2 ;
- DATA ;
- +1 SET IBDATA=^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN)
- +2 SET IBADM=$PIECE(IBDATA,"^")
- SET IBADIAG=$PIECE(IBDATA,"^",2)
- SET IBENRLL=$PIECE(IBDATA,"^",3)
- +3 SET IBPHYAD=$PIECE(IBDATA,"^",4)
- SET IBPHYAT=$PIECE(IBDATA,"^",5)
- SET IBPHYRS=$PIECE(IBDATA,"^",6)
- +4 SET IBAAD=$PIECE(IBDATA,"^",7)
- SET IBNAD=$PIECE(IBDATA,"^",8)
- SET IBRAD=$PIECE(IBDATA,"^",9)
- +5 SET IBCHK=$PIECE(IBDATA,"^",10)
- IF IBCHK=1
- DO PLINE
- QUIT
- +6 SET IBLOS=$GET(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,"LOS"))
- +7 SET IBSACNT=$GET(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,"S-AC"))
- +8 SET IBSNCNT=$GET(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,"S-NAC"))
- +9 KILL IBRSY
- SET IBRSY=""
- +10 FOR
- SET IBRSY=$ORDER(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,IBRSY))
- if 'IBRSY
- QUIT
- Begin DoDot:1
- +11 SET IBRSYCNT=^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,IBRSY)
- +12 SET IBRSY(9999-IBRSYCNT,IBRSY)=""
- End DoDot:1
- +13 DO PLINE
- +14 QUIT
- +15 ;
- PLINE ;
- +1 IF IBPAG=0
- DO HDR
- +2 DO CHKL
- if IBQUIT
- QUIT
- +3 IF IBSUBH'=""
- IF '$GET(IBSSN)
- WRITE !!,IBSUBH,!
- QUIT
- +4 WRITE !,IBSSN,?11
- SET IBDT=IBADM
- DO DTC
- WRITE $JUSTIFY(IBDT,8)
- WRITE ?20
- SET IBDT=IBDDT
- DO DTC
- WRITE $JUSTIFY(IBDT,8)
- +5 WRITE ?29,IBADIAG,?37,IBENRLL,?45,$PIECE(IBRAD," "),?52,$PIECE(IBRAD," ",2)
- +6 IF IBCHK=1
- WRITE ?58,"ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA."
- QUIT
- +7 WRITE ?58,$JUSTIFY(IBLOS,4),?63,$JUSTIFY(IBSACNT,4),?68,$JUSTIFY(IBSNCNT,4)
- +8 WRITE ?73
- SET (RCNT,CNT)=""
- FOR
- SET RCNT=$ORDER(IBRSY(RCNT))
- if 'RCNT
- QUIT
- SET REA=""
- Begin DoDot:1
- +9 FOR
- SET REA=$ORDER(IBRSY(RCNT,REA))
- if REA=""
- QUIT
- Begin DoDot:2
- +10 WRITE ?($X+2),$JUSTIFY(REA_"/"_(9999-RCNT),8)," "
- SET CNT=CNT+1
- End DoDot:2
- if CNT=4
- QUIT
- End DoDot:1
- if CNT=4
- QUIT
- +11 ;W ?85 S RCNT="" F I=1:1:3 S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
- +12 ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
- +13 QUIT
- +14 ;
- HDR ;
- +1 if $EXTRACT(IOST,1,2)["C-"!(IBPAG>0)
- WRITE @IOF
- SET IBPAG=IBPAG+1
- +2 WRITE !,IBTDT,?(IOM-$LENGTH(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
- +3 WRITE !,?(IOM-$LENGTH(IBHDR1)/2),IBHDR1,!,?(IOM-$LENGTH(IBHDR2)/2),IBHDR2
- +4 WRITE !!,?11,"ADMIT",?20,"DISCH",?37,"ENRLL",?45,"ADM. REASONS",?63,"#AC",?68,"#N-AC"
- +5 WRITE ?76,"C O N T I N U E D S T A Y R E A S O N S"
- +6 ;W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
- +7 ;.W ?($X+2),$J("S-REA",6),?($X+2)," "
- +8 WRITE !,"SSN",?11,"DATE",?20,"DATE",?29,"DIAG",?37,"R-D-L",?45,"1",?52,"2",?58,"#LOS",?63,"DAYS",?68,"DAYS"
- +9 ; for Download rpt. use F I=1:1:IBLVH
- WRITE ?73
- FOR I=1:1:4
- Begin DoDot:1
- +10 WRITE ?($X+2),$JUSTIFY(I_"/CNT",6),?($X+2)," "
- End DoDot:1
- +11 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- +12 QUIT
- +13 ;
- CHKL ; -- check end of page
- +1 IF IOSL<($Y+5)
- IF $EXTRACT(IOST,1,2)="C-"
- DO PAUSE^VALM1
- if $DATA(DIRUT)
- SET IBQUIT=1
- if IBQUIT
- QUIT
- WRITE @IOF
- DO HDR
- QUIT
- +2 IF IOSL<($Y+5)
- DO HDR
- +3 QUIT
- +4 ;
- DTC SET IBDT=+$EXTRACT(IBDT,4,5)_"/"_$EXTRACT(IBDT,6,7)_"/"_$EXTRACT(IBDT,2,3)
- +1 QUIT