source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBOBCR6.m@ 628

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