source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IB20P276.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: 6.1 KB
Line 
1IB20P276 ;DALOI/AAT - POST INIT ACTION ;24-JUN-2003
2 ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6 ; Post Init Description: This init will resolve the pointer issues
7 ; for the new entries required in 350.2 and the update need in
8 ; file 399.1. This post init is associated with path *132*.
9 ;
10 Q
11 ;
12 ;
13EN ;
14 D BMES^XPDUTL(">>> Adding/modifying CLAIMS TRACKING NON-BILLABLE REASONS in the file #356.8")
15 D NEWNBR
16 ;
17 ;Temporary:
18 D BMES^XPDUTL(">>> Correcting the BPS CLAIM file, field #900 'CLOSE REASON'")
19 D BPSFIX
20 D BMES^XPDUTL(">>> Correcting 'CLOSE REASON' in the temporary IB events log")
21 D LOGFIX
22 ;
23 D BMES^XPDUTL(">>> Enable menu option 'IBCNR EDIT HIPAA NCPDP FLAG'")
24 D OPT
25 ;
26 D BMES^XPDUTL(">>> Reviewing and correcting the PLAN file entries")
27 D ^IBCNRXI1
28 ;
29 D BMES^XPDUTL(">>> All POST-INIT Activities have been completed. <<<")
30 Q
31 ;
32NEWNBR ; Add/Modify IB non-billable reasons #356.8
33 N IBI,IBY,IBMES
34 F IBI=1:1 S IBY=$P($T(REASONS+IBI),";;",2,255) Q:'IBY D
35 . N IBNAME,IBE02,IBE03,IBL,IBIEN
36 . S IBNAME=$P(IBY,U,2) Q:IBNAME=""
37 . S IBE02=$P(IBY,U,3)
38 . S IBE03=$P(IBY,U,4)
39 . S $E(IBL,33-$L(IBNAME))=" "
40 . S IBMES=" "_$J(IBI,2)_" "_IBNAME_IBL
41 . S IBIEN=$O(^IBE(356.8,"B",IBNAME,0))
42 . S:IBIEN="" IBIEN=0
43 . S:$G(^IBE(356.8,IBIEN,0))="" IBIEN=0
44 . I IBIEN S IBMES=IBMES_" Already on file"
45 . I 'IBIEN D
46 .. N IBRT,IBIEN,IBERR,IBCNT
47 .. S IBCNT=0
48 .. S IBRT(356.8,"+1,",.01)=IBNAME
49 .. S IBRT(356.8,"+1,",.02)=IBE02
50 .. S IBRT(356.8,"+1,",.03)=IBE03
51 .. D UPDATE^DIE("","IBRT","IBIEN","IBERR")
52 .. I $D(IBERR) D S IBCNT=IBCNT+1
53 ... N Y S Y="" F S Y=$O(IBERR(Y)) Q:Y="" D
54 .... S IBMES=IBMES_" *** Error: "_$G(IBERR(Y,1,"TEXT",1))
55 . I IBIEN D
56 .. S $P(^IBE(356.8,IBIEN,0),U,2)=IBE02
57 .. S $P(^IBE(356.8,IBIEN,0),U,3)=IBE03
58 . D MES^XPDUTL(IBMES)
59 Q
60 ;
61 ;
62OPT ; Enable the menu option "IBCNR EDIT HIPAA NCPDP FLAG"
63 N IEN,IBRT,IBERR
64 S IEN=$O(^DIC(19,"B","IBCNR EDIT HIPAA NCPDP FLAG",""))
65 I 'IEN D BMES^XPDUTL(" *** Error: option 'IBCNR EDIT HIPAA NCPDP FLAG' not found") Q
66 S IBRT(19,IEN_",",2)="@"
67 D FILE^DIE("E","IBRT","IBERR")
68 I $D(IBERR) D
69 . N Y S Y="" F S Y=$O(IBERR(Y)) Q:Y="" D
70 .. D BMES^XPDUTL(" *** Error: "_$G(IBERR(Y,1,"TEXT",1)))
71 Q
72 ;
73 ;
74 ; *** Not implemented ***
75ADDUSR ; Add the user to the New Person file (#200)
76 Q
77 N DIC,X,Y,DO,DD,DLAYGO,IBNAME
78 S IBNAME="E-PHARMACY"
79 S DIC(0)="",DIC="^VA(200,",X=IBNAME D ^DIC
80 I Y>0 D Q
81 . D BMES^XPDUTL("User "_IBNAME_" already exists in the NEW PERSON file - not added")
82 D BMES^XPDUTL("Adding new user, "_IBNAME_", to the NEW PERSON file")
83 S DLAYGO=200,DIC(0)="L",DIC="^VA(200,",DIC("DR")="1////MRA",X=IBNAME D FILE^DICN K DIC,DO,DD,DLAYGO
84 I Y'>0 D Q
85 . D BMES^XPDUTL("A problem was encountered trying to add user, "_IBNAME)
86 . D BMES^XPDUTL("The entry must be added manually to the NEW PERSON file")
87 ;
88 D BMES^XPDUTL("User, "_IBNAME_", was successfully added to the NEW PERSON file")
89 Q
90 ;
91 ;Temporary Clean-up procedure to eliminate QTY-DAYS SUPPLY switching
92VERIFY(IBIFN,IBRX,IBFIL) ;check and correct
93 N IBX,QTY,DSUPP,IBZ,IBRXZ
94 S IBRXZ=$G(^PSRX(IBRX,1,IBFIL,0)) Q:IBRXZ=""
95 S QTY=+$P(IBRXZ,U,4) Q:'QTY Q:QTY>999
96 S DSUPP=+$P(IBRXZ,U,10) Q:'DSUPP Q:DSUPP>90
97 ;
98 S IBX=0 F S IBX=$O(^IBA(362.4,"C",IBIFN,IBX)) Q:'IBX D
99 . ;W !,IBIFN,?10," ",IBRX,?22," ",IBFIL
100 . S IBZ=$G(^IBA(362.4,IBX,0)) Q:IBZ=""
101 . I QTY=+$P(IBZ,U,7),DSUPP=+$P(IBZ,U,6) Q
102 . ;W " *** INCORRECT: QTY/DAYS=",+$P(IBZ,U,7),"/",+$P(IBZ,U,6),", MUST BE ",QTY,"/",DSUPP
103 . D SETQTY(IBX,QTY,DSUPP)
104 Q
105SETQTY(IBX,QTY,DSUPP) ;
106 N IBRT,IBERR
107 S IBRT(362.4,IBX_",",.06)=DSUPP
108 S IBRT(362.4,IBX_",",.07)=QTY
109 D FILE^DIE("","IBRT","IBERR")
110 ;I $D(IBERR) W ! ZW IBERR
111 Q
112 ;
113 ;
114GETRX(IBIFN) ;Get Rx from 362.4
115 N IBX,IBRX,IBRXN
116 S IBRX=0
117 S IBX=+$O(^IBA(362.4,"C",+IBIFN,""))
118 S IBRXN=$P($G(^IBA(362.4,IBX,0)),U)
119 I IBRXN'="" S IBRX=+$O(^PSRX("B",IBRXN,0))
120 Q IBRX
121 ;
122BULL ; Generate a bulletin with modified bills.
123 N IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
124 ;
125 S XMSUB="FIXING 'CANCELLATION' IN NCPDP ZERO BILLS"
126 S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP("_$J_",""IB20P276"","
127 S XMY(DUZ)=""
128 S XMY("G.PRCA ERROR")=""
129 D ^XMD
130 Q
131 ;
132 ;
133SETSTA(IBIFN) ; set the status
134 N IBIENS,IBFDA,IBERR
135 S IBIENS=IBIFN_","
136 S IBFDA(430,IBIENS,8)="COLLECTED/CLOSED"
137 D FILE^DIE("E","IBFDA","IBERR")
138 Q '$D(IBERR)
139 ;
140BPSFIX ;CONVERT OLD BPS CODES
141 N I,IBZ,IBY,IBC,IBOTH,IBT,ZNODE
142 S ZNODE="BPSIB-CONVERT-9002313.02-904"
143 I $D(^XTMP(ZNODE,0)) D MES^XPDUTL("*** Already converted") Q
144 F I=1:1 S IBY=$P($T(REASONS+I),";;",2,255) Q:'IBY S IBC(+IBY)=$O(^IBE(356.8,"B",$P(IBY,U,2),0))
145 S IBOTH=$O(^IBE(356.8,"B","OTHER",0))
146 S I=0 F S I=$O(^BPSC(I)) Q:'I S IBZ=$G(^(I,0)) D:$P(IBZ,U,7)=""
147 . N IBOLD,IBNEW
148 . S IBOLD=$P($G(^BPSC(I,900)),U,4) Q:IBOLD=""
149 . S IBNEW=+$G(IBC(IBOLD)) S:'IBNEW IBNEW=IBOTH
150 . ;W !,"I=",I,?10,"CODE=",IBOLD,", NEW=",IBNEW
151 . S $P(^BPSC(I,900),U,4)=IBNEW
152 . S $P(^BPSC(I,0),U,7)=0 ; as a flag to avoid double conversion
153 S ^XTMP(ZNODE,0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"BPS CONVERSION FLAG"
154 Q
155 ;
156LOGFIX ;CONVERT CLOSE REASON IN THE IB LOG
157 N I,J,IBNODE,IBZ,IBY,IBC,IBOTH,IBT,IBDROP
158 F I=1:1 S IBY=$P($T(REASONS+I),";;",2,255) Q:'IBY S IBC(+IBY)=$O(^IBE(356.8,"B",$P(IBY,U,2),0))
159 S IBOTH=$O(^IBE(356.8,"B","OTHER",0))
160 ;
161 S (I,IBNODE)="IBNCPDP-"
162 F S I=$O(^XTMP(I)) Q:I'[IBNODE D
163 . S J=0 F S J=$O(^XTMP(I,J)) Q:'J D
164 .. I '$D(^XTMP(I,J,"IBD","CLOSE REASON")) Q
165 .. I $D(^XTMP(I,J,"IBD","DROP TO PAPER")) Q ; Already converted
166 .. N IBOLD,IBNEW
167 .. S IBOLD=$G(^XTMP(I,J,"IBD","CLOSE REASON")) Q:IBOLD=""
168 .. S IBNEW=+$G(IBC(IBOLD)) S:'IBNEW IBNEW=IBOTH
169 .. ;W !,"I=",I,", J=",J,",",?15,"CODE=",IBOLD,", NEW=",IBNEW
170 .. S ^XTMP(I,J,"IBD","CLOSE REASON")=IBNEW
171 .. S ^XTMP(I,J,"IBD","DROP TO PAPER")=(IBOLD=1) ;flag to avoid double conversion
172 Q
173 ;
174REASONS ;CLOSE REASON to add/modify into file #356.8
175 ;;2^NOT INSURED^1^0
176 ;;3^SERVICE NOT COVERED^1^0
177 ;;4^COVERAGE CANCELED^1^0
178 ;;6^INVALID PRESCRIPTION ENTRY^1^0
179 ;;7^PRESCRIPTION DELETED^1^0
180 ;;8^PRESCRIPTION NOT RELEASED^1^0
181 ;;5^DRUG NOT BILLABLE^1^0
182 ;;10^90 DAY RX FILL NOT COVERED^1^1
183 ;;11^NOT A CONTRACTED PROVIDER^1^1
184 ;;12^INVALID MULTIPLES PER DAY SUPP^1^0
185 ;;13^REFILL TOO SOON^1^0
186 ;;9^INVALID NDC FROM CMOP^1^0
187 ;;1^OTHER^1^1
188 ;;
Note: See TracBrowser for help on using the repository browser.