IBY399P ;ALB/ARH - IB*2*399 POST-INSTALL ; 2/27/09
;;2.0;INTEGRATED BILLING;**399**;21-MAR-94;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
POST ;
N IBA S IBA="IB*2*399 Post-Install .....",IBA(3)="" D MSG(IBA) K IBA
;
D RIDER ; add LTC rider (#355.6)
D CV ; add LTC coverage (#355.31)
;
D FTF^IBY399P3 ; add and convert FTFs (#355.13)
;
D RNB^IBY399P1 ; add and update RNBs (#356.8)
;
D XREF ; index new AE xref (#362.5,.04)
;
S IBA="IB*2*399 Post-Install Complete",IBA(3)="" D MSG(IBA) K IBA
Q
;
;
RIDER ; add LONG TERM CARE Insurance Rider (#355.6)
N IBA,IBNAME,DD,DO,DLAYGO,DIC,X,Y,IBDA,IBARR,IBX
;
S IBNAME="LONG TERM CARE COVERAGE"
I $O(^IBE(355.6,"B",IBNAME,0)) S IBA=">> "_IBNAME_" Insurance Rider (355.6) exists, no change" D MSG(IBA) Q
;
K DD,DO S DLAYGO=355.6,DIC="^IBE(355.6,",DIC(0)="L",X=IBNAME D FILE^DICN K DIC S IBDA=+Y I Y<1 K X,Y Q
;
S IBA=">> "_IBNAME_" Insurance Rider (#355.6) added" D MSG(IBA)
Q
;
;
CV ; add LONG TERM CARE Coverage (#355.31)
N IBA,IBNAME,IBRIDER,IBRDA,IBX,DD,DO,DLAYGO,DIC,X,Y,IBDA,DIE,DA,DR,IBFILE
S IBFILE=" Plan Limitation Category (#355.31) "
;
S IBNAME="LONG TERM CARE",IBRIDER="LONG TERM CARE COVERAGE"
S IBRDA=$O(^IBE(355.6,"B",IBRIDER,0)) I 'IBRDA S IBA="=> "_IBNAME_IBFILE_"Not Added, Rider Missing" D MSG(IBA) Q
;
I $O(^IBE(355.31,"B",IBNAME,0)) S IBA=">> "_IBNAME_IBFILE_"exists, no change" D MSG(IBA) Q
;
K DD,DO S DLAYGO=355.31,DIC="^IBE(355.31,",DIC(0)="L",X=IBNAME D FILE^DICN K DIC S IBDA=+Y I Y<1 K X,Y Q
;
S DIE="^IBE(355.31,",DA=+IBDA,DR=".02////Long Term Care coverage;.03////"_IBRDA D ^DIE K DIE,DA,DR,X,Y
;
S IBA=">> "_IBNAME_IBFILE_"added" D MSG(IBA)
;
Q
;
XREF ; re-index new AE cross reference on IB BILL/CLAIMS PROSTHETICS (#362.5), RECORD (.04)
N DIK,DIC,X,Y D MSG(">> Indexing new 'AE' xref IB BILL/CLAIMS PROSTHETICS, RECORD (#362.5,.04)")
S DIK="^IBA(362.5,",DIK(1)=".04^AE" D ENALL^DIK
Q
;
MSG(IBA) ;
N IBM S IBM(1)=" ",IBM(2)=" "_$G(IBA)
D MES^XPDUTL(.IBM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY399P 2091 printed Oct 16, 2024@18:34:34 Page 2
IBY399P ;ALB/ARH - IB*2*399 POST-INSTALL ; 2/27/09
+1 ;;2.0;INTEGRATED BILLING;**399**;21-MAR-94;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
POST ;
+1 NEW IBA
SET IBA="IB*2*399 Post-Install ....."
SET IBA(3)=""
DO MSG(IBA)
KILL IBA
+2 ;
+3 ; add LTC rider (#355.6)
DO RIDER
+4 ; add LTC coverage (#355.31)
DO CV
+5 ;
+6 ; add and convert FTFs (#355.13)
DO FTF^IBY399P3
+7 ;
+8 ; add and update RNBs (#356.8)
DO RNB^IBY399P1
+9 ;
+10 ; index new AE xref (#362.5,.04)
DO XREF
+11 ;
+12 SET IBA="IB*2*399 Post-Install Complete"
SET IBA(3)=""
DO MSG(IBA)
KILL IBA
+13 QUIT
+14 ;
+15 ;
RIDER ; add LONG TERM CARE Insurance Rider (#355.6)
+1 NEW IBA,IBNAME,DD,DO,DLAYGO,DIC,X,Y,IBDA,IBARR,IBX
+2 ;
+3 SET IBNAME="LONG TERM CARE COVERAGE"
+4 IF $ORDER(^IBE(355.6,"B",IBNAME,0))
SET IBA=">> "_IBNAME_" Insurance Rider (355.6) exists, no change"
DO MSG(IBA)
QUIT
+5 ;
+6 KILL DD,DO
SET DLAYGO=355.6
SET DIC="^IBE(355.6,"
SET DIC(0)="L"
SET X=IBNAME
DO FILE^DICN
KILL DIC
SET IBDA=+Y
IF Y<1
KILL X,Y
QUIT
+7 ;
+8 SET IBA=">> "_IBNAME_" Insurance Rider (#355.6) added"
DO MSG(IBA)
+9 QUIT
+10 ;
+11 ;
CV ; add LONG TERM CARE Coverage (#355.31)
+1 NEW IBA,IBNAME,IBRIDER,IBRDA,IBX,DD,DO,DLAYGO,DIC,X,Y,IBDA,DIE,DA,DR,IBFILE
+2 SET IBFILE=" Plan Limitation Category (#355.31) "
+3 ;
+4 SET IBNAME="LONG TERM CARE"
SET IBRIDER="LONG TERM CARE COVERAGE"
+5 SET IBRDA=$ORDER(^IBE(355.6,"B",IBRIDER,0))
IF 'IBRDA
SET IBA="=> "_IBNAME_IBFILE_"Not Added, Rider Missing"
DO MSG(IBA)
QUIT
+6 ;
+7 IF $ORDER(^IBE(355.31,"B",IBNAME,0))
SET IBA=">> "_IBNAME_IBFILE_"exists, no change"
DO MSG(IBA)
QUIT
+8 ;
+9 KILL DD,DO
SET DLAYGO=355.31
SET DIC="^IBE(355.31,"
SET DIC(0)="L"
SET X=IBNAME
DO FILE^DICN
KILL DIC
SET IBDA=+Y
IF Y<1
KILL X,Y
QUIT
+10 ;
+11 SET DIE="^IBE(355.31,"
SET DA=+IBDA
SET DR=".02////Long Term Care coverage;.03////"_IBRDA
DO ^DIE
KILL DIE,DA,DR,X,Y
+12 ;
+13 SET IBA=">> "_IBNAME_IBFILE_"added"
DO MSG(IBA)
+14 ;
+15 QUIT
+16 ;
XREF ; re-index new AE cross reference on IB BILL/CLAIMS PROSTHETICS (#362.5), RECORD (.04)
+1 NEW DIK,DIC,X,Y
DO MSG(">> Indexing new 'AE' xref IB BILL/CLAIMS PROSTHETICS, RECORD (#362.5,.04)")
+2 SET DIK="^IBA(362.5,"
SET DIK(1)=".04^AE"
DO ENALL^DIK
+3 QUIT
+4 ;
MSG(IBA) ;
+1 NEW IBM
SET IBM(1)=" "
SET IBM(2)=" "_$GET(IBA)
+2 DO MES^XPDUTL(.IBM)
+3 QUIT
