Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBOBCR6

IBOBCR6.m

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