IBQLD3A ;LEB/MRY - PROVIDER/PATIENT DOWNLOAD ; 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
D HDR I '$D(^TMP("IBQLD3",$J)) W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
;
F S IBPHY=$O(^TMP("IBQLD3",$J,IBPHY)) Q:IBPHY="" D Q:IBQUIT
.S IBSUBH=IBTYD_": "_IBPHY
.D PLINE
.S IBDDT="" F S IBDDT=$O(^TMP("IBQLD3",$J,IBPHY,IBDDT)) Q:'IBDDT D Q:IBQUIT
..S IBSSN="" F S IBSSN=$O(^TMP("IBQLD3",$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
Q
;
DATA ;
S IBDATA=^TMP("IBQLD3",$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("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"LOS"))
S IBSACNT=$G(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"S-AC"))
S IBSNCNT=$G(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"S-NAC"))
K IBRSY S IBRSY=""
F S IBRSY=$O(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
.S IBRSYCNT=^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,IBRSY)
.S IBRSY(9999-IBRSYCNT,IBRSY)=""
D PLINE
Q
;
PLINE ;
I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
W !,IBSSN,"^" S IBDT=IBADM D DTC W IBDT W "^" S IBDT=IBDDT D DTC W IBDT
W "^",IBADIAG,"^",IBENRLL,"^",IBAAD,"^",IBNAD,"^",$P(IBRAD," "),"^",$P(IBRAD," ",2),"^",$P(IBRAD," ",3)
I IBCHK=1 W "^ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA." Q
W "^",IBLOS,"^",IBSACNT,"^",IBSNCNT
S RCNT="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT S REA="" D
.F S REA=$O(IBRSY(RCNT,REA)) Q:REA="" D
..W "^",REA,"^",(9999-RCNT)
;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 !!,"^ADMIT^DISCH^^ENRLL^^^A-REA^A-REA^A-REA^^#AC^#N-AC"
F I=1:1:IBLVH D ; for Download rpt. use F I=1:1:IBLVH
.W "^",$J("S-REA",6),"^"
W !,"SSN^DATE^DATE^DIAG^R-D-L^A^N^1^2^3^#LOS^DAYS^DAYS"
F I=1:1:IBLVH D ; for Download rpt. use F I=1:1:IBLVH
.W "^",$J(I,1),"^",$J("CNT",3)
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[HIBQLD3A 2565 printed Nov 22, 2024@17:51:09 Page 2
IBQLD3A ;LEB/MRY - PROVIDER/PATIENT DOWNLOAD ; 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 DO HDR
IF '$DATA(^TMP("IBQLD3",$JOB))
WRITE !!,?20,"<<< NO PATIENTS TO PRINT >>>"
QUIT
+4 ;
+5 FOR
SET IBPHY=$ORDER(^TMP("IBQLD3",$JOB,IBPHY))
if IBPHY=""
QUIT
Begin DoDot:1
+6 SET IBSUBH=IBTYD_": "_IBPHY
+7 DO PLINE
+8 SET IBDDT=""
FOR
SET IBDDT=$ORDER(^TMP("IBQLD3",$JOB,IBPHY,IBDDT))
if 'IBDDT
QUIT
Begin DoDot:2
+9 SET IBSSN=""
FOR
SET IBSSN=$ORDER(^TMP("IBQLD3",$JOB,IBPHY,IBDDT,IBSSN))
if 'IBSSN
QUIT
DO DATA
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+10 QUIT
+11 ;
END KILL IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD
+1 QUIT
+2 ;
DATA ;
+1 SET IBDATA=^TMP("IBQLD3",$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("IBQLD3",$JOB,IBPHY,IBDDT,IBSSN,"LOS"))
+7 SET IBSACNT=$GET(^TMP("IBQLD3",$JOB,IBPHY,IBDDT,IBSSN,"S-AC"))
+8 SET IBSNCNT=$GET(^TMP("IBQLD3",$JOB,IBPHY,IBDDT,IBSSN,"S-NAC"))
+9 KILL IBRSY
SET IBRSY=""
+10 FOR
SET IBRSY=$ORDER(^TMP("IBQLD3",$JOB,IBPHY,IBDDT,IBSSN,IBRSY))
if 'IBRSY
QUIT
Begin DoDot:1
+11 SET IBRSYCNT=^TMP("IBQLD3",$JOB,IBPHY,IBDDT,IBSSN,IBRSY)
+12 SET IBRSY(9999-IBRSYCNT,IBRSY)=""
End DoDot:1
+13 DO PLINE
+14 QUIT
+15 ;
PLINE ;
+1 IF IBSUBH'=""
IF '$GET(IBSSN)
WRITE !!,IBSUBH,!
QUIT
+2 WRITE !,IBSSN,"^"
SET IBDT=IBADM
DO DTC
WRITE IBDT
WRITE "^"
SET IBDT=IBDDT
DO DTC
WRITE IBDT
+3 WRITE "^",IBADIAG,"^",IBENRLL,"^",IBAAD,"^",IBNAD,"^",$PIECE(IBRAD," "),"^",$PIECE(IBRAD," ",2),"^",$PIECE(IBRAD," ",3)
+4 IF IBCHK=1
WRITE "^ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA."
QUIT
+5 WRITE "^",IBLOS,"^",IBSACNT,"^",IBSNCNT
+6 SET RCNT=""
FOR
SET RCNT=$ORDER(IBRSY(RCNT))
if 'RCNT
QUIT
SET REA=""
Begin DoDot:1
+7 FOR
SET REA=$ORDER(IBRSY(RCNT,REA))
if REA=""
QUIT
Begin DoDot:2
+8 WRITE "^",REA,"^",(9999-RCNT)
End DoDot:2
End DoDot:1
+9 ;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(...
+10 ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
+11 QUIT
+12 ;
HDR ;
+1 WRITE !!,"^ADMIT^DISCH^^ENRLL^^^A-REA^A-REA^A-REA^^#AC^#N-AC"
+2 ; for Download rpt. use F I=1:1:IBLVH
FOR I=1:1:IBLVH
Begin DoDot:1
+3 WRITE "^",$JUSTIFY("S-REA",6),"^"
End DoDot:1
+4 WRITE !,"SSN^DATE^DATE^DIAG^R-D-L^A^N^1^2^3^#LOS^DAYS^DAYS"
+5 ; for Download rpt. use F I=1:1:IBLVH
FOR I=1:1:IBLVH
Begin DoDot:1
+6 WRITE "^",$JUSTIFY(I,1),"^",$JUSTIFY("CNT",3)
End DoDot:1
+7 QUIT
+8 ;
DTC SET IBDT=+$EXTRACT(IBDT,4,5)_"/"_$EXTRACT(IBDT,6,7)_"/"_$EXTRACT(IBDT,2,3)
+1 QUIT
