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

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

initial load of WorldVistAEHR

File size: 1.3 KB
Line 
1IB20P275 ;WOIFO/SS - POST INIT ROUTINE FOR IB*2*275 ;11-MAY-04
2 ;;2.0;INTEGRATED BILLING;**275**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6POST ; adding charge removal reason entries if not there
7 N IBX,IBT,IBY,X,Y,DIC,DO
8 D ADDAUTO
9 D ADDCRR
10 Q
11 ;
12ADDAUTO ; need to add charge removal reasons
13 N IBX,IBT,IBY,DIC,Y,X
14 F IBX=1:1 S IBY=$P($T(AUTO+IBX),";",3,99) Q:IBY="" S IBT=$P(IBY,";") I '$O(^IBE(354.2,"B",IBT,0)) K DO D
15 . S DIC="^IBE(354.2,",DIC(0)="",X=IBT,DIC("DR")=$P(IBY,";",2,5)
16 . D FILE^DICN I Y>0 D BMES^XPDUTL(" --> Added Exemption Reason File: "_IBT)
17 Q
18ADDCRR ; add charge removal reasons
19 N IBX,IBT,IBY,DIC,Y,X
20 F IBX=1:1 S IBY=$P($T(CRR+IBX),";",3,99) Q:IBY="" S IBT=$P(IBY,";") I '$O(^IBE(350.3,"B",IBT,0)) K DO D
21 . S DIC="^IBE(350.3,",DIC(0)="",X=IBT,DIC("DR")=$P(IBY,";",2,3)
22 . D FILE^DICN I Y>0 D BMES^XPDUTL(" --> Added Charge Removal Reasons: "_IBT)
23 Q
24 ;
25 ;
26AUTO ; Exemption Reasons to add in #354.2
27 ;;FORMER POW;.02///Patient is a former Prisoner Of War;.03///COPAY INCOME EXEMPTION;.04///EXEMPT;.05///80
28 ;;UNEMPLOYABLE VETERAN;.02///Patient is an unemployable veteran;.03///COPAY INCOME EXEMPTION;.04///EXEMPT;.05///90
29 ;;
30 ;
31CRR ; charge removal reasons to add in #350.3
32 ;;RX FOR FORMER POW;.02///POW;.03///RX
33 ;;RX FOR UNEMPLOYABLE VETERAN;.02///UNEMPL;.03///RX
34 ;;
35 ;
Note: See TracBrowser for help on using the repository browser.