- 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 Feb 18, 2025@23:33:22 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 ;