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

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

initial load of WorldVistAEHR

File size: 5.7 KB
RevLine 
[613]1IB20P336 ;OAK/ELZ - IB*2*336 POST INIT TO REPORT CLAIMS TRACKING PROBLEMS ;15-DEC-2005
2 ;;2.0;INTEGRATED BILLING;**336**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; With the release of CIDC (IB*2*260), PSO added a new node for storage of SC/EI determinations. However it turns
6 ; out this new node is not always there. If the node is there the data contained in that node is correct for SC/EI
7 ; determination. But if the node was not there IB needed to revert back to its original process for marking CT
8 ; entries. That reversion was not included in IB*2*260, but is included in this IB*2*336 patch. This post init
9 ; routine will look through CT entries for Pharmacy that were created after IB*2*260 was installed and evaluate
10 ; those CT entries. Since some sites spend time manually reviewing these entries the entries cannot be auto-
11 ; matically marked and bills cannot be automatically cancelled. So this post init routine will provide an e-mail
12 ; report of CT entries that should be reviewed by the site. Also as a note the PSO IBQ node is not a reliable
13 ; node to look at for patients >49% SC, in fact should not ever be populated for these patients. So if anyone
14 ; does a comparison they are likely to find invalid data. PSO stopped populating IBQ for >49% SC with the
15 ; release of PSO*7*219.
16 ;
17 ;
18POST ; post init entry point
19 ;
20 N IBIDT,IBX,IBSTOP,IBDATA,IBDPT,IBL,IBPNM,IBZ,XMDUZ,XMSUB,XMY,XMZ
21 ;
22 D BMES^XPDUTL("Starting Post Install to evaluate CT entries...")
23 ;
24 K ^TMP("IB20P336",$J)
25 ;
26 ; dbia #2197
27 S IBIDT=$P($G(^XPD(9.7,+$O(^XPD(9.7,"B","IB*2.0*260",0)),1)),"^")
28 I 'IBIDT D BMES^XPDUTL("Cannot find first install of IB*2*260!!! LOG A REMEDY TICKET") Q
29 ;
30 ; start at end of CT file and work backwards to beginning
31 S IBSTOP=0,IBX=":" F S IBX=$O(^IBT(356,IBX),-1) Q:'IBX!(IBSTOP) D
32 . S IBZ=$G(^IBT(356,IBX,0))
33 . Q:'$P(IBZ,"^",8)
34 . ;
35 . ; can i end?
36 . S IBDT=+$G(^IBT(356,IBX,1)) I IBDT,IBDT<IBIDT S IBSTOP=1 Q
37 . ;
38 . ; entry has a RNB no need to check out
39 . Q:$P(IBZ,"^",19)
40 . ;
41 . ; PSO has an ICD node so it was done right
42 . Q:$D(^PSRX($P(IBZ,"^",8),"ICD"))
43 . ;
44 . ;determine RNB would have been had CIDC not been installed, if none quit
45 . S IBRMARK=$$RNB($P(IBZ,"^",2),$P(IBZ,"^",6),$P(IBZ,"^",8),$G(^PSRX($P(IBZ,"^",8),0)))
46 . I IBRMARK="" Q
47 . ;
48 . S IBDPT=$G(^DPT(+$P(IBZ,"^",2),0)) Q:'$L(IBDPT)
49 . S IBDATA=$$TXT($P(IBDPT,"^"),15)_$$TXT($E($P(IBDPT,"^",9),6,9),4)
50 . S IBDATA=IBDATA_$$TXT($$FMTE^XLFDT($P(IBZ,"^",6),"2DZ"),8)_$$TXT($P($G(^PSRX($P(IBZ,"^",8),0)),"^"),10)
51 . S IBDATA=IBDATA_$$TXT($P($G(^DGCR(399,+$P(IBZ,"^",11),0)),"^"),10)_$$TXT(IBRMARK,14)
52 . ;
53 . ; get AR status
54 . S:$P(IBZ,"^",11) IBDATA=IBDATA_$E($P($$STA^PRCAFN(+$P(IBZ,"^",11)),"^",2),1,4)
55 . ;
56 . S ^TMP("IB20P336",$J,$P(IBDPT,"^"),IBX)=IBDATA
57 ;
58 D BMES^XPDUTL("Sending report message...")
59 ;
60 ; get message and send
61RETRY ;
62 S XMSUB="CLAIMS TRACKING PHARMACY IB*2*336"
63 S XMDUZ="INTEGRATED BILLING PACKAGE"
64 D XMZ^XMA2
65 I XMZ<1 G RETRY
66 ;
67 ;set priority on message
68 S DIE=3.9,DA=XMZ,DR="1.7////P" D ^DIE
69 ;
70 S ^XMB(3.9,XMZ,2,1,0)="With the install of the CIDC software (IB*2*260) some pharmacy related"
71 S ^XMB(3.9,XMZ,2,2,0)="Claims Tracking (CT) entries may not have been assigned a Reason Not"
72 S ^XMB(3.9,XMZ,2,3,0)="Billable (RNB). Below is a list of CT entries that do not have a RNB"
73 S ^XMB(3.9,XMZ,2,4,0)="with a RNB that should have been originally assigned to them. Please"
74 S ^XMB(3.9,XMZ,2,5,0)="review the list below and assign a RNB if appropriate."
75 S ^XMB(3.9,XMZ,2,6,0)=" "
76 S ^XMB(3.9,XMZ,2,7,0)="Name SSN Date Rx# Bill# RNB AR"
77 S ^XMB(3.9,XMZ,2,8,0)="--------------- ---- -------- ---------- ---------- -------------- ----"
78 S IBL=8
79 S IBPNM="" F S IBPNM=$O(^TMP("IB20P336",$J,IBPNM)) Q:IBPNM="" S IBX=0 F S IBX=$O(^TMP("IB20P336",$J,IBPNM,IBX)) Q:'IBX D
80 . S IBL=IBL+1
81 . S ^XMB(3.9,XMZ,2,IBL,0)=^TMP("IB20P336",$J,IBPNM,IBX)
82 I '$D(^TMP("IB20P336",$J)) S ^XMB(3.9,XMZ,2,IBL+1,0)=" <None Found>"
83 S ^XMB(3.9,XMZ,2,0)="^3.92^"_IBL_"^"_IBL_"^"_DT
84 ;
85 S XMDUZ="INTEGRATED BILLING PACKAGE"
86 S XMY(DUZ)="" ; Individual as a recipient
87 F IBX="IB SUPERVISOR","IB CLAIMS SUPERVISOR" S IBZ=0 F S IBZ=$O(^XUSEC(IBX,IBZ)) Q:'IBZ S XMY(IBZ)=""
88 ;
89 D ENT1^XMD
90 ;
91 D BMES^XPDUTL("Message number "_XMZ_" sent...")
92 ;
93 K ^TMP("IB20P336",$J)
94 ;
95 D BMES^XPDUTL("Post Install Complete...")
96 ;
97 Q
98 ;
99 ;
100RNB(DFN,IBDT,IBRXN,IBRXDATA) ; determines what the RNB would have been had the new ICD node not been checked
101 ;
102 N VAEL,IBRMARK,VA,IBPOWUNV,IBAUTRET
103 ;
104 D ELIG^VADPT
105 ;if the patient is covered by insurance for pharmacy ($G(IBRMARK)="")
106 ;AND if no copay in #350
107 ;then we need to determine the non billable reason and set IBRMARK
108 ;
109 ;IF VAEL(3) -- if this is a veteran with SC(service connection) status
110 I VAEL(3),'$G(^PSRX(IBRXN,"IB")) D
111 . I $P(VAEL(3),"^",2)>49 S IBRMARK="NEEDS SC DETERMINATION"
112 . ;in case of POW and Unempl. vet we cannot decide if the 3rd party should be exempt
113 . S IBAUTRET=$$AUTOINFO^DGMTCOU1(DFN),IBPOWUNV=$S($P(IBAUTRET,U,8):1,$P(IBAUTRET,U,9):1,1:0)
114 . I $P(VAEL(3),"^",2)<50 S IBRMARK=$S(IBPOWUNV:"NEEDS SC DETERMINATION",1:"SC TREATMENT")
115 . I $$RXST^IBARXEU(DFN,$P(IBRXDATA,U,13))>0 S IBRMARK="NEEDS SC DETERMINATION"
116 ;
117 ;IF +VAEL(3)=0 if the veteran doesn't have SC status, but
118 ;the veteran still may have CV status active
119 I $G(IBRMARK)="",+VAEL(3)=0,'$G(^PSRX(IBRXN,"IB")) D
120 . I $$CVEDT^IBACV(DFN,IBDT) S IBRMARK="NEEDS SC DETERMINATION" ;SC-because IB staff usually is using this reason to search for cases that need to be reviewed. COMBAT VETERAN reason will be used after review if this was the case
121 ;
122 ;
123 Q $G(IBRMARK)
124 ;
125 ;
126TXT(X,Y) ; make text Y characters long adding 2 spaces
127 Q $$LJ^XLFSTR($E(X,1,Y),Y+2)
128 ;
Note: See TracBrowser for help on using the repository browser.