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 ---[H[J[2J[HFBXIP108 3527 printed Apr 09, 2024@21:05:17 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
