Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXCFL

IBARXCFL.m

Go to the documentation of this file.
  1. IBARXCFL ;ALB/MKN-CERNER RXCOPAY CHECK IF CERNER-CONVERTED ;30 Dec 2020
  1. ;;2.0;INTEGRATED BILLING;**676**;21-MAR-94;Build 34
  1. ;
  1. ;ICR # Supports
  1. ; 2990 TFL^VAFCTFU2
  1. ;10112 $$SITE^VASITE
  1. ;
  1. 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
  1. ;CCR is new parameter that determines what entries are to be left in the new IBZ array
  1. ; CCR=0 Remove all Converted sites and Cerner entry
  1. ; CCR=1 Remove all Converted sites Leave Cerner entry
  1. ; CCR=2 Leave Converted sites Leave Cerner entry
  1. ; CCR=3 Leave Converted remove Cerner
  1. ;
  1. N IBKEY
  1. I $G(CCR)="" S CCR=3
  1. S IBKEY=DFN_U_"PI"_U_"USVHA"_U_$P($$SITE^VASITE,"^",3)
  1. D TFL^VAFCTFU2(.IBTFL,IBKEY)
  1. Q:-$G(IBTFL(1))=1 0 ;This function quits if the array returns a -1
  1. N IBX ;TRANSFER ARRAY FOR REBUILDING IBTFL TO LOOK LIKE IBZ
  1. ;
  1. ;REMOVE NON-PI SITES AND NON-USVHA SITES FROM IBTFL
  1. N CNT,CNTI,CNTT,IDTYPE,IDAA,SITEID,IDSTATUS,TFLDT,TFLNUM,STYPE,SITEIEN,SITENM
  1. S CNTI=0,CNTT=0
  1. F S CNTI=$O(IBTFL(CNTI)) Q:CNTI="" D
  1. . ;PIECE APART THE ELEMENTS OF THE ID
  1. . S IDTYPE=$P(IBTFL(CNTI),"^",2),IDAA=$P(IBTFL(CNTI),"^",3)
  1. . S SITEID=$P(IBTFL(CNTI),"^",4),IDSTATUS=$P(IBTFL(CNTI),"^",5)
  1. . ;Values set Now kill all entries we don't want
  1. . I SITEID["742V1"!(SITEID["741") K IBTFL(CNTI) Q
  1. . I IDTYPE'="PI" K IBTFL(CNTI) Q
  1. . I IDAA'="USVHA" K IBTFL(CNTI) Q
  1. . I IDSTATUS="C" D
  1. . . I CCR>1 Q
  1. . . K IBTFL(CNTI)
  1. . Q:$G(IBTFL(CNTI))=""
  1. . I SITEID[200 D
  1. . . I SITEID'["CRNR" K IBTFL(CNTI) Q
  1. . . I CCR=1!(CCR=2) Q
  1. . . K IBTFL(CNTI)
  1. . Q:$G(IBTFL(CNTI))=""
  1. . S CNTT=CNTT+1
  1. . ;Rebuld the VAFCTFU1 array in the format used by VAFCTFU2 utility
  1. . S SITEIEN=$O(^DIC(4,"D",SITEID,0))
  1. . S SITENM=$$GET1^DIQ(4,SITEIEN_",",.01,"E")
  1. . S STYPE=$$GET1^DIQ(4,SITEIEN_",",13,"E")
  1. . D MATCH(.IBZ,CNTI) ;See if you can match this entry to the VAFCTFU1 arry for two values
  1. . S IBX(CNTT)=SITEID_"^"_SITENM_"^"_TFLDT_"^"_TFLNUM_"^"_STYPE
  1. ;Now we have an IBX array that is built from VAFCTFU2 but with data from VAFCTFU1 replace IBZ
  1. K IBZ,IBTFL
  1. M IBZ=IBX
  1. K IBX
  1. S:$D(IBZ) IBZ=1
  1. ;Send new IBZ back
  1. Q IBZ
  1. ;
  1. 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
  1. S TFLDT="",TFLNUM=""
  1. N CNTM,QUIT
  1. S CNTM=0,QUIT=0
  1. F S CNTM=$O(IBZ(CNTM)) Q:CNTM=""!(QUIT) D
  1. . Q:SITEID'=$P(IBZ(CNTM),"^",1)
  1. . S TFLDT=$P(IBZ(CNTM),"^",3)
  1. . S TFLNUM=$P(IBZ(CNTM),"^",4)
  1. . S QUIT=1
  1. . Q
  1. Q
  1. ;