FBXIP108.m

FBXIP108 ;WOIFO/SAB - PATCH INSTALL ROUTINE ;6/17/2009

 ;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 Q

 ;

PR ; pre-install entry point

 ; create KIDS checkpoints with call backs

 N FBX,Y

 F FBX="OPT" D

 . S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP108")

 . I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

 Q

 ;

OPT ; pre-install: remove options from supervisor menu

 ; ICR 1157 for $$DELETE^XPDMENU()

 N FBMENU,FBX

 D BMES^XPDUTL("  Updating Supervisor Main Menu...")

 S FBMENU="FBAA SUPERVISOR OPTIONS"

 S FBX=$$DELETE^XPDMENU(FBMENU,"FBUC ADD NEW PERSON")

 S FBX=$$DELETE^XPDMENU(FBMENU,"FBUC DISAPPROVAL REASONS FILE")

 S FBX=$$DELETE^XPDMENU(FBMENU,"FBUC DISPOSITIONS FILE")

 S FBX=$$DELETE^XPDMENU(FBMENU,"FBUC REQUEST INFO FILE")

 Q

 ;

PS ; post-install entry point

 ; create KIDS checkpoints with call backs

 N FBX,Y

 F FBX="HRO","PAR" D

 . S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP108")

 . I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

 Q

 ;

HRO ; Add HERO contracts

 ; ICR 2541 for $$KSP^XUPARAM

 N FBDINST,FBVISN

 ; get default institution ien

 S FBDINST=$$KSP^XUPARAM("INST")

 ; determine VISN

 S FBVISN=$$VISN(FBDINST)

 ; Enter HERO data if VISN is 8, 16, 20, or 23

 I "^VISN 8^VISN 16^VISN 20^VISN 23^"[("^"_FBVISN_"^") D

 . N FBCNTRN,FBFDA,FBV,FBVID,FBVNM

 . ; Delta contract

 . S FBCNTRN="VA101(049A3)-P-0269"

 . S FBVID="942761537"

 . S FBVNM="Delta"

 . I $D(^FBAA(161.43,"B",FBCNTRN)) D

 . . D BMES^XPDUTL(FBCNTRN_" is already set up as a contract.")

 . I '$D(^FBAA(161.43,"B",FBCNTRN)) D

 . . D BMES^XPDUTL("  Adding "_FBCNTRN_" as a contract for "_FBVNM_"...")

 . . S FBV=$$FIND1^DIC(161.2,"","X",FBVID,"C")

 . . I 'FBV D

 . . . D MES^XPDUTL("    Can't find Fee Basis Vendor with ID "_FBVID)

 . . . D MES^XPDUTL("    The contract must be manually edited to add")

 . . . D MES^XPDUTL("    the applicable vendor.")

 . . S FBFDA(161.43,"+1,",.01)=FBCNTRN

 . . S FBFDA(161.43,"+1,",2)="A"

 . . S:FBV FBFDA(161.433,"+2,+1,",.01)=FBV

 . ; HVHS contract

 . S FBCNTRN="VA101049A3-P-0270"

 . S FBVID="208418853"

 . S FBVNM="HVHS"

 . I $D(^FBAA(161.43,"B",FBCNTRN)) D

 . . D BMES^XPDUTL(FBCNTRN_" is already set up as a contract.")

 . I '$D(^FBAA(161.43,"B",FBCNTRN)) D

 . . D BMES^XPDUTL("  Adding "_FBCNTRN_" as a contract for "_FBVNM_"...")

 . . S FBV=$$FIND1^DIC(161.2,"","X",FBVID,"C")

 . . I 'FBV D

 . . . D MES^XPDUTL("    Can't find Fee Basis Vendor with ID "_FBVID)

 . . . D MES^XPDUTL("    The contract must be manually edited to add")

 . . . D MES^XPDUTL("    the applicable vendor.")

 . . S FBFDA(161.43,"+3,",.01)=FBCNTRN

 . . S FBFDA(161.43,"+3,",2)="A"

 . . S:FBV FBFDA(161.433,"+4,+3,",.01)=FBV

 . I $D(FBFDA) D UPDATE^DIE("","FBFDA")

 Q

 ;

VISN(FBSTAI) ; VISN extrinsic function

 ; ICR 2171 for PARENT^XUAF4

 ; input   - IEN of an entry in the INSTITUTION (#4) file

 ; returns - the name of the parent VISN or a null value

 N FBARR,FBRET,FBVISNI

 S FBRET=""

 I FBSTAI D

 . D PARENT^XUAF4("FBARR","`"_FBSTAI,"VISN")

 . S FBVISNI=$O(FBARR("P",""))

 . I FBVISNI S FBRET=$P(FBARR("P",FBVISNI),"^")

 Q FBRET

 ;

PAR ; Populate new parameter fields

 N FBFDA,FBY

 S FBY=$G(^FBAA(161.4,1,"FBNUM"))

 I $P(FBY,"^",3)="" S FBFDA(161.4,"1,",17)=85

 I $P(FBY,"^",3)>85 S FBFDA(161.4,"1,",17)=85

 I $P(FBY,"^",4)="" S FBFDA(161.4,"1,",17.1)=42

 I $P(FBY,"^",5)="" S FBFDA(161.4,"1,",17.2)=61

 I $D(FBFDA) D FILE^DIE("","FBFDA")

 Q

 ;FBXIP108

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBXIP108   3527     printed  Apr 23, 2025@18:15:34                                                                                                                                                                                                    Page 2

FBXIP108  ;WOIFO/SAB - PATCH INSTALL ROUTINE ;6/17/2009

 +1       ;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3        QUIT 

 +4       ;

PR        ; pre-install entry point

 +1       ; create KIDS checkpoints with call backs

 +2        NEW FBX,Y

 +3        FOR FBX="OPT"

               Begin DoDot:1

 +4                SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP108")

 +5                IF 'Y

                       DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

               End DoDot:1

 +6        QUIT 

 +7       ;

OPT       ; pre-install: remove options from supervisor menu

 +1       ; ICR 1157 for $$DELETE^XPDMENU()

 +2        NEW FBMENU,FBX

 +3        DO BMES^XPDUTL("  Updating Supervisor Main Menu...")

 +4        SET FBMENU="FBAA SUPERVISOR OPTIONS"

 +5        SET FBX=$$DELETE^XPDMENU(FBMENU,"FBUC ADD NEW PERSON")

 +6        SET FBX=$$DELETE^XPDMENU(FBMENU,"FBUC DISAPPROVAL REASONS FILE")

 +7        SET FBX=$$DELETE^XPDMENU(FBMENU,"FBUC DISPOSITIONS FILE")

 +8        SET FBX=$$DELETE^XPDMENU(FBMENU,"FBUC REQUEST INFO FILE")

 +9        QUIT 

 +10      ;

PS        ; post-install entry point

 +1       ; create KIDS checkpoints with call backs

 +2        NEW FBX,Y

 +3        FOR FBX="HRO","PAR"

               Begin DoDot:1

 +4                SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP108")

 +5                IF 'Y

                       DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

               End DoDot:1

 +6        QUIT 

 +7       ;

HRO       ; Add HERO contracts

 +1       ; ICR 2541 for $$KSP^XUPARAM

 +2        NEW FBDINST,FBVISN

 +3       ; get default institution ien

 +4        SET FBDINST=$$KSP^XUPARAM("INST")

 +5       ; determine VISN

 +6        SET FBVISN=$$VISN(FBDINST)

 +7       ; Enter HERO data if VISN is 8, 16, 20, or 23

 +8        IF "^VISN 8^VISN 16^VISN 20^VISN 23^"[("^"_FBVISN_"^")

               Begin DoDot:1

 +9                NEW FBCNTRN,FBFDA,FBV,FBVID,FBVNM

 +10      ; Delta contract

 +11               SET FBCNTRN="VA101(049A3)-P-0269"

 +12               SET FBVID="942761537"

 +13               SET FBVNM="Delta"

 +14               IF $DATA(^FBAA(161.43,"B",FBCNTRN))

                       Begin DoDot:2

 +15                       DO BMES^XPDUTL(FBCNTRN_" is already set up as a contract.")

                       End DoDot:2

 +16               IF '$DATA(^FBAA(161.43,"B",FBCNTRN))

                       Begin DoDot:2

 +17                       DO BMES^XPDUTL("  Adding "_FBCNTRN_" as a contract for "_FBVNM_"...")

 +18                       SET FBV=$$FIND1^DIC(161.2,"","X",FBVID,"C")

 +19                       IF 'FBV

                               Begin DoDot:3

 +20                               DO MES^XPDUTL("    Can't find Fee Basis Vendor with ID "_FBVID)

 +21                               DO MES^XPDUTL("    The contract must be manually edited to add")

 +22                               DO MES^XPDUTL("    the applicable vendor.")

                               End DoDot:3

 +23                       SET FBFDA(161.43,"+1,",.01)=FBCNTRN

 +24                       SET FBFDA(161.43,"+1,",2)="A"

 +25                       if FBV

                               SET FBFDA(161.433,"+2,+1,",.01)=FBV

                       End DoDot:2

 +26      ; HVHS contract

 +27               SET FBCNTRN="VA101049A3-P-0270"

 +28               SET FBVID="208418853"

 +29               SET FBVNM="HVHS"

 +30               IF $DATA(^FBAA(161.43,"B",FBCNTRN))

                       Begin DoDot:2

 +31                       DO BMES^XPDUTL(FBCNTRN_" is already set up as a contract.")

                       End DoDot:2

 +32               IF '$DATA(^FBAA(161.43,"B",FBCNTRN))

                       Begin DoDot:2

 +33                       DO BMES^XPDUTL("  Adding "_FBCNTRN_" as a contract for "_FBVNM_"...")

 +34                       SET FBV=$$FIND1^DIC(161.2,"","X",FBVID,"C")

 +35                       IF 'FBV

                               Begin DoDot:3

 +36                               DO MES^XPDUTL("    Can't find Fee Basis Vendor with ID "_FBVID)

 +37                               DO MES^XPDUTL("    The contract must be manually edited to add")

 +38                               DO MES^XPDUTL("    the applicable vendor.")

                               End DoDot:3

 +39                       SET FBFDA(161.43,"+3,",.01)=FBCNTRN

 +40                       SET FBFDA(161.43,"+3,",2)="A"

 +41                       if FBV

                               SET FBFDA(161.433,"+4,+3,",.01)=FBV

                       End DoDot:2

 +42               IF $DATA(FBFDA)

                       DO UPDATE^DIE("","FBFDA")

               End DoDot:1

 +43       QUIT 

 +44      ;

VISN(FBSTAI) ; VISN extrinsic function

 +1       ; ICR 2171 for PARENT^XUAF4

 +2       ; input   - IEN of an entry in the INSTITUTION (#4) file

 +3       ; returns - the name of the parent VISN or a null value

 +4        NEW FBARR,FBRET,FBVISNI

 +5        SET FBRET=""

 +6        IF FBSTAI

               Begin DoDot:1

 +7                DO PARENT^XUAF4("FBARR","`"_FBSTAI,"VISN")

 +8                SET FBVISNI=$ORDER(FBARR("P",""))

 +9                IF FBVISNI

                       SET FBRET=$PIECE(FBARR("P",FBVISNI),"^")

               End DoDot:1

 +10       QUIT FBRET

 +11      ;

PAR       ; Populate new parameter fields

 +1        NEW FBFDA,FBY

 +2        SET FBY=$GET(^FBAA(161.4,1,"FBNUM"))

 +3        IF $PIECE(FBY,"^",3)=""

               SET FBFDA(161.4,"1,",17)=85

 +4        IF $PIECE(FBY,"^",3)>85

               SET FBFDA(161.4,"1,",17)=85

 +5        IF $PIECE(FBY,"^",4)=""

               SET FBFDA(161.4,"1,",17.1)=42

 +6        IF $PIECE(FBY,"^",5)=""

               SET FBFDA(161.4,"1,",17.2)=61

 +7        IF $DATA(FBFDA)

               DO FILE^DIE("","FBFDA")

 +8        QUIT 

 +9       ;FBXIP108