FBXIP109 ;ALB/RC-PATCH INSTALL ROUTINE ; 12/29/08 1:54pm
;;3.5;FEE BASIS;**109**;JAN 30, 1995;Build 10
Q
;
PS ; post-install entry point
; create KIDS checkpoints with call backs
N FBX
F FBX="EN" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP109")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
EN ; Begin Post-Install
D CF ;Add Conv factors
D POV ;Update Place of Visit
Q
CF ; add conversion factors for calendar year 2009 RBRVS fee schedule
; File 162.99 is being updated in the post install because the Fee
; Basis software examines this file to determine the latest available
; fee schedule. By doing this at the end of the patch installation,
; users can continue to use the payment options during the install.
D BMES^XPDUTL(" Filing conversion factor for RBRVS 2009 fee schedule.")
N DD,DO,DA,DIE,DR,X,Y
S DA(1)=0 F S DA(1)=$O(^FB(162.99,DA(1))) Q:'DA(1) D
. S DA=$O(^FB(162.99,DA(1),"CY","B",2009,0))
. I DA'>0 D Q:DA'>0
. . S DIC="^FB(162.99,"_DA(1)_",""CY"",",DIC(0)="L",DIC("P")="162.991A",DLAYGO=162.991
. . S X=2009
. . K DD,DO D FILE^DICN
. . K DIC,DLAYGO
. . S DA=+Y
. ;
. S DIE="^FB(162.99,"_DA(1)_",""CY"","
. S DR=".02///"_$S(DA(1)=1:20.9150,1:36.0666)
. D ^DIE
Q
POV ;Update Place of Visit
;
;Add 67,68,69,56
D BMES^XPDUTL("Updating Place of Visit entries in the FEE BASIS PURPOSE OF VISIT file (#161.82)")
N FBCNT,X,NEWENTRY,NEWCODE,NEWPOV,POVCHECK
F FBCNT=1:1 S NEWENTRY=$P($T(NEWTABLE+FBCNT),";;",2) Q:NEWENTRY="EXIT" D
.S NEWPOV=$P(NEWENTRY,"^",1),NEWCODE=$P(NEWENTRY,"^",2)
.S POVCHECK=$O(^FBAA(161.82,"C",NEWCODE,"")) D
..I POVCHECK D BMES^XPDUTL("Code: "_NEWCODE_" already exists, please verify this entry in the FEE BASIS PURPOSE OF VISIT file (#161.82).") Q
..N DIC,DA,DR,DLAYGO,DINUM
..S DIC="^FBAA(161.82,",DIC(0)="L",DLAYGO=161.82
..S X=NEWPOV,DIC("DR")="3///^S X=NEWCODE",DINUM=NEWCODE
..K DD,D0 D FILE^DICN K DIC,DA,DLAYGO
;Inactivate POV 20
N DA,DIE,DR
S DA=$O(^FBAA(161.82,"B","CLASS IIr DENTAL TREATMENT",""))
S DIE="^FBAA(161.82,",DR="4///01/01/09"
D
.I DA D ^DIE Q
.D BMES^XPDUTL("Purpose of Visit 20, ""CLASS IIr DENTAL TREATMENT"", does not exist.")
Q
NEWTABLE ;New POVs
;;Dialysis^56
;;Outpatient Maternity Care Services^67
;;Bowel and Bladder care: Agency^68
;;Bowel and Bladder care: Family caregiver^69
;;EXIT
;FBXIP109
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP109 2399 printed Apr 09, 2024@21:00:49 Page 2
FBXIP109 ;ALB/RC-PATCH INSTALL ROUTINE ; 12/29/08 1:54pm
+1 ;;3.5;FEE BASIS;**109**;JAN 30, 1995;Build 10
+2 QUIT
+3 ;
PS ; post-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX
+3 FOR FBX="EN"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP109")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
EN ; Begin Post-Install
+1 ;Add Conv factors
DO CF
+2 ;Update Place of Visit
DO POV
+3 QUIT
CF ; add conversion factors for calendar year 2009 RBRVS fee schedule
+1 ; File 162.99 is being updated in the post install because the Fee
+2 ; Basis software examines this file to determine the latest available
+3 ; fee schedule. By doing this at the end of the patch installation,
+4 ; users can continue to use the payment options during the install.
+5 DO BMES^XPDUTL(" Filing conversion factor for RBRVS 2009 fee schedule.")
+6 NEW DD,DO,DA,DIE,DR,X,Y
+7 SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FB(162.99,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:1
+8 SET DA=$ORDER(^FB(162.99,DA(1),"CY","B",2009,0))
+9 IF DA'>0
Begin DoDot:2
+10 SET DIC="^FB(162.99,"_DA(1)_",""CY"","
SET DIC(0)="L"
SET DIC("P")="162.991A"
SET DLAYGO=162.991
+11 SET X=2009
+12 KILL DD,DO
DO FILE^DICN
+13 KILL DIC,DLAYGO
+14 SET DA=+Y
End DoDot:2
if DA'>0
QUIT
+15 ;
+16 SET DIE="^FB(162.99,"_DA(1)_",""CY"","
+17 SET DR=".02///"_$SELECT(DA(1)=1:20.9150,1:36.0666)
+18 DO ^DIE
End DoDot:1
+19 QUIT
POV ;Update Place of Visit
+1 ;
+2 ;Add 67,68,69,56
+3 DO BMES^XPDUTL("Updating Place of Visit entries in the FEE BASIS PURPOSE OF VISIT file (#161.82)")
+4 NEW FBCNT,X,NEWENTRY,NEWCODE,NEWPOV,POVCHECK
+5 FOR FBCNT=1:1
SET NEWENTRY=$PIECE($TEXT(NEWTABLE+FBCNT),";;",2)
if NEWENTRY="EXIT"
QUIT
Begin DoDot:1
+6 SET NEWPOV=$PIECE(NEWENTRY,"^",1)
SET NEWCODE=$PIECE(NEWENTRY,"^",2)
+7 SET POVCHECK=$ORDER(^FBAA(161.82,"C",NEWCODE,""))
Begin DoDot:2
+8 IF POVCHECK
DO BMES^XPDUTL("Code: "_NEWCODE_" already exists, please verify this entry in the FEE BASIS PURPOSE OF VISIT file (#161.82).")
QUIT
+9 NEW DIC,DA,DR,DLAYGO,DINUM
+10 SET DIC="^FBAA(161.82,"
SET DIC(0)="L"
SET DLAYGO=161.82
+11 SET X=NEWPOV
SET DIC("DR")="3///^S X=NEWCODE"
SET DINUM=NEWCODE
+12 KILL DD,D0
DO FILE^DICN
KILL DIC,DA,DLAYGO
End DoDot:2
End DoDot:1
+13 ;Inactivate POV 20
+14 NEW DA,DIE,DR
+15 SET DA=$ORDER(^FBAA(161.82,"B","CLASS IIr DENTAL TREATMENT",""))
+16 SET DIE="^FBAA(161.82,"
SET DR="4///01/01/09"
+17 Begin DoDot:1
+18 IF DA
DO ^DIE
QUIT
+19 DO BMES^XPDUTL("Purpose of Visit 20, ""CLASS IIr DENTAL TREATMENT"", does not exist.")
End DoDot:1
+20 QUIT
NEWTABLE ;New POVs
+1 ;;Dialysis^56
+2 ;;Outpatient Maternity Care Services^67
+3 ;;Bowel and Bladder care: Agency^68
+4 ;;Bowel and Bladder care: Family caregiver^69
+5 ;;EXIT
+6 ;FBXIP109
