IBQLD2A ;LEB/MRY - PATIENT DOWNLOAD TO SPREADSHEET ; 1-JUN-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
PRINT D SVCTAB^IBQLR1B S (IBDATA,IBTS,IBQUIT,IBHDR,IBHDR1,IBSVC)="",IBPAG=0
; -- call to return header dates - IBTDT, IBDRNG
D DTC^IBQLPL2
D HDR ;S IBHDR="UTILIZATION MANAGEMENT",IBHDR1="PATIENT REVIEWS FOR "_IBDRNG
;
F S IBSVC=$O(^TMP("IBQLD2",$J,IBSVC)) Q:IBSVC="" D TS Q:IBQUIT
G END
TS F S IBTS=$O(^TMP("IBQLD2",$J,IBSVC,IBTS)) Q:IBTS="" D Q:IBQUIT
.I IBTS=999 S IBSUBH=$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
.E S IBSUBH=IBTS_",("_$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
.I IBTY="I",'$D(IBTS(IBTS)) Q
.D PLINE
.S IBDDT="" F S IBDDT=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT)) Q:'IBDDT D Q:IBQUIT
..S IBSSN="" F S IBSSN=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,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("IBQLD2",$J,IBSVC,IBTS,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 IBLOS=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"LOS"))
S IBSACNT=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-AC"))
S IBSNCNT=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-NAC"))
K IBRSY S IBRSY=""
F S IBRSY=$O(^TMP("IBQLD2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
.S IBRSYCNT=^TMP("IBQLD2",$J,IBSVC,IBTS,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),"^",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)
;S RCNT="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
;.W "^",IBRSY(RCNT),"^",(9999-RCNT)
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[HIBQLD2A 2703 printed Nov 22, 2024@17:51:07 Page 2
IBQLD2A ;LEB/MRY - PATIENT DOWNLOAD TO SPREADSHEET ; 1-JUN-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 DO SVCTAB^IBQLR1B
SET (IBDATA,IBTS,IBQUIT,IBHDR,IBHDR1,IBSVC)=""
SET IBPAG=0
+1 ; -- call to return header dates - IBTDT, IBDRNG
+2 DO DTC^IBQLPL2
+3 ;S IBHDR="UTILIZATION MANAGEMENT",IBHDR1="PATIENT REVIEWS FOR "_IBDRNG
DO HDR
+4 ;
+5 FOR
SET IBSVC=$ORDER(^TMP("IBQLD2",$JOB,IBSVC))
if IBSVC=""
QUIT
DO TS
if IBQUIT
QUIT
+6 GOTO END
TS FOR
SET IBTS=$ORDER(^TMP("IBQLD2",$JOB,IBSVC,IBTS))
if IBTS=""
QUIT
Begin DoDot:1
+1 IF IBTS=999
SET IBSUBH=$SELECT($DATA(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
+2 IF '$TEST
SET IBSUBH=IBTS_",("_$SELECT($DATA(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
+3 IF IBTY="I"
IF '$DATA(IBTS(IBTS))
QUIT
+4 DO PLINE
+5 SET IBDDT=""
FOR
SET IBDDT=$ORDER(^TMP("IBQLD2",$JOB,IBSVC,IBTS,IBDDT))
if 'IBDDT
QUIT
Begin DoDot:2
+6 SET IBSSN=""
FOR
SET IBSSN=$ORDER(^TMP("IBQLD2",$JOB,IBSVC,IBTS,IBDDT,IBSSN))
if 'IBSSN
QUIT
DO DATA
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+7 QUIT
+8 ;
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("IBQLD2",$JOB,IBSVC,IBTS,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 IBLOS=$GET(^TMP("IBQLD2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,"LOS"))
+6 SET IBSACNT=$GET(^TMP("IBQLD2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,"S-AC"))
+7 SET IBSNCNT=$GET(^TMP("IBQLD2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,"S-NAC"))
+8 KILL IBRSY
SET IBRSY=""
+9 FOR
SET IBRSY=$ORDER(^TMP("IBQLD2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,IBRSY))
if 'IBRSY
QUIT
Begin DoDot:1
+10 SET IBRSYCNT=^TMP("IBQLD2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)
+11 SET IBRSY(9999-IBRSYCNT,IBRSY)=""
End DoDot:1
+12 DO PLINE
+13 QUIT
+14 ;
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),"^",IBLOS,"^",IBSACNT,"^",IBSNCNT
+4 SET RCNT=""
FOR
SET RCNT=$ORDER(IBRSY(RCNT))
if 'RCNT
QUIT
SET REA=""
Begin DoDot:1
+5 FOR
SET REA=$ORDER(IBRSY(RCNT,REA))
if REA=""
QUIT
Begin DoDot:2
+6 WRITE "^",REA,"^",(9999-RCNT)
End DoDot:2
End DoDot:1
+7 ;S RCNT="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
+8 ;.W "^",IBRSY(RCNT),"^",(9999-RCNT)
+9 QUIT
+10 ;
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
