IBQLSCR ;LEB/MRY - SCREEN DUMP OF RAW DATA FOR DOWNLOAD SPREADSHEET ; 12-APR-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
D SVCTAB^IBQLR1B
;
W !!,"Load Data to Excel"
W !!,"Set your Device settings to '0;255;9999'"
DEV ; -- select device, run option
W ! D ^%ZIS G:POP END
S DIR(0)="FO",DIR("A")="Initiate File Capture Procedure and Press Return" D ^DIR I $D(DTOUT)!$D(DUOUT) G END
W !,"Working...",!
U IO
;
START ;
W !,"ssn^adm. diag^enrollement code^adm. phy^attend. phy^resident phy^adm. date^disch. date^ward^ts^service^acute adm.?^si^is^reasons^prov. interviewed?^adm. influenced?^day^day is^day si^day d/s^day interviewed?^day reasons^ts^service"
S IBDDT=IBBDT-.01
F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
.S IBTRN=0
.F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
;
END D ^%ZISC K IBTRN,POP,IBSTR,X,I,II Q
;
DATA ;
S IBWRAP=""
S X=^IBQ(538,IBTRN,0),IBSTR="",X1=$G(^(1))
F I=3:1:13 S IBSTR=IBSTR_$P(X,"^",I)_"^"
S $P(IBSTR,"^",13)=$P(IBSTR,"^",12),$P(IBSTR,"^",12)=$G(IBSVC($P(X1,"^",7)))
F I=1:1:5 S IBSTR=IBSTR_$P(X1,"^",I)_"^"
F N=7,8 S X=$P(IBSTR,"^",N),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),$P(IBSTR,"^",N)=X
F N=12,16,17 S X=$P(IBSTR,"^",N),X=$S(X=0:"N",X=1:"Y",1:""),$P(IBSTR,"^",N)=X
S N=0 F S N=$O(^IBQ(538,IBTRN,13,N)) Q:'N F I=1:1:8 D
.I I=1,$L(IBSTR)>(IOM-60) S IBWRAP=1 D PLINE
.S X=$P(^IBQ(538,IBTRN,13,N,0),"^",I)
.I I=5 S X=$S(X=0:"N",X=1:"Y",1:"")
.I I=8 S X=$G(IBSVC(X))
.S IBSTR=IBSTR_X_"^"
.Q
S IBSTR=$P(IBSTR,"^",1,$L(IBSTR,"^")-1)
D PLINE
Q
;
PLINE W !,IBSTR
S:'IBWRAP IBSTR="" S:IBWRAP IBSTR="WRAP:DAY>",IBWRAP=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLSCR 1824 printed Oct 16, 2024@18:42:08 Page 2
IBQLSCR ;LEB/MRY - SCREEN DUMP OF RAW DATA FOR DOWNLOAD SPREADSHEET ; 12-APR-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 DO SVCTAB^IBQLR1B
+3 ;
+4 WRITE !!,"Load Data to Excel"
+5 WRITE !!,"Set your Device settings to '0;255;9999'"
DEV ; -- select device, run option
+1 WRITE !
DO ^%ZIS
if POP
GOTO END
+2 SET DIR(0)="FO"
SET DIR("A")="Initiate File Capture Procedure and Press Return"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO END
+3 WRITE !,"Working...",!
+4 USE IO
+5 ;
START ;
+1 WRITE !,"ssn^adm. diag^enrollement code^adm. phy^attend. phy^resident phy^adm. date^disch. date^ward^ts^service^acute adm.?^si^is^reasons^prov. interviewed?^adm. influenced?^day^day is^day si^day d/s^day interviewed?^day reasons^ts^service"
+2 SET IBDDT=IBBDT-.01
+3 FOR
SET IBDDT=$ORDER(^IBQ(538,"ADIS",IBDDT))
if 'IBDDT!(IBDDT>IBEDT)
QUIT
Begin DoDot:1
+4 SET IBTRN=0
+5 FOR
SET IBTRN=$ORDER(^IBQ(538,"ADIS",IBDDT,IBTRN))
if 'IBTRN
QUIT
DO DATA
End DoDot:1
+6 ;
END DO ^%ZISC
KILL IBTRN,POP,IBSTR,X,I,II
QUIT
+1 ;
DATA ;
+1 SET IBWRAP=""
+2 SET X=^IBQ(538,IBTRN,0)
SET IBSTR=""
SET X1=$GET(^(1))
+3 FOR I=3:1:13
SET IBSTR=IBSTR_$PIECE(X,"^",I)_"^"
+4 SET $PIECE(IBSTR,"^",13)=$PIECE(IBSTR,"^",12)
SET $PIECE(IBSTR,"^",12)=$GET(IBSVC($PIECE(X1,"^",7)))
+5 FOR I=1:1:5
SET IBSTR=IBSTR_$PIECE(X1,"^",I)_"^"
+6 FOR N=7,8
SET X=$PIECE(IBSTR,"^",N)
SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
SET $PIECE(IBSTR,"^",N)=X
+7 FOR N=12,16,17
SET X=$PIECE(IBSTR,"^",N)
SET X=$SELECT(X=0:"N",X=1:"Y",1:"")
SET $PIECE(IBSTR,"^",N)=X
+8 SET N=0
FOR
SET N=$ORDER(^IBQ(538,IBTRN,13,N))
if 'N
QUIT
FOR I=1:1:8
Begin DoDot:1
+9 IF I=1
IF $LENGTH(IBSTR)>(IOM-60)
SET IBWRAP=1
DO PLINE
+10 SET X=$PIECE(^IBQ(538,IBTRN,13,N,0),"^",I)
+11 IF I=5
SET X=$SELECT(X=0:"N",X=1:"Y",1:"")
+12 IF I=8
SET X=$GET(IBSVC(X))
+13 SET IBSTR=IBSTR_X_"^"
+14 QUIT
End DoDot:1
+15 SET IBSTR=$PIECE(IBSTR,"^",1,$LENGTH(IBSTR,"^")-1)
+16 DO PLINE
+17 QUIT
+18 ;
PLINE WRITE !,IBSTR
+1 if 'IBWRAP
SET IBSTR=""
if IBWRAP
SET IBSTR="WRAP:DAY>"
SET IBWRAP=""
+2 QUIT
