- IBCRHBS3 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC 2+) PARSE ; 10-OCT-03
- ;;2.0;INTEGRATED BILLING;**245,458**;21-MAR-94;Build 4
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; IBFILE, IBFLINE, COLUMNS required and VERS expected on entry
- ; Parse lines from the Host Files and place them in XTMP.
- ; Direct copy of fields, number of fields and placement not changed, but cleaned up (spaces, $, commas removed)
- ;
- A ; Inpatient Facility DRG Charges: process a single line, parse out into individual fields and store in XTMP
- ;
- N LINE,IBI,IBPIECE,IBITYPE,IBCODE,IBXTMP,IBXIFN S IBXTMP="IBCR RC A" I ('$G(COLUMNS))!($G(IBFLINE)="") Q
- ;
- S LINE="" F IBI=1:1:COLUMNS S IBPIECE=$$P(IBFLINE,IBI),IBPIECE=$$STRIP(IBPIECE) S LINE=LINE_IBPIECE_U
- ;
- S IBITYPE=$P(LINE,U,2) I IBITYPE'="DRG",IBITYPE'="SNF" Q
- S IBCODE=$P(LINE,U,1) I IBCODE'?3N Q
- ;
- S IBXIFN=$$SET(IBFILE,IBXTMP,LINE)
- ;
- Q
- ;
- B ; Outpatient Facility CPT Charges: process a single line, parse out into individual fields and store in XTMP
- ;
- N LINE,IBI,IBPIECE,IBITYPE,IBCODE,IBXTMP,IBXIFN S IBXTMP="IBCR RC B" I ('$G(COLUMNS))!($G(IBFLINE)="") Q
- ;
- S LINE="" F IBI=1:1:COLUMNS S IBPIECE=$$P(IBFLINE,IBI),IBPIECE=$$STRIP(IBPIECE) S LINE=LINE_IBPIECE_U
- ;
- S IBITYPE=$P(LINE,U,2) I IBITYPE'="CPT",IBITYPE'="HCPCS",IBITYPE'="PHOSP" Q
- S IBCODE=$P(LINE,U,1) I IBCODE'?5UN Q
- ;
- S IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBCODE)
- ;
- Q
- ;
- C ; Physician CPT Charges: process a single line, parse out into individual fields and store in XTMP
- ;
- N LINE,IBI,IBPIECE,IBITYPE,IBCODE,IBXTMP,IBXIFN S IBXTMP="IBCR RC C" I ('$G(COLUMNS))!($G(IBFLINE)="") Q
- ;
- S LINE="" F IBI=1:1:COLUMNS S IBPIECE=$$P(IBFLINE,IBI),IBPIECE=$$STRIP(IBPIECE) S LINE=LINE_IBPIECE_U
- ;
- S IBITYPE=$P(LINE,U,2) I IBITYPE'="CPT",IBITYPE'="HCPCS" Q
- S IBCODE=$P(LINE,U,1) I IBCODE'?5UN Q
- ;
- S IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBCODE)
- ;
- Q
- ;
- D ; Service Category Codes: process a single line, parse out into individual fields and store in XTMP
- ;
- N LINE,IBI,IBPIECE,IBCODE,IBXTMP,IBXIFN S IBXTMP="IBCR RC D" I ('$G(COLUMNS))!($G(IBFLINE)="") Q
- ;
- S LINE="" F IBI=1:1:COLUMNS S IBPIECE=$$P(IBFLINE,IBI),IBPIECE=$$STRIP(IBPIECE) S LINE=LINE_IBPIECE_U
- ;
- S IBCODE=$P(LINE,U,1) I 'IBCODE Q
- ;
- S IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBCODE)
- ;
- Q
- ;
- E ; Area Factors: process a single line, parse out into individual fields and store in XTMP
- ;
- N LINE,IBI,IBPIECE,IBZIP,IBXTMP,IBXIFN S IBXTMP="IBCR RC E" I ('$G(COLUMNS))!($G(IBFLINE)="") Q
- ;
- S LINE="" F IBI=1:1:COLUMNS S IBPIECE=$$P(IBFLINE,IBI),IBPIECE=$$STRIP(IBPIECE) S LINE=LINE_IBPIECE_U
- ;
- S IBZIP=$P(LINE,U,1) I IBZIP'?3N Q
- ;
- S IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBZIP) D SETSITE(IBZIP)
- ;
- Q
- ;
- F ; Zip Codes and Sites: process a single line, parse out into individual fields and store in XTMP
- ;
- N LINE,IBSITE,IBZIP,IBNM,IBSTYPE,IBXTMP,IBXIFN S IBXTMP="IBCR RC F" I ('$G(COLUMNS))!($G(IBFLINE)="") Q
- ;
- S IBSITE=$$P(IBFLINE,1),IBSITE=$$STRIP(IBSITE) I IBSITE'?3N0.4UN Q ; division number
- S IBNM=$$P(IBFLINE,2) ; facility name
- S IBZIP=$$P(IBFLINE,3),IBZIP=$$STRIP(IBZIP) I IBZIP'?3N Q ; 3-digit zip code
- S IBSTYPE=$$P(IBFLINE,4),IBSTYPE=$$STRIP(IBSTYPE) I 'IBSTYPE Q ; facility type
- ;
- S LINE=IBSITE_U_IBNM_U_IBZIP_U_IBSTYPE
- ;
- S IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBZIP) D SETSITE(IBZIP,IBSITE,IBNM,IBSTYPE)
- ;
- Q
- ;
- ;
- ;
- SETHDR(IBFILE,IBXRF1) ; set up header for XTMP file
- ;
- N IBX S IBX=IBFILE_" RC v"_$G(VERS)_" Host File Upload, "_$P($$HTE^XLFDT($H,2),":",1,2)_" by "_$P($G(^VA(200,+$G(DUZ),0)),U,1)
- S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX_U_0_U_0
- I IBXRF1="IBCR RC SITE" S ^XTMP(IBXRF1,"VERSION")=$G(VERS),^XTMP(IBXRF1,"VERSION INACTIVE")=$$VERSEDT^IBCRHBRV($G(VERS))
- Q
- ;
- SET(IBFILE,IBXRF1,LINE,ACROSS) ; set data parsed from host file to XTMP
- N IBX,IBK
- S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR(IBFILE,IBXRF1)
- S IBK=+$P(IBX,U,5)+1,$P(^XTMP(IBXRF1,0),U,5)=IBK
- S ^XTMP(IBXRF1,IBK)=LINE
- ;
- I $G(ACROSS)'="" S ^XTMP(IBXRF1,"A",ACROSS,IBK)=""
- Q IBK
- ;
- ;
- SETSITE(ZIP,SITE,NAME,TYPE) ; set up site entries and cross references
- ; the Area Factor File (E) has entries not associated with a VA site, Site/Zip file (F) only has valid VA sites
- ; therefore there are many zip codes (E) with no assigned division but that must be available for selection
- ; these unassigned zip codes are passed in with only Zip defined,
- ; a temporary Division Number '9yyXy' and Name 'ZIP Code ZZZ' is created, Type is blank to be set by user
- ; if the zip is '000' then these are the Nation wide charges and the corresponding Division Number/Name is used
- N IBXRF1,LINE,IBXIFN
- ;
- I ZIP="000" S SITE="999",NAME="NATIONWIDE AVERAGE",TYPE=""
- I $G(SITE)="" S SITE="9"_$E(ZIP,1,2)_"X"_$E(ZIP,3),NAME="ZIP Code "_ZIP,TYPE=""
- I $O(^XTMP("IBCR RC SITE","C",SITE_" ",0)) W !!,"Site Error: Dupicate Site Numbers: ",SITE
- ;
- S IBXRF1="IBCR RC SITE"
- S LINE=SITE_U_NAME_U_ZIP_U_TYPE
- ;
- S IBXIFN=$$SET(IBXRF1,IBXRF1,LINE)
- ;
- I $G(NAME)'="" S ^XTMP(IBXRF1,"B",NAME,IBXIFN)=""
- I $G(ZIP)'="" S ZIP="ZC "_ZIP S ^XTMP(IBXRF1,"B",ZIP,IBXIFN)=""
- I $G(SITE)'="" S SITE=SITE_" " S ^XTMP(IBXRF1,"B",SITE,IBXIFN)="",^XTMP(IBXRF1,"C",SITE,IBXIFN)=""
- ;
- Q
- ;
- ;
- STRIP(IBVAL) ; strip blanks, $, and commas
- N IBI,IBY,IBX S IBY=""
- F IBI=1:1:200 S IBX=$E(IBVAL,IBI) Q:IBX="" I IBX'=" ",IBX'=",",IBX'="$" S IBY=IBY_IBX
- Q IBY
- ;
- ;
- P(LINE,P) ; parse the line and return the piece requested (replaces $P since may be two dilimiters)
- ; the pieces are delimited by a comma, any piece that includes a comma within the text is surrounded by quotes
- N I,U1,U2,PC S U1=",",U2="""",PC=""
- ;
- F I=1:1:P D
- . I $E(LINE)=U2 S LINE=$E(LINE,2,9999),PC=$P(LINE,U2,1),LINE=$P(LINE,U2_U1,2,9999) Q
- . ;
- . S PC=$P(LINE,U1,1),LINE=$P(LINE,U1,2,9999)
- ;
- Q PC
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBS3 5886 printed Feb 18, 2025@23:45:49 Page 2
- IBCRHBS3 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC 2+) PARSE ; 10-OCT-03
- +1 ;;2.0;INTEGRATED BILLING;**245,458**;21-MAR-94;Build 4
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; IBFILE, IBFLINE, COLUMNS required and VERS expected on entry
- +5 ; Parse lines from the Host Files and place them in XTMP.
- +6 ; Direct copy of fields, number of fields and placement not changed, but cleaned up (spaces, $, commas removed)
- +7 ;
- A ; Inpatient Facility DRG Charges: process a single line, parse out into individual fields and store in XTMP
- +1 ;
- +2 NEW LINE,IBI,IBPIECE,IBITYPE,IBCODE,IBXTMP,IBXIFN
- SET IBXTMP="IBCR RC A"
- IF ('$GET(COLUMNS))!($GET(IBFLINE)="")
- QUIT
- +3 ;
- +4 SET LINE=""
- FOR IBI=1:1:COLUMNS
- SET IBPIECE=$$P(IBFLINE,IBI)
- SET IBPIECE=$$STRIP(IBPIECE)
- SET LINE=LINE_IBPIECE_U
- +5 ;
- +6 SET IBITYPE=$PIECE(LINE,U,2)
- IF IBITYPE'="DRG"
- IF IBITYPE'="SNF"
- QUIT
- +7 SET IBCODE=$PIECE(LINE,U,1)
- IF IBCODE'?3N
- QUIT
- +8 ;
- +9 SET IBXIFN=$$SET(IBFILE,IBXTMP,LINE)
- +10 ;
- +11 QUIT
- +12 ;
- B ; Outpatient Facility CPT Charges: process a single line, parse out into individual fields and store in XTMP
- +1 ;
- +2 NEW LINE,IBI,IBPIECE,IBITYPE,IBCODE,IBXTMP,IBXIFN
- SET IBXTMP="IBCR RC B"
- IF ('$GET(COLUMNS))!($GET(IBFLINE)="")
- QUIT
- +3 ;
- +4 SET LINE=""
- FOR IBI=1:1:COLUMNS
- SET IBPIECE=$$P(IBFLINE,IBI)
- SET IBPIECE=$$STRIP(IBPIECE)
- SET LINE=LINE_IBPIECE_U
- +5 ;
- +6 SET IBITYPE=$PIECE(LINE,U,2)
- IF IBITYPE'="CPT"
- IF IBITYPE'="HCPCS"
- IF IBITYPE'="PHOSP"
- QUIT
- +7 SET IBCODE=$PIECE(LINE,U,1)
- IF IBCODE'?5UN
- QUIT
- +8 ;
- +9 SET IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBCODE)
- +10 ;
- +11 QUIT
- +12 ;
- C ; Physician CPT Charges: process a single line, parse out into individual fields and store in XTMP
- +1 ;
- +2 NEW LINE,IBI,IBPIECE,IBITYPE,IBCODE,IBXTMP,IBXIFN
- SET IBXTMP="IBCR RC C"
- IF ('$GET(COLUMNS))!($GET(IBFLINE)="")
- QUIT
- +3 ;
- +4 SET LINE=""
- FOR IBI=1:1:COLUMNS
- SET IBPIECE=$$P(IBFLINE,IBI)
- SET IBPIECE=$$STRIP(IBPIECE)
- SET LINE=LINE_IBPIECE_U
- +5 ;
- +6 SET IBITYPE=$PIECE(LINE,U,2)
- IF IBITYPE'="CPT"
- IF IBITYPE'="HCPCS"
- QUIT
- +7 SET IBCODE=$PIECE(LINE,U,1)
- IF IBCODE'?5UN
- QUIT
- +8 ;
- +9 SET IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBCODE)
- +10 ;
- +11 QUIT
- +12 ;
- D ; Service Category Codes: process a single line, parse out into individual fields and store in XTMP
- +1 ;
- +2 NEW LINE,IBI,IBPIECE,IBCODE,IBXTMP,IBXIFN
- SET IBXTMP="IBCR RC D"
- IF ('$GET(COLUMNS))!($GET(IBFLINE)="")
- QUIT
- +3 ;
- +4 SET LINE=""
- FOR IBI=1:1:COLUMNS
- SET IBPIECE=$$P(IBFLINE,IBI)
- SET IBPIECE=$$STRIP(IBPIECE)
- SET LINE=LINE_IBPIECE_U
- +5 ;
- +6 SET IBCODE=$PIECE(LINE,U,1)
- IF 'IBCODE
- QUIT
- +7 ;
- +8 SET IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBCODE)
- +9 ;
- +10 QUIT
- +11 ;
- E ; Area Factors: process a single line, parse out into individual fields and store in XTMP
- +1 ;
- +2 NEW LINE,IBI,IBPIECE,IBZIP,IBXTMP,IBXIFN
- SET IBXTMP="IBCR RC E"
- IF ('$GET(COLUMNS))!($GET(IBFLINE)="")
- QUIT
- +3 ;
- +4 SET LINE=""
- FOR IBI=1:1:COLUMNS
- SET IBPIECE=$$P(IBFLINE,IBI)
- SET IBPIECE=$$STRIP(IBPIECE)
- SET LINE=LINE_IBPIECE_U
- +5 ;
- +6 SET IBZIP=$PIECE(LINE,U,1)
- IF IBZIP'?3N
- QUIT
- +7 ;
- +8 SET IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBZIP)
- DO SETSITE(IBZIP)
- +9 ;
- +10 QUIT
- +11 ;
- F ; Zip Codes and Sites: process a single line, parse out into individual fields and store in XTMP
- +1 ;
- +2 NEW LINE,IBSITE,IBZIP,IBNM,IBSTYPE,IBXTMP,IBXIFN
- SET IBXTMP="IBCR RC F"
- IF ('$GET(COLUMNS))!($GET(IBFLINE)="")
- QUIT
- +3 ;
- +4 ; division number
- SET IBSITE=$$P(IBFLINE,1)
- SET IBSITE=$$STRIP(IBSITE)
- IF IBSITE'?3N0.4UN
- QUIT
- +5 ; facility name
- SET IBNM=$$P(IBFLINE,2)
- +6 ; 3-digit zip code
- SET IBZIP=$$P(IBFLINE,3)
- SET IBZIP=$$STRIP(IBZIP)
- IF IBZIP'?3N
- QUIT
- +7 ; facility type
- SET IBSTYPE=$$P(IBFLINE,4)
- SET IBSTYPE=$$STRIP(IBSTYPE)
- IF 'IBSTYPE
- QUIT
- +8 ;
- +9 SET LINE=IBSITE_U_IBNM_U_IBZIP_U_IBSTYPE
- +10 ;
- +11 SET IBXIFN=$$SET(IBFILE,IBXTMP,LINE,IBZIP)
- DO SETSITE(IBZIP,IBSITE,IBNM,IBSTYPE)
- +12 ;
- +13 QUIT
- +14 ;
- +15 ;
- +16 ;
- SETHDR(IBFILE,IBXRF1) ; set up header for XTMP file
- +1 ;
- +2 NEW IBX
- SET IBX=IBFILE_" RC v"_$GET(VERS)_" Host File Upload, "_$PIECE($$HTE^XLFDT($HOROLOG,2),":",1,2)_" by "_$PIECE($GET(^VA(200,+$GET(DUZ),0)),U,1)
- +3 SET ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX_U_0_U_0
- +4 IF IBXRF1="IBCR RC SITE"
- SET ^XTMP(IBXRF1,"VERSION")=$GET(VERS)
- SET ^XTMP(IBXRF1,"VERSION INACTIVE")=$$VERSEDT^IBCRHBRV($GET(VERS))
- +5 QUIT
- +6 ;
- SET(IBFILE,IBXRF1,LINE,ACROSS) ; set data parsed from host file to XTMP
- +1 NEW IBX,IBK
- +2 SET IBX=$GET(^XTMP(IBXRF1,0))
- IF IBX=""
- DO SETHDR(IBFILE,IBXRF1)
- +3 SET IBK=+$PIECE(IBX,U,5)+1
- SET $PIECE(^XTMP(IBXRF1,0),U,5)=IBK
- +4 SET ^XTMP(IBXRF1,IBK)=LINE
- +5 ;
- +6 IF $GET(ACROSS)'=""
- SET ^XTMP(IBXRF1,"A",ACROSS,IBK)=""
- +7 QUIT IBK
- +8 ;
- +9 ;
- SETSITE(ZIP,SITE,NAME,TYPE) ; set up site entries and cross references
- +1 ; the Area Factor File (E) has entries not associated with a VA site, Site/Zip file (F) only has valid VA sites
- +2 ; therefore there are many zip codes (E) with no assigned division but that must be available for selection
- +3 ; these unassigned zip codes are passed in with only Zip defined,
- +4 ; a temporary Division Number '9yyXy' and Name 'ZIP Code ZZZ' is created, Type is blank to be set by user
- +5 ; if the zip is '000' then these are the Nation wide charges and the corresponding Division Number/Name is used
- +6 NEW IBXRF1,LINE,IBXIFN
- +7 ;
- +8 IF ZIP="000"
- SET SITE="999"
- SET NAME="NATIONWIDE AVERAGE"
- SET TYPE=""
- +9 IF $GET(SITE)=""
- SET SITE="9"_$EXTRACT(ZIP,1,2)_"X"_$EXTRACT(ZIP,3)
- SET NAME="ZIP Code "_ZIP
- SET TYPE=""
- +10 IF $ORDER(^XTMP("IBCR RC SITE","C",SITE_" ",0))
- WRITE !!,"Site Error: Dupicate Site Numbers: ",SITE
- +11 ;
- +12 SET IBXRF1="IBCR RC SITE"
- +13 SET LINE=SITE_U_NAME_U_ZIP_U_TYPE
- +14 ;
- +15 SET IBXIFN=$$SET(IBXRF1,IBXRF1,LINE)
- +16 ;
- +17 IF $GET(NAME)'=""
- SET ^XTMP(IBXRF1,"B",NAME,IBXIFN)=""
- +18 IF $GET(ZIP)'=""
- SET ZIP="ZC "_ZIP
- SET ^XTMP(IBXRF1,"B",ZIP,IBXIFN)=""
- +19 IF $GET(SITE)'=""
- SET SITE=SITE_" "
- SET ^XTMP(IBXRF1,"B",SITE,IBXIFN)=""
- SET ^XTMP(IBXRF1,"C",SITE,IBXIFN)=""
- +20 ;
- +21 QUIT
- +22 ;
- +23 ;
- STRIP(IBVAL) ; strip blanks, $, and commas
- +1 NEW IBI,IBY,IBX
- SET IBY=""
- +2 FOR IBI=1:1:200
- SET IBX=$EXTRACT(IBVAL,IBI)
- if IBX=""
- QUIT
- IF IBX'=" "
- IF IBX'=","
- IF IBX'="$"
- SET IBY=IBY_IBX
- +3 QUIT IBY
- +4 ;
- +5 ;
- P(LINE,P) ; parse the line and return the piece requested (replaces $P since may be two dilimiters)
- +1 ; the pieces are delimited by a comma, any piece that includes a comma within the text is surrounded by quotes
- +2 NEW I,U1,U2,PC
- SET U1=","
- SET U2=""""
- SET PC=""
- +3 ;
- +4 FOR I=1:1:P
- Begin DoDot:1
- +5 IF $EXTRACT(LINE)=U2
- SET LINE=$EXTRACT(LINE,2,9999)
- SET PC=$PIECE(LINE,U2,1)
- SET LINE=$PIECE(LINE,U2_U1,2,9999)
- QUIT
- +6 ;
- +7 SET PC=$PIECE(LINE,U1,1)
- SET LINE=$PIECE(LINE,U1,2,9999)
- End DoDot:1
- +8 ;
- +9 QUIT PC