IBOBCR6 ;ALB/RJS-CONTINUOUS PATIENT PRINTOUT;2/20/92
;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
;
;
;THIS REPORT GATHERS DATA FROM THE IB CONTINUOUS PT FILE 351.1
;THE PATIENT FILE 2 AND THE MEANS TEST FILE 41.3 AND REPORTS 6
;FIELDS IN COLUMNAR FORMAT. THE FIELDS ARE
;Patient Name,Pt-Id,Ward Location,Means Test,Last Means,Eligibility
; Status Test Date
;
START ;
;***
;S XRTL=$ZU(0),XRTN="IBOBCR6-1" D T0^%ZOSV ;start rt clock
W !,"Margin width of this report is 132 columns",!
D OPEN G EXIT:POP
I $D(IO("Q")) D QUEUED,HOME^%ZIS G END
U IO
LOOP ;
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
;S XRTL=$ZU(0),XRTN="IBOBCR6-2" D T0^%ZOSV ;start rt clock
S IBCOL2=23,IBCOL3=37,IBCOL4=54,IBCOL5=66,IBCOL6=84,IBDONE=0,IBRECNR=0
F S IBRECNR=$O(^IBE(351.1,IBRECNR)) Q:IBRECNR'>0 S IBDATA=^IBE(351.1,IBRECNR,0) D BUILDARY:+IBDATA
D OUTPUT
END ;
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6-2" D T1^%ZOSV ;stop rt clock
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
EXIT ;
K IBDATA,IBMNSCAT,IBMNSDTA,IBDATE,IBNAME,IBOUT,IBPAGE,IBPATDIS,POP,IBRECNR
K IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOL5,IBCOL6,IBDONE,^TMP($J,"IBOBCR6"),DIRUT,IBRECORD
K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
D KVAR^VADPT
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
Q
QUEUED ;
S ZTRTN="LOOP^IBOBCR6",ZTDESC="Current Continuous Pt Report"
D ^%ZTLOAD W !!,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled")
Q
BUILDARY ;
S DFN=+IBDATA,IBPATDIS=$P(IBDATA,"^",2)
I DFN=""!((IBPATDIS'="")&(IBPATDIS'>DT)) Q
I '$D(^DPT(DFN,0)) Q
D 2^VADPT,MEANS,LOADARY
Q
MEANS ;
;PIECE 2=LAST MT DATE///PIECE 3=STATUS NAME
S IBXX=$$LST^DGMTU(DFN),IBDATE=$P(IBXX,U,2),IBMNSCAT=$P(IBXX,U,4)
S IBMNSCAT=$S(IBMNSCAT="P":"PEN",IBMNSCAT="G":"GMT",IBMNSCAT="C":"YES",IBMNSCAT="R":"REQ",1:"NO")
I IBDATE'="" S IBDATE=$E(IBDATE,4,5)_"/"_$E(IBDATE,6,7)_"/"_$E(IBDATE,2,3)
Q
LOADARY ;***IN LOADARY FUNCTION THESE ARE THE VALUES***
;*** BEING LOADED FROM THE CALLS TO VADPT ***
;
; PATIENT = VADM(1)
; ELIGIBILITY = $P(VAEL(1),"^",2)
; SSI = $P(VADM(2),"^",2)
; LOCATION = $G(^DPT(DFN,.1))
;
S ^TMP($J,"IBOBCR6",VADM(1),DFN)=VADM(1)_"^"_$P(VADM(2),"^",2)_"^"_$G(^DPT(DFN,.1))_"^"_$P(VAEL(1),"^",2)_"^"_IBMNSCAT_"^"_IBDATE
Q
OUTPUT ;
S Y=DT X ^DD("DD")
S IBPAGE=1,IBOUT=""
D HEADING
S IBNAME=""
F S IBNAME=$O(^TMP($J,"IBOBCR6",IBNAME)) Q:IBNAME=""!(IBDONE) S DFN="" F S DFN=$O(^TMP($J,"IBOBCR6",IBNAME,DFN)) Q:DFN=""!(IBDONE) D LINE
Q
LINE ;
S IBRECORD=^TMP($J,"IBOBCR6",IBNAME,DFN)
;***PATIENT NAME***
W $E(IBNAME,1,20),?IBCOL2
;***PATIENT SSI****
W $E($P(IBRECORD,"^",2),1,11),?IBCOL3
;***PATIENT LOCATION***
W $E($P(IBRECORD,"^",3),1,14),?IBCOL4
;***LAST MEANS TEST DATE****
W $E($P(IBRECORD,"^",6),1,8),?IBCOL5
;***PATIENT MEANS TEST STATUS***
W $P(IBRECORD,"^",5),?IBCOL6
;***PATIENT ELIGIBILITY***
W $E($P(IBRECORD,"^",4),1,30),!
D:$Y+3>IOSL HEADING
Q
OPEN ;
S %ZIS="QM" D ^%ZIS
Q
HEADING ;
I IBPAGE>1,($E(IOST,1,2)="C-")
I S DIR(0)="E" D ^DIR K DIR I $D(DUOUT) S IBDONE=1 Q
I $E(IOST,1,2)["C-"!(IBPAGE>1) W @IOF ; initial form feeds to crts subsequent form feeds to all
W !,Y,?IBCOL2,"***Patients Continuously Hospitalized Since July 1, 1986***",?IBCOL6,"PAGE ",IBPAGE
W !!,"Patient NAME",?IBCOL2,"Pt-Id",?IBCOL3,"Ward Location",?IBCOL4
W "Last Means",?IBCOL5,"Means Test",?IBCOL6,"Eligibility"
W !,?IBCOL4,"Test Date",?IBCOL5,"Status",!
S IBX="",$P(IBX,"=",IOM)="" W IBX,!
S IBPAGE=IBPAGE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOBCR6 3646 printed Nov 22, 2024@17:35:18 Page 2
IBOBCR6 ;ALB/RJS-CONTINUOUS PATIENT PRINTOUT;2/20/92
+1 ;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
+2 ;
+3 ;
+4 ;THIS REPORT GATHERS DATA FROM THE IB CONTINUOUS PT FILE 351.1
+5 ;THE PATIENT FILE 2 AND THE MEANS TEST FILE 41.3 AND REPORTS 6
+6 ;FIELDS IN COLUMNAR FORMAT. THE FIELDS ARE
+7 ;Patient Name,Pt-Id,Ward Location,Means Test,Last Means,Eligibility
+8 ; Status Test Date
+9 ;
START ;
+1 ;***
+2 ;S XRTL=$ZU(0),XRTN="IBOBCR6-1" D T0^%ZOSV ;start rt clock
+3 WRITE !,"Margin width of this report is 132 columns",!
+4 DO OPEN
if POP
GOTO EXIT
+5 IF $DATA(IO("Q"))
DO QUEUED
DO HOME^%ZIS
GOTO END
+6 USE IO
LOOP ;
+1 ;***
+2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
+3 ;S XRTL=$ZU(0),XRTN="IBOBCR6-2" D T0^%ZOSV ;start rt clock
+4 SET IBCOL2=23
SET IBCOL3=37
SET IBCOL4=54
SET IBCOL5=66
SET IBCOL6=84
SET IBDONE=0
SET IBRECNR=0
+5 FOR
SET IBRECNR=$ORDER(^IBE(351.1,IBRECNR))
if IBRECNR'>0
QUIT
SET IBDATA=^IBE(351.1,IBRECNR,0)
if +IBDATA
DO BUILDARY
+6 DO OUTPUT
END ;
+1 ;***
+2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6-2" D T1^%ZOSV ;stop rt clock
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+4 DO ^%ZISC
EXIT ;
+1 KILL IBDATA,IBMNSCAT,IBMNSDTA,IBDATE,IBNAME,IBOUT,IBPAGE,IBPATDIS,POP,IBRECNR
+2 KILL IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOL5,IBCOL6,IBDONE,^TMP($JOB,"IBOBCR6"),DIRUT,IBRECORD
+3 KILL ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
+4 DO KVAR^VADPT
+5 ;***
+6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
+7 QUIT
QUEUED ;
+1 SET ZTRTN="LOOP^IBOBCR6"
SET ZTDESC="Current Continuous Pt Report"
+2 DO ^%ZTLOAD
WRITE !!,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled")
+3 QUIT
BUILDARY ;
+1 SET DFN=+IBDATA
SET IBPATDIS=$PIECE(IBDATA,"^",2)
+2 IF DFN=""!((IBPATDIS'="")&(IBPATDIS'>DT))
QUIT
+3 IF '$DATA(^DPT(DFN,0))
QUIT
+4 DO 2^VADPT
DO MEANS
DO LOADARY
+5 QUIT
MEANS ;
+1 ;PIECE 2=LAST MT DATE///PIECE 3=STATUS NAME
+2 SET IBXX=$$LST^DGMTU(DFN)
SET IBDATE=$PIECE(IBXX,U,2)
SET IBMNSCAT=$PIECE(IBXX,U,4)
+3 SET IBMNSCAT=$SELECT(IBMNSCAT="P":"PEN",IBMNSCAT="G":"GMT",IBMNSCAT="C":"YES",IBMNSCAT="R":"REQ",1:"NO")
+4 IF IBDATE'=""
SET IBDATE=$EXTRACT(IBDATE,4,5)_"/"_$EXTRACT(IBDATE,6,7)_"/"_$EXTRACT(IBDATE,2,3)
+5 QUIT
LOADARY ;***IN LOADARY FUNCTION THESE ARE THE VALUES***
+1 ;*** BEING LOADED FROM THE CALLS TO VADPT ***
+2 ;
+3 ; PATIENT = VADM(1)
+4 ; ELIGIBILITY = $P(VAEL(1),"^",2)
+5 ; SSI = $P(VADM(2),"^",2)
+6 ; LOCATION = $G(^DPT(DFN,.1))
+7 ;
+8 SET ^TMP($JOB,"IBOBCR6",VADM(1),DFN)=VADM(1)_"^"_$PIECE(VADM(2),"^",2)_"^"_$GET(^DPT(DFN,.1))_"^"_$PIECE(VAEL(1),"^",2)_"^"_IBMNSCAT_"^"_IBDATE
+9 QUIT
OUTPUT ;
+1 SET Y=DT
XECUTE ^DD("DD")
+2 SET IBPAGE=1
SET IBOUT=""
+3 DO HEADING
+4 SET IBNAME=""
+5 FOR
SET IBNAME=$ORDER(^TMP($JOB,"IBOBCR6",IBNAME))
if IBNAME=""!(IBDONE)
QUIT
SET DFN=""
FOR
SET DFN=$ORDER(^TMP($JOB,"IBOBCR6",IBNAME,DFN))
if DFN=""!(IBDONE)
QUIT
DO LINE
+6 QUIT
LINE ;
+1 SET IBRECORD=^TMP($JOB,"IBOBCR6",IBNAME,DFN)
+2 ;***PATIENT NAME***
+3 WRITE $EXTRACT(IBNAME,1,20),?IBCOL2
+4 ;***PATIENT SSI****
+5 WRITE $EXTRACT($PIECE(IBRECORD,"^",2),1,11),?IBCOL3
+6 ;***PATIENT LOCATION***
+7 WRITE $EXTRACT($PIECE(IBRECORD,"^",3),1,14),?IBCOL4
+8 ;***LAST MEANS TEST DATE****
+9 WRITE $EXTRACT($PIECE(IBRECORD,"^",6),1,8),?IBCOL5
+10 ;***PATIENT MEANS TEST STATUS***
+11 WRITE $PIECE(IBRECORD,"^",5),?IBCOL6
+12 ;***PATIENT ELIGIBILITY***
+13 WRITE $EXTRACT($PIECE(IBRECORD,"^",4),1,30),!
+14 if $Y+3>IOSL
DO HEADING
+15 QUIT
OPEN ;
+1 SET %ZIS="QM"
DO ^%ZIS
+2 QUIT
HEADING ;
+1 IF IBPAGE>1
IF ($EXTRACT(IOST,1,2)="C-")
+2 IF $TEST
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET IBDONE=1
QUIT
+3 ; initial form feeds to crts subsequent form feeds to all
IF $EXTRACT(IOST,1,2)["C-"!(IBPAGE>1)
WRITE @IOF
+4 WRITE !,Y,?IBCOL2,"***Patients Continuously Hospitalized Since July 1, 1986***",?IBCOL6,"PAGE ",IBPAGE
+5 WRITE !!,"Patient NAME",?IBCOL2,"Pt-Id",?IBCOL3,"Ward Location",?IBCOL4
+6 WRITE "Last Means",?IBCOL5,"Means Test",?IBCOL6,"Eligibility"
+7 WRITE !,?IBCOL4,"Test Date",?IBCOL5,"Status",!
+8 SET IBX=""
SET $PIECE(IBX,"=",IOM)=""
WRITE IBX,!
+9 SET IBPAGE=IBPAGE+1
+10 QUIT
