IB20P275 ;WOIFO/SS - POST INIT ROUTINE FOR IB*2*275 ;11-MAY-04
;;2.0;INTEGRATED BILLING;**275**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
POST ; adding charge removal reason entries if not there
N IBX,IBT,IBY,X,Y,DIC,DO
D ADDAUTO
D ADDCRR
Q
;
ADDAUTO ; need to add charge removal reasons
N IBX,IBT,IBY,DIC,Y,X
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
. S DIC="^IBE(354.2,",DIC(0)="",X=IBT,DIC("DR")=$P(IBY,";",2,5)
. D FILE^DICN I Y>0 D BMES^XPDUTL(" --> Added Exemption Reason File: "_IBT)
Q
ADDCRR ; add charge removal reasons
N IBX,IBT,IBY,DIC,Y,X
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
. S DIC="^IBE(350.3,",DIC(0)="",X=IBT,DIC("DR")=$P(IBY,";",2,3)
. D FILE^DICN I Y>0 D BMES^XPDUTL(" --> Added Charge Removal Reasons: "_IBT)
Q
;
;
AUTO ; Exemption Reasons to add in #354.2
;;FORMER POW;.02///Patient is a former Prisoner Of War;.03///COPAY INCOME EXEMPTION;.04///EXEMPT;.05///80
;;UNEMPLOYABLE VETERAN;.02///Patient is an unemployable veteran;.03///COPAY INCOME EXEMPTION;.04///EXEMPT;.05///90
;;
;
CRR ; charge removal reasons to add in #350.3
;;RX FOR FORMER POW;.02///POW;.03///RX
;;RX FOR UNEMPLOYABLE VETERAN;.02///UNEMPL;.03///RX
;;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P275 1385 printed Dec 13, 2024@02:02:03 Page 2
IB20P275 ;WOIFO/SS - POST INIT ROUTINE FOR IB*2*275 ;11-MAY-04
+1 ;;2.0;INTEGRATED BILLING;**275**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
POST ; adding charge removal reason entries if not there
+1 NEW IBX,IBT,IBY,X,Y,DIC,DO
+2 DO ADDAUTO
+3 DO ADDCRR
+4 QUIT
+5 ;
ADDAUTO ; need to add charge removal reasons
+1 NEW IBX,IBT,IBY,DIC,Y,X
+2 FOR IBX=1:1
SET IBY=$PIECE($TEXT(AUTO+IBX),";",3,99)
if IBY=""
QUIT
SET IBT=$PIECE(IBY,";")
IF '$ORDER(^IBE(354.2,"B",IBT,0))
KILL DO
Begin DoDot:1
+3 SET DIC="^IBE(354.2,"
SET DIC(0)=""
SET X=IBT
SET DIC("DR")=$PIECE(IBY,";",2,5)
+4 DO FILE^DICN
IF Y>0
DO BMES^XPDUTL(" --> Added Exemption Reason File: "_IBT)
End DoDot:1
+5 QUIT
ADDCRR ; add charge removal reasons
+1 NEW IBX,IBT,IBY,DIC,Y,X
+2 FOR IBX=1:1
SET IBY=$PIECE($TEXT(CRR+IBX),";",3,99)
if IBY=""
QUIT
SET IBT=$PIECE(IBY,";")
IF '$ORDER(^IBE(350.3,"B",IBT,0))
KILL DO
Begin DoDot:1
+3 SET DIC="^IBE(350.3,"
SET DIC(0)=""
SET X=IBT
SET DIC("DR")=$PIECE(IBY,";",2,3)
+4 DO FILE^DICN
IF Y>0
DO BMES^XPDUTL(" --> Added Charge Removal Reasons: "_IBT)
End DoDot:1
+5 QUIT
+6 ;
+7 ;
AUTO ; Exemption Reasons to add in #354.2
+1 ;;FORMER POW;.02///Patient is a former Prisoner Of War;.03///COPAY INCOME EXEMPTION;.04///EXEMPT;.05///80
+2 ;;UNEMPLOYABLE VETERAN;.02///Patient is an unemployable veteran;.03///COPAY INCOME EXEMPTION;.04///EXEMPT;.05///90
+3 ;;
+4 ;
CRR ; charge removal reasons to add in #350.3
+1 ;;RX FOR FORMER POW;.02///POW;.03///RX
+2 ;;RX FOR UNEMPLOYABLE VETERAN;.02///UNEMPL;.03///RX
+3 ;;
+4 ;
