source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATOP.m@ 1464

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

initial load of WorldVistAEHR

File size: 6.8 KB
Line 
1IBATOP ;ALB/CPM-TRANSFER PRICING PATIENT LISTING ;21-MAR-99
2 ;;2.0;INTEGRATED BILLING;**115,153,183,249**;21-MAR-94
3 ;
4EN ; Option entry point.
5 ;
6 W !!,"This report creates a listing of all Transfer Pricing patients for"
7 W !,"specific networks or facilities. Please enter all applicable networks"
8 W !,"and facilities, specifying networks by VISN (i.e., 'VISN 1').",!
9 ;
10 ; - allow entry of network/facilities; quit if none entered
11 Q:$$FAC^IBATUTL
12 ;
13 ; - set flag to determine if all facilities were entered
14 S IBALL='$D(IBFAC)
15 ;
16 W !!,"This report requires only an 80 column printer.",!
17 ;
18 ; - select a device
19 S %ZIS="QM" D ^%ZIS I POP G ENQ
20 I $D(IO("Q")) D G ENQ
21 .S ZTRTN="DQ^IBATOP",ZTDESC="IB - TRANSFER PRICING PATIENT LISTING"
22 .S ZTSAVE("IBALL")="" I $D(IBFAC) S ZTSAVE("IBFAC(")=""
23 .D ^%ZTLOAD
24 .W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
25 .K ZTSK,IO("Q") D HOME^%ZIS
26 ;
27 U IO
28 ;
29DQ ; Tasked entry point.
30 ;
31 K ^TMP("IBATOP",$J),IBARR,IBFACN,^TMP($J,"SDAMA301"),^TMP("IBDFN",$J)
32 N IBARRAY,IBCOUNT,IBNDT
33 ;
34 ; - process the entire file if all patients were selected
35 I IBALL D G PRINT
36 .S DFN=0 F S DFN=$O(^IBAT(351.6,DFN)) Q:'DFN S IBD=$G(^(DFN,0)) D
37 ..;
38 ..; - get the enrolled facility and find the associated network
39 ..S IBSTN=+$$PPF^IBATUTL(DFN)
40 ..;S IBSTN=+$P(IBD,"^",3)
41 ..I '$D(IBARR(IBSTN)) D
42 ...N X,Y
43 ...S X=$$VISN^IBATUTL(IBSTN),Y=$$INST^IBATUTL(IBSTN)
44 ...S:$P(Y,"^",2)="" $P(Y,"^",2)="<No Sta. #>"
45 ...S IBARR(IBSTN)=+$P($P(X,"^",2)," ",2)_"^"_Y
46 ...S IBFACN(IBSTN)=Y
47 ..;
48 ..; - set patient information
49 ..D SET(+IBARR(IBSTN),IBSTN,DFN)
50 ;
51 ; - process patients from selected networks/facilities
52 S IBX="" F S IBX=$O(IBFAC(IBX)) Q:IBX="" D
53 .S IBSTN="" F S IBSTN=$O(IBFAC(IBX,"C",IBSTN)) Q:IBSTN="" D
54 ..;
55 ..; - get facility/network information
56 ..S IBNET=+$P($P($$VISN^IBATUTL(IBSTN),"^",2)," ",2)
57 ..S IBY=$$INST^IBATUTL(IBSTN)
58 ..S:$P(IBY,"^",2)="" $P(IBY,"^",2)="<No Sta. #>"
59 ..S IBFACN(IBSTN)=IBY
60 ..;
61 ..; - find all patients from the specific facility
62 ..S DFN=0 F S DFN=$O(^IBAT(351.6,"AD",IBSTN,DFN)) Q:'DFN D
63 ...D SET(IBNET,IBSTN,DFN)
64 ;
65PRINT ;
66 ; now call scheduling to look up future appts
67 S IBARRAY(1)=$$NOW^XLFDT_";9999999"
68 S IBARRAY(3)="R;I;NT"
69 S IBARRAY(4)="^TMP(""IBDFN"",$J,"
70 S IBARRAY("SORT")="P"
71 S IBARRAY("FLDS")=1
72 S IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
73 ;
74 ; Print the report.
75 ;
76 S (IBPAG,IBQ)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
77 ;
78 I '$D(^TMP("IBATOP",$J)) D HDR(0) W !!!,"There are no Transfer Pricing patients for the selected networks/facilities." G ENQ
79 ;
80 S IBNET="" F S IBNET=$O(^TMP("IBATOP",$J,IBNET)) Q:IBNET=""!(IBQ) D
81 .D PAUSE:IBPAG,HDR(IBNET)
82 .S IBSTN="" F S IBSTN=$O(^TMP("IBATOP",$J,IBNET,IBSTN)) Q:IBSTN=""!(IBQ) D
83 ..;
84 ..I $Y>(IOSL-4) D PAUSE Q:IBQ D HDR(IBNET)
85 ..D DISFAC(IBSTN)
86 ..;
87 ..S IBNAM="" F S IBNAM=$O(^TMP("IBATOP",$J,IBNET,IBSTN,IBNAM)) Q:IBNAM=""!(IBQ) S IBXX=$G(^(IBNAM)) D
88 ...;
89 ...I $Y>(IOSL-2) D PAUSE Q:IBQ D HDR(IBNET),DISFAC(IBSTN)
90 ...;
91 ...W !,$E($P(IBNAM,"@@"),1,20)," (",$P(IBXX,"^"),")"
92 ...W ?28,$E($P(IBXX,"^",2),1,19),?49,$P(IBXX,"^",3),?55,$P(IBXX,"^",4)
93 ...W ?61,$S($P(IBXX,"^",5):$$DAT1^IBOUTL($P(IBXX,"^",5)),1:"")
94 ...S IBNDT=$O(^TMP($J,"SDAMA301",$P(IBNAM,"@@",2),0))
95 ...I IBNDT S $P(IBXX,"^",6)=$S('$P(IBXX,"^",6):IBNDT,IBNDT<$P(IBXX,"^",6):IBNDT,1:$P(IBXX,"^",6))
96 ...W ?71,$S($P(IBXX,"^",6):$$DAT1^IBOUTL($P(IBXX,"^",6)),1:"")
97 ;
98 I 'IBQ D PAUSE
99 ;
100ENQ K ^TMP("IBATOP",$J)
101 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
102 ;
103 D ^%ZISC
104ENQ1 K IBPAG,IBD,IBQ,IBRUN,IBNET,IBSTN,IBNAM,IBXX,IBY
105 K IBFAC,IBFACN,IBARR,IBALL,IBX,DFN,POP,X,Y,SDCNT
106 Q
107 ;
108 ;
109SET(IBNET,IBSTA,DFN) ; Create the temporary sort file.
110 ; Input: IBNET -- The network/VISN number
111 ; IBSTA -- The Station number
112 ; DFN -- Pointer to the patient in file #2
113 ;
114 N IBDFN,IBINS,IBMT,IBTXMT,VAEL,VAERR
115 ;
116 S IBDFN=$$PT^IBEFUNC(DFN)
117 S IBINS=$$INSURED^IBCNS1(DFN),IBMT=$P($$LST^DGMTU(DFN),"^",4)
118 S IBMT=$S(IBMT="C":"YES",IBMT="G":"GMT",IBMT="P":"PEN",IBMT="R":"REQ",1:"NO")
119 S IBTXMT=$$TXMT(DFN)
120 D ELIG^VADPT
121 ;
122 ; - set all patients to be included in array for next appt.
123 I $$GETICN^MPIF001(DFN)>0 S ^TMP("IBDFN",$J,DFN)=""
124 ;
125 ; - set all patient data into the temporary file
126 S ^TMP("IBATOP",$J,IBNET,IBSTA,$P(IBDFN,"^")_"@@"_DFN)=$P(IBDFN,"^",3)_"^"_$P(VAEL(1),"^",2)_"^"_IBMT_"^"_$S(IBINS:"YES",1:"NO")_"^"_IBTXMT
127 Q
128 ;
129TXMT(DFN) ; Find the patient's last treatment date and next sched date
130 ; Input: DFN -- Pointer to the patient in file #2
131 ; Output: 1^2, where
132 ; 1 => last treatment date, or null
133 ; 2 => next scheduled treatment date, or null
134 ; (not including scheduling)
135 ;
136 N IBDT,IBLT,IBNEXT,IBQ,X,X1,X2
137 S (IBLT,IBNEXT)=""
138 ;
139 ; - if current inpatient, set last treatment date to today
140 I $G(^DPT(DFN,.105)) S IBLT=DT G TXMTN
141 ;
142 ; - get the last discharge date
143 S IBLT=+$O(^DGPM("ATID3",DFN,"")) S:IBLT IBLT=9999999.9999999-IBLT\1
144 S:IBLT>DT IBLT=DT
145 ;
146 ; - get the last registration date and compare to last treatment date
147 S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X\1 S:X>IBLT IBLT=X
148 ;
149 ; - get the last appointment or stop after last treatment date (if any)
150 K ^TMP("DIERR",$J)
151 I '$G(IBQ) D
152 .D OPEN^SDQ(.IBQ) Q:'$G(IBQ)
153 .D INDEX^SDQ(.IBQ,"PATIENT/DATE","SET")
154 .D SCANCB^SDQ(.IBQ,"I $S($P(SDOE0,U,8)=2:1,$P(SDOE0,U,8)=1:$$APPT^IBATOP(SDOE0),1:0) S IBLT=SDOE0\1,SDSTOP=1","SET")
155 ;
156 D PAT^SDQ(.IBQ,DFN,"SET")
157 D DATE^SDQ(.IBQ,IBLT+.000001,9999999,"SET")
158 D ACTIVE^SDQ(.IBQ,"TRUE","SET")
159 D SCAN^SDQ(.IBQ,"BACKWARD")
160 D CLOSE^SDQ(.IBQ)
161 K ^TMP("DIERR",$J)
162 ;
163TXMTN ; - find next scheduled treatment date
164 S IBNEXT=""
165 S X=0 F S X=$O(^DGS(41.1,"B",DFN,X)) Q:'X D ; sched adm
166 .S X1=$G(^DGS(41.1,X,0))
167 .S X2=$P(X1,"^",2)\1
168 .Q:X2<DT ; must be old scheduled adm
169 .Q:$P(X1,"^",13) ; sched adm is cancelled
170 .Q:$P(X1,"^",17) ; patient already admitted
171 .I X2>IBNEXT S IBNEXT=X2
172 ;
173 Q IBLT_"^"_IBNEXT
174 ;
175APPT(SDOE0) ; Determine if appt associated with encounter is valid
176 Q $S($P(SDOE0,U,12)=2:1,$P(SDOE0,U,12)=14:1,1:0)
177 ;
178 ;
179PAUSE ; Page break
180 Q:$E(IOST,1,2)'="C-"
181 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
182 F IBX=$Y:1:(IOSL-3) W !
183 S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
184 Q
185 ;
186HDR(IBNET) ; Write the detail report header.
187 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
188 S IBPAG=IBPAG+1
189 W !,"Transfer Pricing Patient Listing",?38,"Run Date: ",IBRUN,?72,"Page: ",IBPAG
190 I $G(IBNET) W !,"Network: VISN ",IBNET
191 W !?50,"MT",?55,"Act",?63,"Last",?71,"Nxt Sched"
192 W !,"Patient Name/ID",?28,"Primary Eligibility",?49,"Stat"
193 W ?55,"Ins",?63,"Seen",?71,"Visit/Adm"
194 W !,$$DASH(IOM)
195 Q
196 ;
197DISFAC(X) ; Display the station number and name.
198 ; Input: X -- The Station Number
199 ; Variable input: IBFACN array
200 ;
201 W !!?4,"Home Facility: ",$P(IBFACN(X),"^",2)," ",$P(IBFACN(X),"^"),!
202 Q
203 ;
204DASH(X) ; Return a dashed line.
205 Q $TR($J("",X)," ","=")
Note: See TracBrowser for help on using the repository browser.