FBY130PO.m

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 ---FBY130PO   1670     printed  Apr 09, 2024@21:05:16                                                                                                                                                                                                    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