IBARXCFL ;ALB/MKN-CERNER RXCOPAY CHECK IF CERNER-CONVERTED ;30 Dec 2020
;;2.0;INTEGRATED BILLING;**676**;21-MAR-94;Build 34
;
;ICR # Supports
; 2990 TFL^VAFCTFU2
;10112 $$SITE^VASITE
;
TFL(IBZ,DFN,CCR) ;Call to ensure the Cerner and converted site entries are handled
;Returns a modified IBZ array. VAFCTFU2 is the new source of truth for Treating Fac List
;CCR is new parameter that determines what entries are to be left in the new IBZ array
; CCR=0 Remove all Converted sites and Cerner entry
; CCR=1 Remove all Converted sites Leave Cerner entry
; CCR=2 Leave Converted sites Leave Cerner entry
; CCR=3 Leave Converted remove Cerner
;
N IBKEY
I $G(CCR)="" S CCR=3
S IBKEY=DFN_U_"PI"_U_"USVHA"_U_$P($$SITE^VASITE,"^",3)
D TFL^VAFCTFU2(.IBTFL,IBKEY)
Q:-$G(IBTFL(1))=1 0 ;This function quits if the array returns a -1
N IBX ;TRANSFER ARRAY FOR REBUILDING IBTFL TO LOOK LIKE IBZ
;
;REMOVE NON-PI SITES AND NON-USVHA SITES FROM IBTFL
N CNT,CNTI,CNTT,IDTYPE,IDAA,SITEID,IDSTATUS,TFLDT,TFLNUM,STYPE,SITEIEN,SITENM
S CNTI=0,CNTT=0
F S CNTI=$O(IBTFL(CNTI)) Q:CNTI="" D
. ;PIECE APART THE ELEMENTS OF THE ID
. S IDTYPE=$P(IBTFL(CNTI),"^",2),IDAA=$P(IBTFL(CNTI),"^",3)
. S SITEID=$P(IBTFL(CNTI),"^",4),IDSTATUS=$P(IBTFL(CNTI),"^",5)
. ;Values set Now kill all entries we don't want
. I SITEID["742V1"!(SITEID["741") K IBTFL(CNTI) Q
. I IDTYPE'="PI" K IBTFL(CNTI) Q
. I IDAA'="USVHA" K IBTFL(CNTI) Q
. I IDSTATUS="C" D
. . I CCR>1 Q
. . K IBTFL(CNTI)
. Q:$G(IBTFL(CNTI))=""
. I SITEID[200 D
. . I SITEID'["CRNR" K IBTFL(CNTI) Q
. . I CCR=1!(CCR=2) Q
. . K IBTFL(CNTI)
. Q:$G(IBTFL(CNTI))=""
. S CNTT=CNTT+1
. ;Rebuld the VAFCTFU1 array in the format used by VAFCTFU2 utility
. S SITEIEN=$O(^DIC(4,"D",SITEID,0))
. S SITENM=$$GET1^DIQ(4,SITEIEN_",",.01,"E")
. S STYPE=$$GET1^DIQ(4,SITEIEN_",",13,"E")
. D MATCH(.IBZ,CNTI) ;See if you can match this entry to the VAFCTFU1 arry for two values
. S IBX(CNTT)=SITEID_"^"_SITENM_"^"_TFLDT_"^"_TFLNUM_"^"_STYPE
;Now we have an IBX array that is built from VAFCTFU2 but with data from VAFCTFU1 replace IBZ
K IBZ,IBTFL
M IBZ=IBX
K IBX
S:$D(IBZ) IBZ=1
;Send new IBZ back
Q IBZ
;
MATCH(IBZ,CNTI) ;The VAFCTFU2 array lacks two entries from the 391.91 file.
;Attempt to match to the VAFCTFU2 array and use the 3rd 4th and 5th piece from the TFL
S TFLDT="",TFLNUM=""
N CNTM,QUIT
S CNTM=0,QUIT=0
F S CNTM=$O(IBZ(CNTM)) Q:CNTM=""!(QUIT) D
. Q:SITEID'=$P(IBZ(CNTM),"^",1)
. S TFLDT=$P(IBZ(CNTM),"^",3)
. S TFLNUM=$P(IBZ(CNTM),"^",4)
. S QUIT=1
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXCFL 2650 printed Sep 23, 2025@19:43:11 Page 2
IBARXCFL ;ALB/MKN-CERNER RXCOPAY CHECK IF CERNER-CONVERTED ;30 Dec 2020
+1 ;;2.0;INTEGRATED BILLING;**676**;21-MAR-94;Build 34
+2 ;
+3 ;ICR # Supports
+4 ; 2990 TFL^VAFCTFU2
+5 ;10112 $$SITE^VASITE
+6 ;
TFL(IBZ,DFN,CCR) ;Call to ensure the Cerner and converted site entries are handled
+1 ;Returns a modified IBZ array. VAFCTFU2 is the new source of truth for Treating Fac List
+2 ;CCR is new parameter that determines what entries are to be left in the new IBZ array
+3 ; CCR=0 Remove all Converted sites and Cerner entry
+4 ; CCR=1 Remove all Converted sites Leave Cerner entry
+5 ; CCR=2 Leave Converted sites Leave Cerner entry
+6 ; CCR=3 Leave Converted remove Cerner
+7 ;
+8 NEW IBKEY
+9 IF $GET(CCR)=""
SET CCR=3
+10 SET IBKEY=DFN_U_"PI"_U_"USVHA"_U_$PIECE($$SITE^VASITE,"^",3)
+11 DO TFL^VAFCTFU2(.IBTFL,IBKEY)
+12 ;This function quits if the array returns a -1
if -$GET(IBTFL(1))=1
QUIT 0
+13 ;TRANSFER ARRAY FOR REBUILDING IBTFL TO LOOK LIKE IBZ
NEW IBX
+14 ;
+15 ;REMOVE NON-PI SITES AND NON-USVHA SITES FROM IBTFL
+16 NEW CNT,CNTI,CNTT,IDTYPE,IDAA,SITEID,IDSTATUS,TFLDT,TFLNUM,STYPE,SITEIEN,SITENM
+17 SET CNTI=0
SET CNTT=0
+18 FOR
SET CNTI=$ORDER(IBTFL(CNTI))
if CNTI=""
QUIT
Begin DoDot:1
+19 ;PIECE APART THE ELEMENTS OF THE ID
+20 SET IDTYPE=$PIECE(IBTFL(CNTI),"^",2)
SET IDAA=$PIECE(IBTFL(CNTI),"^",3)
+21 SET SITEID=$PIECE(IBTFL(CNTI),"^",4)
SET IDSTATUS=$PIECE(IBTFL(CNTI),"^",5)
+22 ;Values set Now kill all entries we don't want
+23 IF SITEID["742V1"!(SITEID["741")
KILL IBTFL(CNTI)
QUIT
+24 IF IDTYPE'="PI"
KILL IBTFL(CNTI)
QUIT
+25 IF IDAA'="USVHA"
KILL IBTFL(CNTI)
QUIT
+26 IF IDSTATUS="C"
Begin DoDot:2
+27 IF CCR>1
QUIT
+28 KILL IBTFL(CNTI)
End DoDot:2
+29 if $GET(IBTFL(CNTI))=""
QUIT
+30 IF SITEID[200
Begin DoDot:2
+31 IF SITEID'["CRNR"
KILL IBTFL(CNTI)
QUIT
+32 IF CCR=1!(CCR=2)
QUIT
+33 KILL IBTFL(CNTI)
End DoDot:2
+34 if $GET(IBTFL(CNTI))=""
QUIT
+35 SET CNTT=CNTT+1
+36 ;Rebuld the VAFCTFU1 array in the format used by VAFCTFU2 utility
+37 SET SITEIEN=$ORDER(^DIC(4,"D",SITEID,0))
+38 SET SITENM=$$GET1^DIQ(4,SITEIEN_",",.01,"E")
+39 SET STYPE=$$GET1^DIQ(4,SITEIEN_",",13,"E")
+40 ;See if you can match this entry to the VAFCTFU1 arry for two values
DO MATCH(.IBZ,CNTI)
+41 SET IBX(CNTT)=SITEID_"^"_SITENM_"^"_TFLDT_"^"_TFLNUM_"^"_STYPE
End DoDot:1
+42 ;Now we have an IBX array that is built from VAFCTFU2 but with data from VAFCTFU1 replace IBZ
+43 KILL IBZ,IBTFL
+44 MERGE IBZ=IBX
+45 KILL IBX
+46 if $DATA(IBZ)
SET IBZ=1
+47 ;Send new IBZ back
+48 QUIT IBZ
+49 ;
MATCH(IBZ,CNTI) ;The VAFCTFU2 array lacks two entries from the 391.91 file.
+1 ;Attempt to match to the VAFCTFU2 array and use the 3rd 4th and 5th piece from the TFL
+2 SET TFLDT=""
SET TFLNUM=""
+3 NEW CNTM,QUIT
+4 SET CNTM=0
SET QUIT=0
+5 FOR
SET CNTM=$ORDER(IBZ(CNTM))
if CNTM=""!(QUIT)
QUIT
Begin DoDot:1
+6 if SITEID'=$PIECE(IBZ(CNTM),"^",1)
QUIT
+7 SET TFLDT=$PIECE(IBZ(CNTM),"^",3)
+8 SET TFLNUM=$PIECE(IBZ(CNTM),"^",4)
+9 SET QUIT=1
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
