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

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1IBOBCR6 ;ALB/RJS-CONTINUOUS PATIENT PRINTOUT;2/20/92
2 ;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
3 ;
4 ;
5 ;THIS REPORT GATHERS DATA FROM THE IB CONTINUOUS PT FILE 351.1
6 ;THE PATIENT FILE 2 AND THE MEANS TEST FILE 41.3 AND REPORTS 6
7 ;FIELDS IN COLUMNAR FORMAT. THE FIELDS ARE
8 ;Patient Name,Pt-Id,Ward Location,Means Test,Last Means,Eligibility
9 ; Status Test Date
10 ;
11START ;
12 ;***
13 ;S XRTL=$ZU(0),XRTN="IBOBCR6-1" D T0^%ZOSV ;start rt clock
14 W !,"Margin width of this report is 132 columns",!
15 D OPEN G EXIT:POP
16 I $D(IO("Q")) D QUEUED,HOME^%ZIS G END
17 U IO
18LOOP ;
19 ;***
20 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
21 ;S XRTL=$ZU(0),XRTN="IBOBCR6-2" D T0^%ZOSV ;start rt clock
22 S IBCOL2=23,IBCOL3=37,IBCOL4=54,IBCOL5=66,IBCOL6=84,IBDONE=0,IBRECNR=0
23 F S IBRECNR=$O(^IBE(351.1,IBRECNR)) Q:IBRECNR'>0 S IBDATA=^IBE(351.1,IBRECNR,0) D BUILDARY:+IBDATA
24 D OUTPUT
25END ;
26 ;***
27 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6-2" D T1^%ZOSV ;stop rt clock
28 I $D(ZTQUEUED) S ZTREQ="@" Q
29 D ^%ZISC
30EXIT ;
31 K IBDATA,IBMNSCAT,IBMNSDTA,IBDATE,IBNAME,IBOUT,IBPAGE,IBPATDIS,POP,IBRECNR
32 K IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOL5,IBCOL6,IBDONE,^TMP($J,"IBOBCR6"),DIRUT,IBRECORD
33 K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
34 D KVAR^VADPT
35 ;***
36 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
37 Q
38QUEUED ;
39 S ZTRTN="LOOP^IBOBCR6",ZTDESC="Current Continuous Pt Report"
40 D ^%ZTLOAD W !!,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled")
41 Q
42BUILDARY ;
43 S DFN=+IBDATA,IBPATDIS=$P(IBDATA,"^",2)
44 I DFN=""!((IBPATDIS'="")&(IBPATDIS'>DT)) Q
45 I '$D(^DPT(DFN,0)) Q
46 D 2^VADPT,MEANS,LOADARY
47 Q
48MEANS ;
49 ;PIECE 2=LAST MT DATE///PIECE 3=STATUS NAME
50 S IBXX=$$LST^DGMTU(DFN),IBDATE=$P(IBXX,U,2),IBMNSCAT=$P(IBXX,U,4)
51 S IBMNSCAT=$S(IBMNSCAT="P":"PEN",IBMNSCAT="G":"GMT",IBMNSCAT="C":"YES",IBMNSCAT="R":"REQ",1:"NO")
52 I IBDATE'="" S IBDATE=$E(IBDATE,4,5)_"/"_$E(IBDATE,6,7)_"/"_$E(IBDATE,2,3)
53 Q
54LOADARY ;***IN LOADARY FUNCTION THESE ARE THE VALUES***
55 ;*** BEING LOADED FROM THE CALLS TO VADPT ***
56 ;
57 ; PATIENT = VADM(1)
58 ; ELIGIBILITY = $P(VAEL(1),"^",2)
59 ; SSI = $P(VADM(2),"^",2)
60 ; LOCATION = $G(^DPT(DFN,.1))
61 ;
62 S ^TMP($J,"IBOBCR6",VADM(1),DFN)=VADM(1)_"^"_$P(VADM(2),"^",2)_"^"_$G(^DPT(DFN,.1))_"^"_$P(VAEL(1),"^",2)_"^"_IBMNSCAT_"^"_IBDATE
63 Q
64OUTPUT ;
65 S Y=DT X ^DD("DD")
66 S IBPAGE=1,IBOUT=""
67 D HEADING
68 S IBNAME=""
69 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
70 Q
71LINE ;
72 S IBRECORD=^TMP($J,"IBOBCR6",IBNAME,DFN)
73 ;***PATIENT NAME***
74 W $E(IBNAME,1,20),?IBCOL2
75 ;***PATIENT SSI****
76 W $E($P(IBRECORD,"^",2),1,11),?IBCOL3
77 ;***PATIENT LOCATION***
78 W $E($P(IBRECORD,"^",3),1,14),?IBCOL4
79 ;***LAST MEANS TEST DATE****
80 W $E($P(IBRECORD,"^",6),1,8),?IBCOL5
81 ;***PATIENT MEANS TEST STATUS***
82 W $P(IBRECORD,"^",5),?IBCOL6
83 ;***PATIENT ELIGIBILITY***
84 W $E($P(IBRECORD,"^",4),1,30),!
85 D:$Y+3>IOSL HEADING
86 Q
87OPEN ;
88 S %ZIS="QM" D ^%ZIS
89 Q
90HEADING ;
91 I IBPAGE>1,($E(IOST,1,2)="C-")
92 I S DIR(0)="E" D ^DIR K DIR I $D(DUOUT) S IBDONE=1 Q
93 I $E(IOST,1,2)["C-"!(IBPAGE>1) W @IOF ; initial form feeds to crts subsequent form feeds to all
94 W !,Y,?IBCOL2,"***Patients Continuously Hospitalized Since July 1, 1986***",?IBCOL6,"PAGE ",IBPAGE
95 W !!,"Patient NAME",?IBCOL2,"Pt-Id",?IBCOL3,"Ward Location",?IBCOL4
96 W "Last Means",?IBCOL5,"Means Test",?IBCOL6,"Eligibility"
97 W !,?IBCOL4,"Test Date",?IBCOL5,"Status",!
98 S IBX="",$P(IBX,"=",IOM)="" W IBX,!
99 S IBPAGE=IBPAGE+1
100 Q
Note: See TracBrowser for help on using the repository browser.