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

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

initial load of WorldVistAEHR

File size: 5.0 KB
Line 
1IBCOMA1 ;ALB/CMS - IDENTIFY ACTIVE POLICIES W/NO EFFECTIVE DATE (CON'T); 08-03-98
2 ;;2.0;INTEGRATED BILLING;**103**;21-MAR-94
3 Q
4BEG ; Entry to run Active Policies w/no Effective Date Report
5 ; Input variables:
6 ; IBAIB - Required. How to sort
7 ; 1= Patient Name Range 2= Termianl Digit Range
8 ;
9 ; IBSIN - Required. Include Active Policies with
10 ; 1= Verification Date 2= No Verification Date 3= Both
11 ;
12 ; IBRF - Required. Name or Terminal Digit Range Start value
13 ; IBRL - Required. Name or Terminal Digit Range Go to value
14 ; IBBDT - Optional. Begining Verification Date Range
15 ; IBEDT - Optional. Ending Verification Date Range
16 ;
17 N DFN,IBC,IBC0,IBCDA,IBCDA0,IBCDA1,IBC11,IBC13,IBGP,IBI,IBPAGE,IBTMP
18 N IBQUIT,IBTD,IBX,VA,VADM,VAERR,X,Y
19 K ^TMP("IBCOMA",$J) S IBPAGE=0,IBQUIT=0
20 S IBC=0 F S IBC=$O(^DPT("AB",IBC)) Q:'IBC D
21 .S IBC0=$G(^DIC(36,IBC,0))
22 .;
23 .; If company inactive quit
24 .I $P(IBC0,U)="" Q
25 .I $P(IBC0,U,5)=1 Q
26 .S DFN=0 F S DFN=$O(^DPT("AB",IBC,DFN)) Q:'DFN D
27 ..K VA,VADM,VAERR,VAPA
28 ..D DEM^VADPT,ADD^VADPT
29 ..;
30 ..; I Pt. deceased quit I $G(VADM(6))>0 Q
31 ..; I Pt. name out of range quit
32 ..S VADM(1)=$P($G(VADM(1)),U,1) I VADM(1)="" Q
33 ..I IBAIB=1,VADM(1)]IBRL Q
34 ..I IBAIB=1,IBRF]VADM(1) Q
35 ..;
36 ..; I Terminal Digit out of range quit
37 ..I IBAIB=2 S IBTD=$$TERMDG^IBCONS2(DFN) S:IBTD="" IBTD="000000000" I (+IBTD>IBRL)!(IBRF>+IBTD) Q
38 ..S IBCDA=0 F S IBCDA=$O(^DPT("AB",IBC,DFN,IBCDA)) Q:'IBCDA D
39 ...S IBCDA0=$G(^DPT(DFN,.312,IBCDA,0))
40 ...;
41 ...; I Effective Date populated quit
42 ...I $P(IBCDA0,U,8) Q
43 ...;
44 ...; I Expiration Date entered and expired quit
45 ...I $P(IBCDA0,U,4),$P(IBCDA0,U,4)'>DT Q
46 ...;
47 ...; Sorting by verification date or no date check
48 ...S IBCDA1=$G(^DPT(DFN,.312,IBCDA,1))
49 ...I IBSIN=1,'$P(IBCDA1,U,3) Q
50 ...S $P(IBCDA1,U,3)=$P($P(IBCDA1,U,3),".",1)
51 ...I IBSIN=1,+$P(IBCDA1,U,3)>IBEDT Q
52 ...I IBSIN=1,+$P(IBCDA1,U,3)<IBBDT Q
53 ...I IBSIN=2,$P(IBCDA1,U,3) Q
54 ...I IBSIN=3 I +$P(IBCDA1,U,3)>0 I +$P(IBCDA1,U,3)<IBBDT!(+$P(IBCDA1,U,3)>IBEDT) Q
55 ...S IBC11=$G(^DIC(36,IBC,.11))
56 ...S IBC13=$G(^DIC(36,IBC,.13))
57 ...;
58 ...; set data line for global
59 ...;S IBTMP(1)=PT NAME^SSN^AGE^HOME PHONE^DATE OF DEATH
60 ...;S IBTMP(2)=INSURANCE NAME^REIMBURSE?^PHONE^ADD LINE 1
61 ...;S IBTMP(3)=GROUP PLAN^SUBSCRIBER ID^WHOSE INS.^VERIFICATION DATE
62 ...;
63 ...S IBGP=$P($G(^IBA(355.3,+$P(IBCDA0,U,18),0)),U,3)
64 ...S IBTMP(1)=VADM(1)_U_$P(VADM(2),U,2)_U_+VADM(4)_U_$P(VAPA(8),U,1)_U_$$FMTE^XLFDT($P(VADM(6),U,1),"5ZD")
65 ...S IBTMP(2)=$P(IBC0,U,1)_U_$P(IBC0,U,2)_U_$P(IBC13,U,1)_U_$P(IBC11,U,1)
66 ...S IBTMP(3)=$S(IBGP]"":IBGP,1:"(No Plan Name)")_U_$P(IBCDA0,U,2)_U_$P(IBCDA0,U,6)_U_$$FMTE^XLFDT($P(IBCDA1,U,3),"5ZD")
67 ...;
68 ...; set variable IBI for Verified=1 or Non verified=2
69 ...S IBI=$S(+$P(IBCDA1,U,3):1,1:2)
70 ...;
71 ...; Set Global array
72 ...S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN)=IBTMP(1)
73 ...S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC)=IBTMP(2)
74 ...S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC,IBCDA)=IBTMP(3)
75 ...;
76 ;
77 I '$D(^TMP("IBCOMA",$J)) D HD W !!,"** NO RECORDS FOUND **" G QUEQ
78 D WRT
79 ;
80QUEQ ; Exit clean-UP
81 W ! D ^%ZISC K IBTMP,IBAIB,IBRF,IBRL,IBSIN,IBSTR,VA,VAERR,VADM,VAPA,^TMP("IBCOMA",$J)
82 Q
83 ;
84HD ;Write Heading
85 S IBPAGE=IBPAGE+1
86 W @IOF,"Active Policies with no Effective Date Report ",$$FMTE^XLFDT($$NOW^XLFDT,"Z")," Page: ",IBPAGE
87 W !,?5,"Sorted by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
88 W !,?5," Include: "_$S(IBSIN=1:"Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z"),IBSIN=2:"No Verification Date Entered",1:"with or without Verification Date")
89 W !!,"Patient Name",?32,"SSN",?44,"Age",?50,"Phone",?66,"Date of Death"
90 W ! F IBX=1:1:79 W "="
91 Q
92 ;
93WRT ;Write data lines
94 N IBA,IBCDA,IBDA,IBDFN,IBINS,IBNA,IBPOL,IBPT,X,Y S IBQUIT=0
95 S IBA=0 F S IBA=$O(^TMP("IBCOMA",$J,IBA)) Q:('IBA)!(IBQUIT=1) D
96 .I IBPAGE D ASK^IBCOMC2 I IBQUIT=1 Q
97 .D HD W !,$S(IBA=1:"Verified",1:"Non-Verified")
98 .S IBNA="" F S IBNA=$O(^TMP("IBCOMA",$J,IBA,IBNA)) Q:(IBNA="")!(IBQUIT=1) D
99 ..S IBDFN=0 F S IBDFN=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN)) Q:('IBDFN)!(IBQUIT=1) D
100 ...S IBPT=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN))
101 ...;
102 ...I ($Y+6)>IOSL D I IBQUIT=1 Q
103 ....D ASK^IBCOMC2 I IBQUIT=1 Q
104 ....D HD
105 ...;
106 ...W !!,$E($P(IBPT,U,1),1,30),?32,$E($P(IBPT,U,2),1,12),?44,$J($P(IBPT,U,3),3),?50,$E($P(IBPT,U,4),1,20),?70,$P(IBPT,U,5)
107 ...;
108 ...S IBDA=0 F S IBDA=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA)) Q:('IBDA)!(IBQUIT=1) D
109 ....S IBINS=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA))
110 ....W !?3,$E($P(IBINS,U,1),1,30),?35,"Reimb VA? ",$P(IBINS,U,2),?50,$E($P(IBINS,U,3),1,20) ; ?70,$E($P(IBINS,U,4),1,10)
111 ....;
112 ....S IBCDA=0 F S IBCDA=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA,IBCDA)) Q:('IBCDA)!(IBQUIT=1) D
113 .....S IBPOL=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA,IBCDA))
114 .....W !?5,$E($P(IBPOL,U,1),1,20),?26,"Sub ID: ",$E($P(IBPOL,U,2),1,20),?55,"Whose: ",$P(IBPOL,U,3)
115 .....I IBA=1 W ?64,"Verif:",$P(IBPOL,U,4)
116 Q
117 ;IBCOMA1
Note: See TracBrowser for help on using the repository browser.