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

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
2 ;;2.0;INTEGRATED BILLING;**13,260,312,339,389**;21-MAR-94;Build 6
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5% ; -- entry point for nightly background job
6 N IBTSBDT,IBTSEDT
7 S IBTSBDT=$$FMADD^XLFDT(DT,-30)-.1
8 S IBTSEDT=$$FMADD^XLFDT(DT,-3)+.9
9 D EN1
10 Q
11 ;
12EN ; -- entry point to ask date range
13 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
14 N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK
15 S IBTALK=1
16 I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prosthetics is currently turned off." G ENQ
17 W !!!,"Select the Date Range of Prosthetics to Add to Claims Tracking.",!
18 D DATE^IBOUTL
19 I IBBDT<1!(IBEDT<1) G ENQ
20 S IBTSBDT=IBBDT,IBTSEDT=IBEDT
21 ;
22 ; -- check selected dates ;IB*2.0*312
23 ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt ;CCR-930
24 I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D G EN
25 .W !!,"The Begin OR End Date CANNOT be on or after the PFSS Effective date"
26 .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
27 ;
28 S IBTRKR=$G(^IBE(350.9,1,6))
29 ; start date can't be before parameters
30 I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
31 ; -- end date into future
32 I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
33 ;
34 W !!!,"I'm going to automatically queue this off and send you a"
35 W !,"mail message when complete.",!
36 S ZTIO="",ZTRTN="EN1^IBTRKR5",ZTSAVE("IB*")="",ZTDESC="IB - Add Prosthetics to Claims Tracking"
37 D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued"
38ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
39 D HOME^%ZIS
40 Q
41 ;
42EN1 ; -- add prostethics to claims tracking file
43 N I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS
44 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
45 ;
46 ; -- check parameters
47 S IBTRKR=$G(^IBE(350.9,1,6))
48 G:'$P(IBTRKR,"^",5) EN1Q ; quit if prothetics tracking off
49 I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters
50 ;
51 ; -- users can queue into future, make sure dates not after date run
52 I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3)
53 ;
54 ;S IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics
55 ;
56 ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
57 S (IBCNT,IBCNT1,IBCNT2)=0
58 S (IBDTS,IBDT)=IBTSBDT-.0001
59 ;
60 ; loop twice, once for shipmnet date (new search), and once for
61 ; delivery date (old search) for backward compatibility.
62 F S IBDT=$O(^RMPR(660,"AF",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D
63 .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930
64 .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312
65 .S IBDA=0 F S IBDA=$O(^RMPR(660,"AF",IBDT,IBDA)) Q:'IBDA D PRCHK
66 ;
67 ; reset date and do old check
68 S IBDT=IBDTS
69 F S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D
70 .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930
71 .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312
72 .S IBDA="" F S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA D PRCHK
73 ;
74 I $G(IBTALK) D BULL ;^IBTRKR51
75EN1Q I $D(ZTQUEUED) S ZTREQ="@"
76 Q
77 ;
78PRCHK ; -- check and add item
79 N IBE,IBP,IBDX,IBRMARK,IBARR,IBT
80 S IBCNT=IBCNT+1,IBRMARK=""
81 I '$D(ZTQUEUED),($G(IBTALK)) W "."
82 ;
83 S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
84 S DFN=$P(IBDATA,"^",2) Q:'DFN
85 D CL^SDCO21(DFN,IBDT,"",.IBARR)
86 ;
87 ; -- checks copied from rmprbil v2.0 /feb 2, 1994
88 Q:'$D(^RMPR(660,+IBDA,"AM"))
89 Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
90 ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
91 ;
92 ;
93 I $O(^IBT(356,"APRO",IBDA,0)) G PRCHKQ ; already in claims tracking
94 ;
95 ; -- see if tracking only insured and pt is insured
96 I $P(IBTRKR,"^",5)=1,'$$INSURED^IBCNS1(DFN,IBDT) G PRCHKQ ; patient not insure
97 ;
98 ; -- if clasifications required, check exemptions
99 I '$D(IBARR) G CLQ
100 S IBE=0 F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) I IBDX(IBP) S IBE=1
101 I 'IBE S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status
102 S IBE=0 F S IBE=$O(IBARR(IBE)) Q:'IBE!($L($G(IBRMARK))) F IBP=1:1:4 Q:$L($G(IBRMARK)) I IBDX(IBP) S IBRMARK=$S($P(IBDX(IBP),"^",IBE+1):$P($T(CLTXT+IBE),";",3),$P(IBDX(IBP),"^",IBE+1)=0:"",1:"NEEDS SC DETERMINATION")
103 ;
104 ;
105CLQ ; -- ok to add to tracking module
106 D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
107 I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
108 I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
109 K VAEL,VA,IBDATA,DFN,X,Y
110PRCHKQ Q
111 ;
112BULL ; -- send bulletin
113 ;
114 S XMSUB="Prosthetic Items added to Claims Tracking Complete"
115 S IBT(1)="The process to automatically add Prosthetic Items has successfully completed."
116 S IBT(1.1)=""
117 S IBT(2)=" Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
118 S IBT(3)=" End Date: "_$$DAT1^IBOUTL(IBTSEDT)
119 I $D(IBMESS) S IBT(3.1)=IBMESS
120 S IBT(4)=""
121 S IBT(5)=" Total Prosthetics Items checked: "_$G(IBCNT)
122 S IBT(6)="Total NSC Prosthetic Items Added: "_$G(IBCNT1)
123 S IBT(7)=" Total SC Prosthetic Items Added: "_$G(IBCNT2)
124 S IBT(8)=""
125 S IBT(9)="*The items added as SC require determination and editing to be billed"
126 D SEND^IBTRKR31
127BULLQ Q
128 ;
129CLTXT ; classification text for reason not billable
130 ;;AGENT ORANGE
131 ;;IONIZING RADIATION
132 ;;SC TREATMENT
133 ;;SOUTHWEST ASIA
134 ;;MILITARY SEXUAL TRAUMA
135 ;;HEAD/NECK CANCER
136 ;;COMBAT VETERAN
Note: See TracBrowser for help on using the repository browser.