FBXIP4 ;WCIOFO/SAB-PATCH INSTALL ROUTINE ;6/21/1999
;;3.5;FEE BASIS;**4**;JAN 30, 1995
Q
;
PR ; pre-install entry point
; create KIDS checkpoints with call backs
N FBX
F FBX="PRG" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP4")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
PS ; post-install entry point
; create KIDS checkpoints with call backs
N FBX
F FBX="MOD" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP4")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
PRG ; Purge Old RBRVS Fee Schedules (pre-install)
N DA,DIK,ENC,FBDEL,FBMT,FBYR,FBYRC
;
S FBYRC=1997 ; ***earliest year that will be retained
;
; determine if there is any data prior to year FBYRC
D BMES^XPDUTL(" Looking for old (before "_FBYRC_") RBRVS fee schedules to purge...")
S DA=$O(^FB(162.99,"B","MEDICINE",0))
S FBDEL=0,FBYR=""
I DA>0 D
. F S FBYR=$O(^FB(162.99,DA,"CY","B",FBYR)) Q:FBYR=""!(FBYR'<FBYRC) D
. . D MES^XPDUTL(" RBRVS fee schedule for "_FBYR_" was found.")
. . S FBDEL=1
I 'FBDEL D MES^XPDUTL(" No old RBRVS fee schedules were found.") Q
;
D MES^XPDUTL(" Purging old data")
;
; delete 162.96 data (GPCI) prior to year FBYRC
; init variables
S FBC("TOT")=$P($G(^FB(162.96,0)),U,4) ; total # of entries to process
I FBC("TOT")=0 S FBC("TOT")=1 ; avoid divide by zero error
S FBC("ENT")=0 ; count of evaluated entries
S XPDIDTOT=FBC("TOT") ; set total for status bar
S FBC("UPD")=5 ; initial % required to update status bar
D MES^XPDUTL(" from file 162.96...")
K DA S DA(1)=0 F S DA(1)=$O(^FB(162.96,DA(1))) Q:'DA(1) D
. S FBC("ENT")=FBC("ENT")+1
. S FBC("%")=FBC("ENT")*100/FBC("TOT") ; calculate % complete
. ; check if status bar should be updated
. I FBC("%")>FBC("UPD") D
. . D UPDATE^XPDID(FBC("ENT")) ; update status bar
. . S FBC("UPD")=FBC("UPD")+5 ; increase update criteria by 5%
. S DA=0 F S DA=$O(^FB(162.96,DA(1),"CY",DA)) Q:'DA D
. . S FBYR=$P($G(^FB(162.96,DA(1),"CY",DA,0)),U)
. . I FBYR<FBYRC S DIK="^FB(162.96,"_DA(1)_",""CY""," D ^DIK
;
; init variables
S FBC("TOT")=$P($G(^FB(162.97,0)),U,4) ; total # of entries to process
I FBC("TOT")=0 S FBC("TOT")=1 ; avoid divide by zero error
S FBC("ENT")=0 ; count of evaluated entries
S XPDIDTOT=FBC("TOT") ; set total for status bar
S FBC("UPD")=5 ; initial % required to update status bar
D MES^XPDUTL(" from file 162.97...")
; delete 162.97 data (CPT RVU) prior to year FBYRC
K DA S DA(1)=0 F S DA(1)=$O(^FB(162.97,DA(1))) Q:'DA(1) D
. S FBC("ENT")=FBC("ENT")+1
. S FBC("%")=FBC("ENT")*100/FBC("TOT") ; calculate % complete
. ; check if status bar should be updated
. I FBC("%")>FBC("UPD") D
. . D UPDATE^XPDID(FBC("ENT")) ; update status bar
. . S FBC("UPD")=FBC("UPD")+5 ; increase update criteria by 5%
. S DA=0 F S DA=$O(^FB(162.97,DA(1),"CY",DA)) Q:'DA D
. . S FBYR=$P($G(^FB(162.97,DA(1),"CY",DA,0)),U)
. . I FBYR<FBYRC S DIK="^FB(162.97,"_DA(1)_",""CY""," D ^DIK
;
; delete 162.98 data (MOD LEVEL TABLE) prior to year FBYRC
D MES^XPDUTL(" from file 162.98...")
K DA S DIK="^FB(162.98,",FBMT=""
F S FBMT=$O(^FB(162.98,"B",FBMT)) Q:FBMT=""!($P(FBMT,"-")'<FBYRC) D
. S DA=0 F S DA=$O(^FB(162.98,"B",FBMT,DA)) Q:'DA D ^DIK
;
; delete 162.99 data (CONVERSION FACTOR) prior to year FBYRC
D MES^XPDUTL(" from file 162.99...")
K DA S DA(1)=0 F S DA(1)=$O(^FB(162.99,DA(1))) Q:'DA(1) D
. S DA=0 F S DA=$O(^FB(162.99,DA(1),"CY",DA)) Q:'DA D
. . S FBYR=$P($G(^FB(162.99,DA(1),"CY",DA,0)),U)
. . I FBYR<FBYRC S DIK="^FB(162.99,"_DA(1)_",""CY""," D ^DIK
;
D MES^XPDUTL(" Purge completed.")
Q
;
MOD ; Move CPT Modifier data (post-install)
;
; If field 39 not CPT MODIFER then already done
I $$GET1^DID(162.03,39,"","LABEL")'="CPT MODIFIER" D Q
. D BMES^XPDUTL(" CPT MODIFIER data already moved. Skipping step.")
;
; loop through file 162 - move data from 39 into new multiple
D BMES^XPDUTL(" Moving CPT MODIFIER data in file 162...")
; init variables
S FBC("TOT")=$P($G(^FBAAC(0)),U,4) ; total # of patients to process
I FBC("TOT")=0 S FBC("TOT")=1 ; avoid divide by zero error
S FBC("PAT")=0 ; count of evaluated patients
S FBC("MOD")=0 ; count of modifiers moved
S XPDIDTOT=FBC("TOT") ; set total for status bar
S FBC("UPD")=5 ; initial % required to update status bar
; loop thru patients
S FBD0=0 F S FBD0=$O(^FBAAC(FBD0)) Q:'FBD0 D
. S FBC("PAT")=FBC("PAT")+1
. S FBC("%")=FBC("PAT")*100/FBC("TOT") ; calculate % complete
. ; check if status bar should be updated
. I FBC("%")>FBC("UPD") D
. . D UPDATE^XPDID(FBC("PAT")) ; update status bar
. . S FBC("UPD")=FBC("UPD")+5 ; increase update criteria by 5%
. ; loop thru vendors
. S FBD1=0 F S FBD1=$O(^FBAAC(FBD0,1,FBD1)) Q:'FBD1 D
. . ; loop thru initial treatment date
. . S FBD2=0 F S FBD2=$O(^FBAAC(FBD0,1,FBD1,1,FBD2)) Q:'FBD2 D
. . . ; loop thru service provided
. . . S FBD3=0
. . . F S FBD3=$O(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3)) Q:'FBD3 D
. . . . ; get single valued modifier
. . . . S FBMOD=$P($G(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,2)),U,7)
. . . . Q:'FBMOD ; nothing to move
. . . . Q:$O(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M",0)) ; unexpected
. . . . ; put modifier in multiple field
. . . . S ^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M",0)="^162.06P^1^1"
. . . . S ^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M",1,0)=FBMOD
. . . . S ^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M","B",FBMOD,1)=""
. . . . ; delete modifier from old location
. . . . S $P(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,2),U,7)=""
. . . . S FBC("MOD")=FBC("MOD")+1
;
; delete field 39 from data dictionary
S DIK="^DD(162.03,",DA=39,DA(1)=162.03 D ^DIK
;
; report results
D MES^XPDUTL(" "_FBC("PAT")_" FEE BASIS PATIENTs were evaluated.")
D MES^XPDUTL(" "_FBC("MOD")_" CPT Modifiers were moved.")
Q
;
VPC ; Add Vendor Participation Codes (post-install)
; NOTE: This section will not be performed by patch FB*3.5*4 and
; label has been VPC removed from the post-install call backs.
Q ; quit statement added to prevent execution of code
N FBFDA,FBFDAIEN,FBI,FBX,FBY0
D BMES^XPDUTL(" Adding new participation codes...")
F FBI=1:1 S FBX=$P($T(VPCT+FBI),";",3) Q:$P(FBX,U)="" D
. S FBY0=$G(^FBAA(161.81,$P(FBX,U),0))
. I $P(FBY0,U)]"",$P(FBY0,U)=$P(FBX,U,2) Q ; already there
. I $P(FBY0,U)]"",$P(FBY0,U)'=$P(FBX,U,2) D Q ; unexpected value
. . D MES^XPDUTL(" Error adding "_$P(FBX,U,2)_" ("_$P(FBX,U,3)_")")
. . D MES^XPDUTL(" because local '"_$P(FBY0,U)_"' is in it's place.")
. S FBFDA(161.81,"+"_$P(FBX,U)_",",.01)=$P(FBX,U,2)
. S FBFDA(161.81,"+"_$P(FBX,U)_",",1)=$P(FBX,U,3)
. S FBFDAIEN($P(FBX,U))=$P(FBX,U)
I $D(FBFDA) D UPDATE^DIE("E","FBFDA","FBFDAIEN") D MSG^DIALOG()
Q
VPCT ;;Participation Code Data (internal entry number^#.01 field^#1 field)
;;15^PHYSICAL/OCCUPATIONAL THERAPIST^15;
;;16^PHYSICIAN ASSISTANT^16;
;;17^NURSE PRACTITIONER^17;
;;18^CLINICAL NURSE SPECIALIST^18;
;;19^CERTIFIED REGISTERED NURSE ANESTHETIST^19;
;;20^NURSE MIDWIFE^20;
;;21^CLINICAL PSYCHOLOGIST^21;
;;22^CLINICAL SOCIAL WORKER^22;
;;; end of vendor participation codes
;FBXIP4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP4 7226 printed Sep 23, 2025@19:37:54 Page 2
FBXIP4 ;WCIOFO/SAB-PATCH INSTALL ROUTINE ;6/21/1999
+1 ;;3.5;FEE BASIS;**4**;JAN 30, 1995
+2 QUIT
+3 ;
PR ; pre-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX
+3 FOR FBX="PRG"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP4")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
PS ; post-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX
+3 FOR FBX="MOD"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP4")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
PRG ; Purge Old RBRVS Fee Schedules (pre-install)
+1 NEW DA,DIK,ENC,FBDEL,FBMT,FBYR,FBYRC
+2 ;
+3 ; ***earliest year that will be retained
SET FBYRC=1997
+4 ;
+5 ; determine if there is any data prior to year FBYRC
+6 DO BMES^XPDUTL(" Looking for old (before "_FBYRC_") RBRVS fee schedules to purge...")
+7 SET DA=$ORDER(^FB(162.99,"B","MEDICINE",0))
+8 SET FBDEL=0
SET FBYR=""
+9 IF DA>0
Begin DoDot:1
+10 FOR
SET FBYR=$ORDER(^FB(162.99,DA,"CY","B",FBYR))
if FBYR=""!(FBYR'<FBYRC)
QUIT
Begin DoDot:2
+11 DO MES^XPDUTL(" RBRVS fee schedule for "_FBYR_" was found.")
+12 SET FBDEL=1
End DoDot:2
End DoDot:1
+13 IF 'FBDEL
DO MES^XPDUTL(" No old RBRVS fee schedules were found.")
QUIT
+14 ;
+15 DO MES^XPDUTL(" Purging old data")
+16 ;
+17 ; delete 162.96 data (GPCI) prior to year FBYRC
+18 ; init variables
+19 ; total # of entries to process
SET FBC("TOT")=$PIECE($GET(^FB(162.96,0)),U,4)
+20 ; avoid divide by zero error
IF FBC("TOT")=0
SET FBC("TOT")=1
+21 ; count of evaluated entries
SET FBC("ENT")=0
+22 ; set total for status bar
SET XPDIDTOT=FBC("TOT")
+23 ; initial % required to update status bar
SET FBC("UPD")=5
+24 DO MES^XPDUTL(" from file 162.96...")
+25 KILL DA
SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FB(162.96,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:1
+26 SET FBC("ENT")=FBC("ENT")+1
+27 ; calculate % complete
SET FBC("%")=FBC("ENT")*100/FBC("TOT")
+28 ; check if status bar should be updated
+29 IF FBC("%")>FBC("UPD")
Begin DoDot:2
+30 ; update status bar
DO UPDATE^XPDID(FBC("ENT"))
+31 ; increase update criteria by 5%
SET FBC("UPD")=FBC("UPD")+5
End DoDot:2
+32 SET DA=0
FOR
SET DA=$ORDER(^FB(162.96,DA(1),"CY",DA))
if 'DA
QUIT
Begin DoDot:2
+33 SET FBYR=$PIECE($GET(^FB(162.96,DA(1),"CY",DA,0)),U)
+34 IF FBYR<FBYRC
SET DIK="^FB(162.96,"_DA(1)_",""CY"","
DO ^DIK
End DoDot:2
End DoDot:1
+35 ;
+36 ; init variables
+37 ; total # of entries to process
SET FBC("TOT")=$PIECE($GET(^FB(162.97,0)),U,4)
+38 ; avoid divide by zero error
IF FBC("TOT")=0
SET FBC("TOT")=1
+39 ; count of evaluated entries
SET FBC("ENT")=0
+40 ; set total for status bar
SET XPDIDTOT=FBC("TOT")
+41 ; initial % required to update status bar
SET FBC("UPD")=5
+42 DO MES^XPDUTL(" from file 162.97...")
+43 ; delete 162.97 data (CPT RVU) prior to year FBYRC
+44 KILL DA
SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FB(162.97,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:1
+45 SET FBC("ENT")=FBC("ENT")+1
+46 ; calculate % complete
SET FBC("%")=FBC("ENT")*100/FBC("TOT")
+47 ; check if status bar should be updated
+48 IF FBC("%")>FBC("UPD")
Begin DoDot:2
+49 ; update status bar
DO UPDATE^XPDID(FBC("ENT"))
+50 ; increase update criteria by 5%
SET FBC("UPD")=FBC("UPD")+5
End DoDot:2
+51 SET DA=0
FOR
SET DA=$ORDER(^FB(162.97,DA(1),"CY",DA))
if 'DA
QUIT
Begin DoDot:2
+52 SET FBYR=$PIECE($GET(^FB(162.97,DA(1),"CY",DA,0)),U)
+53 IF FBYR<FBYRC
SET DIK="^FB(162.97,"_DA(1)_",""CY"","
DO ^DIK
End DoDot:2
End DoDot:1
+54 ;
+55 ; delete 162.98 data (MOD LEVEL TABLE) prior to year FBYRC
+56 DO MES^XPDUTL(" from file 162.98...")
+57 KILL DA
SET DIK="^FB(162.98,"
SET FBMT=""
+58 FOR
SET FBMT=$ORDER(^FB(162.98,"B",FBMT))
if FBMT=""!($PIECE(FBMT,"-")'<FBYRC)
QUIT
Begin DoDot:1
+59 SET DA=0
FOR
SET DA=$ORDER(^FB(162.98,"B",FBMT,DA))
if 'DA
QUIT
DO ^DIK
End DoDot:1
+60 ;
+61 ; delete 162.99 data (CONVERSION FACTOR) prior to year FBYRC
+62 DO MES^XPDUTL(" from file 162.99...")
+63 KILL DA
SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FB(162.99,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:1
+64 SET DA=0
FOR
SET DA=$ORDER(^FB(162.99,DA(1),"CY",DA))
if 'DA
QUIT
Begin DoDot:2
+65 SET FBYR=$PIECE($GET(^FB(162.99,DA(1),"CY",DA,0)),U)
+66 IF FBYR<FBYRC
SET DIK="^FB(162.99,"_DA(1)_",""CY"","
DO ^DIK
End DoDot:2
End DoDot:1
+67 ;
+68 DO MES^XPDUTL(" Purge completed.")
+69 QUIT
+70 ;
MOD ; Move CPT Modifier data (post-install)
+1 ;
+2 ; If field 39 not CPT MODIFER then already done
+3 IF $$GET1^DID(162.03,39,"","LABEL")'="CPT MODIFIER"
Begin DoDot:1
+4 DO BMES^XPDUTL(" CPT MODIFIER data already moved. Skipping step.")
End DoDot:1
QUIT
+5 ;
+6 ; loop through file 162 - move data from 39 into new multiple
+7 DO BMES^XPDUTL(" Moving CPT MODIFIER data in file 162...")
+8 ; init variables
+9 ; total # of patients to process
SET FBC("TOT")=$PIECE($GET(^FBAAC(0)),U,4)
+10 ; avoid divide by zero error
IF FBC("TOT")=0
SET FBC("TOT")=1
+11 ; count of evaluated patients
SET FBC("PAT")=0
+12 ; count of modifiers moved
SET FBC("MOD")=0
+13 ; set total for status bar
SET XPDIDTOT=FBC("TOT")
+14 ; initial % required to update status bar
SET FBC("UPD")=5
+15 ; loop thru patients
+16 SET FBD0=0
FOR
SET FBD0=$ORDER(^FBAAC(FBD0))
if 'FBD0
QUIT
Begin DoDot:1
+17 SET FBC("PAT")=FBC("PAT")+1
+18 ; calculate % complete
SET FBC("%")=FBC("PAT")*100/FBC("TOT")
+19 ; check if status bar should be updated
+20 IF FBC("%")>FBC("UPD")
Begin DoDot:2
+21 ; update status bar
DO UPDATE^XPDID(FBC("PAT"))
+22 ; increase update criteria by 5%
SET FBC("UPD")=FBC("UPD")+5
End DoDot:2
+23 ; loop thru vendors
+24 SET FBD1=0
FOR
SET FBD1=$ORDER(^FBAAC(FBD0,1,FBD1))
if 'FBD1
QUIT
Begin DoDot:2
+25 ; loop thru initial treatment date
+26 SET FBD2=0
FOR
SET FBD2=$ORDER(^FBAAC(FBD0,1,FBD1,1,FBD2))
if 'FBD2
QUIT
Begin DoDot:3
+27 ; loop thru service provided
+28 SET FBD3=0
+29 FOR
SET FBD3=$ORDER(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3))
if 'FBD3
QUIT
Begin DoDot:4
+30 ; get single valued modifier
+31 SET FBMOD=$PIECE($GET(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,2)),U,7)
+32 ; nothing to move
if 'FBMOD
QUIT
+33 ; unexpected
if $ORDER(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M",0))
QUIT
+34 ; put modifier in multiple field
+35 SET ^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M",0)="^162.06P^1^1"
+36 SET ^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M",1,0)=FBMOD
+37 SET ^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,"M","B",FBMOD,1)=""
+38 ; delete modifier from old location
+39 SET $PIECE(^FBAAC(FBD0,1,FBD1,1,FBD2,1,FBD3,2),U,7)=""
+40 SET FBC("MOD")=FBC("MOD")+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 ; delete field 39 from data dictionary
+43 SET DIK="^DD(162.03,"
SET DA=39
SET DA(1)=162.03
DO ^DIK
+44 ;
+45 ; report results
+46 DO MES^XPDUTL(" "_FBC("PAT")_" FEE BASIS PATIENTs were evaluated.")
+47 DO MES^XPDUTL(" "_FBC("MOD")_" CPT Modifiers were moved.")
+48 QUIT
+49 ;
VPC ; Add Vendor Participation Codes (post-install)
+1 ; NOTE: This section will not be performed by patch FB*3.5*4 and
+2 ; label has been VPC removed from the post-install call backs.
+3 ; quit statement added to prevent execution of code
QUIT
+4 NEW FBFDA,FBFDAIEN,FBI,FBX,FBY0
+5 DO BMES^XPDUTL(" Adding new participation codes...")
+6 FOR FBI=1:1
SET FBX=$PIECE($TEXT(VPCT+FBI),";",3)
if $PIECE(FBX,U)=""
QUIT
Begin DoDot:1
+7 SET FBY0=$GET(^FBAA(161.81,$PIECE(FBX,U),0))
+8 ; already there
IF $PIECE(FBY0,U)]""
IF $PIECE(FBY0,U)=$PIECE(FBX,U,2)
QUIT
+9 ; unexpected value
IF $PIECE(FBY0,U)]""
IF $PIECE(FBY0,U)'=$PIECE(FBX,U,2)
Begin DoDot:2
+10 DO MES^XPDUTL(" Error adding "_$PIECE(FBX,U,2)_" ("_$PIECE(FBX,U,3)_")")
+11 DO MES^XPDUTL(" because local '"_$PIECE(FBY0,U)_"' is in it's place.")
End DoDot:2
QUIT
+12 SET FBFDA(161.81,"+"_$PIECE(FBX,U)_",",.01)=$PIECE(FBX,U,2)
+13 SET FBFDA(161.81,"+"_$PIECE(FBX,U)_",",1)=$PIECE(FBX,U,3)
+14 SET FBFDAIEN($PIECE(FBX,U))=$PIECE(FBX,U)
End DoDot:1
+15 IF $DATA(FBFDA)
DO UPDATE^DIE("E","FBFDA","FBFDAIEN")
DO MSG^DIALOG()
+16 QUIT
VPCT ;;Participation Code Data (internal entry number^#.01 field^#1 field)
+1 ;;15^PHYSICAL/OCCUPATIONAL THERAPIST^15;
+2 ;;16^PHYSICIAN ASSISTANT^16;
+3 ;;17^NURSE PRACTITIONER^17;
+4 ;;18^CLINICAL NURSE SPECIALIST^18;
+5 ;;19^CERTIFIED REGISTERED NURSE ANESTHETIST^19;
+6 ;;20^NURSE MIDWIFE^20;
+7 ;;21^CLINICAL PSYCHOLOGIST^21;
+8 ;;22^CLINICAL SOCIAL WORKER^22;
+9 ;;; end of vendor participation codes
+10 ;FBXIP4
