FBY130PO ;Harris/YMG - Post Install for FB patch 130 ;26-Oct-2011
;;3.5;FEE BASIS;**130**;JAN 30, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; project ARCH post-install
;
EN ; entry point
N XPDIDTOT
S XPDIDTOT=1
D JUST(1) ; 1. Modify eligibility justification entries
;
EX ; exit point
Q
;
JUST(FBXPD) ; modify entries in file 161.35
;
N DA,DIE,DIK,DR,IEN1,IEN2,NEWPTR,PTR,STR,X,Y,Z
D BMES^XPDUTL(" STEP "_FBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Setting eligibility justification entries ... ")
;
S Z=$P(^FBAA(161.35,0),U,3) I Z=3 G JUSTX ; there's nothing to do
; delete existing entries
S DIK="^FBAA(161.35," F DA=1:1:Z D ^DIK
; create new entries
S STR(1)="OEF/OIF/OND, enrolled after 8/29/2011, geographic eligibility confirmed via web based tool"
S STR(2)="Enrolled between 10/1/2010 and 8/29/2011, geographic eligibility confirmed via web based tool"
S STR(3)="Enrolled prior to 10/1/2010, geographic eligibility confirmed via web based tool"
F DA=1:1:3 S DR=".01////"_STR(DA)_";1////1",DIE=161.35 D ^DIE
; change existing pointers
TEST ;
S Z="" F S Z=$O(^FBAAA("ARCH",Z)) Q:Z="" D
.S IEN1="" F S IEN1=$O(^FBAAA("ARCH",Z,IEN1)) Q:IEN1="" D
..S IEN2="" F S IEN2=$O(^FBAAA("ARCH",Z,IEN1,IEN2)) Q:IEN2="" D
...S PTR=+$P(^FBAAA(IEN1,"ARCHFEE",IEN2,0),U,4)
...I PTR'>0 Q ; only change existing pointers
...S NEWPTR=$S(PTR=5:2,PTR=1:3,PTR=6:3,1:1)
...S DIE="^FBAAA("_IEN1_",""ARCHFEE"",",DA(1)=IEN1,DA=IEN2,DR="4////"_NEWPTR D ^DIE
...Q
..Q
.Q
;
JUSTX ;
D MES^XPDUTL(" Done.")
D UPDATE^XPDID(FBXPD)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBY130PO 1670 printed Dec 13, 2024@02:01:59 Page 2
FBY130PO ;Harris/YMG - Post Install for FB patch 130 ;26-Oct-2011
+1 ;;3.5;FEE BASIS;**130**;JAN 30, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; project ARCH post-install
+5 ;
EN ; entry point
+1 NEW XPDIDTOT
+2 SET XPDIDTOT=1
+3 ; 1. Modify eligibility justification entries
DO JUST(1)
+4 ;
EX ; exit point
+1 QUIT
+2 ;
JUST(FBXPD) ; modify entries in file 161.35
+1 ;
+2 NEW DA,DIE,DIK,DR,IEN1,IEN2,NEWPTR,PTR,STR,X,Y,Z
+3 DO BMES^XPDUTL(" STEP "_FBXPD_" of "_XPDIDTOT)
+4 DO MES^XPDUTL("-------------")
+5 DO MES^XPDUTL("Setting eligibility justification entries ... ")
+6 ;
+7 ; there's nothing to do
SET Z=$PIECE(^FBAA(161.35,0),U,3)
IF Z=3
GOTO JUSTX
+8 ; delete existing entries
+9 SET DIK="^FBAA(161.35,"
FOR DA=1:1:Z
DO ^DIK
+10 ; create new entries
+11 SET STR(1)="OEF/OIF/OND, enrolled after 8/29/2011, geographic eligibility confirmed via web based tool"
+12 SET STR(2)="Enrolled between 10/1/2010 and 8/29/2011, geographic eligibility confirmed via web based tool"
+13 SET STR(3)="Enrolled prior to 10/1/2010, geographic eligibility confirmed via web based tool"
+14 FOR DA=1:1:3
SET DR=".01////"_STR(DA)_";1////1"
SET DIE=161.35
DO ^DIE
+15 ; change existing pointers
TEST ;
+1 SET Z=""
FOR
SET Z=$ORDER(^FBAAA("ARCH",Z))
if Z=""
QUIT
Begin DoDot:1
+2 SET IEN1=""
FOR
SET IEN1=$ORDER(^FBAAA("ARCH",Z,IEN1))
if IEN1=""
QUIT
Begin DoDot:2
+3 SET IEN2=""
FOR
SET IEN2=$ORDER(^FBAAA("ARCH",Z,IEN1,IEN2))
if IEN2=""
QUIT
Begin DoDot:3
+4 SET PTR=+$PIECE(^FBAAA(IEN1,"ARCHFEE",IEN2,0),U,4)
+5 ; only change existing pointers
IF PTR'>0
QUIT
+6 SET NEWPTR=$SELECT(PTR=5:2,PTR=1:3,PTR=6:3,1:1)
+7 SET DIE="^FBAAA("_IEN1_",""ARCHFEE"","
SET DA(1)=IEN1
SET DA=IEN2
SET DR="4////"_NEWPTR
DO ^DIE
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 ;
JUSTX ;
+1 DO MES^XPDUTL(" Done.")
+2 DO UPDATE^XPDID(FBXPD)
+3 QUIT
