IBCRHBC3 ;ALB/ARH - RATES: UPLOAD HOST FILES (CMAC 2005+) ; 10-MAY-2005
;;2.0;INTEGRATED BILLING;**307,329**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; ROUTINE SPECIFIC FOR FORMAT OF YEAR 2005+ CMAC FILES
;
CMAC(IBPATH,IBFILE,IBNAME,IBMODP,IBMODT) ; upload CMAC file from a VMS file into ^XTMP
N X,Y,IBI,IBXRF,IBDONE,IBXRF1,IBXRF2,IBFLINE,IBINACT,IBMOD,IBCHG
N IBLOC,IBCPT,IBNFP,IBFP,IBNFNP,IBFNP,IBEFDT,IBTRDT,IBPPC,IBPTC,IBNPPC,IBNPTC
;
D SETUP(IBFILE,IBNAME)
;
S IBXRF=IBNAME_IBFILE,IBLOC="",IBDONE=""
;
D OPEN^%ZISH("CMAC UPLOAD",IBPATH,IBFILE,"R") I POP W !!,"**** Unable to open ",IBPATH,IBFILE,! G CMACQ
;
U IO(0) W !!,"Loading ",IBFILE," into ^XTMP "
;
S IBI=0 F S IBI=IBI+1 U IO R IBFLINE:5 Q:$$ENDF D PARSE,STORE I '(IBI#100) U IO(0) W "."
;
D CLOSE^%ZISH("CMAC UPLOAD")
;
S IBDONE=(IBI-1)_U_IBXRF
;
CMACQ Q IBDONE
;
ENDF() N IBX S IBX=1 I $T,IBFLINE'="" S IBX=0
I $$STATUS^%ZISH S IBX=1
I 'IBX,'$$LNFORM(IBFLINE) D
. U IO(0)
. W !!,"**** Error while reading file: line not expected format (98 numeric characters):"
. W !!,"Line Length=",$L(IBFLINE)," characters" W:IBFLINE="" ?40,"Line read is null"
. W !,"LINE='",IBFLINE,"'",!!,"Upload Aborted!"
. S IBX=1 H 7 U IO
I IBI=1,IBFLINE="" U IO(0) W !!,"First line of file has no data, can not continue!" S IBX=1 H 7 U IO
Q IBX
;
LNFORM(LINE) ; check an individual line of the file for proper format (length=98 characters)
N IBX S IBX=0,LINE=$G(LINE) I (LINE?98N)!(LINE?3N5AN90N) S IBX=1
Q IBX
;
PARSE ; process a single line from a CMAC file: parse out into individual fields and store the line in XTMP
;
S IBLOC=$E(IBFLINE,1,3) ; locality
S IBCPT=$E(IBFLINE,4,8) ; CPT procedure
S IBNFP=$E(IBFLINE,9,16) ; category 2 Non-Facility Physician charge
S IBFP=$E(IBFLINE,17,24) ; category 1 Facility Physician charge
S IBNFNP=$E(IBFLINE,25,32) ; category 4 Non-Facility Non-Physician charge
S IBFNP=$E(IBFLINE,33,40) ; category 3 Facility Non-Physician charge
S IBEFDT=$E(IBFLINE,41,48) ; effective date
S IBTRDT=$E(IBFLINE,57,64) ; termination date
S IBPPC=$E(IBFLINE,65,72) ; Physician professional component
S IBPTC=$E(IBFLINE,73,80) ; Physician technical component
S IBNPPC=$E(IBFLINE,81,88) ; Non-Physician professional component
S IBNPTC=$E(IBFLINE,89,96) ; Non-Physician technical component
Q
;
STORE ;
S IBXRF1=IBXRF_" "_IBLOC
;
S IBMOD="",IBEFDT=$$DATE(IBEFDT),IBINACT="" I IBTRDT'=99999999,+IBTRDT S IBINACT=$$DATE(IBTRDT)
;
I +IBFP S IBCHG=$$CGF(IBFP),IBMOD="" S IBXRF2="FAC/PHYS CAT 1" D SET
I +IBFNP S IBCHG=$$CGF(IBFNP),IBMOD="" S IBXRF2="FAC/NONPHYS CAT 3" D SET
;
I +IBNFP S IBCHG=$$CGF(IBNFP),IBMOD="" S IBXRF2="NONFAC/PHYS CAT 2" D SET
I +IBNFNP S IBCHG=$$CGF(IBNFNP),IBMOD="" S IBXRF2="NONFAC/NONPHYS CAT 4" D SET
;
I +IBMODP,+IBPPC S IBCHG=$$CGF(IBPPC),IBMOD=IBMODP S IBXRF2="FAC/PHYS PC" D SET S IBXRF2="NON"_IBXRF2 D SET
I +IBMODT,+IBPTC S IBCHG=$$CGF(IBPTC),IBMOD=IBMODT S IBXRF2="FAC/PHYS TC" D SET S IBXRF2="NON"_IBXRF2 D SET
;
I +IBMODP,+IBNPPC S IBCHG=$$CGF(IBNPPC),IBMOD=IBMODP S IBXRF2="FAC/NONPHYS PC" D SET S IBXRF2="NON"_IBXRF2 D SET
I +IBMODT,+IBNPTC S IBCHG=$$CGF(IBNPTC),IBMOD=IBMODT S IBXRF2="FAC/NONPHYS TC" D SET S IBXRF2="NON"_IBXRF2 D SET
;
Q
;
CGF(AMT) ; return charge string from file line in dollar format
Q +($E(AMT,1,6)_"."_$E(AMT,7,8))
;
SET ;
N IBX S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR
S $P(^XTMP(IBXRF1,0),U,4)=+$P(IBX,U,4)+1
S $P(^XTMP(IBXRF1,IBXRF2),U,1)=+$G(^XTMP(IBXRF1,IBXRF2))+1
S ^XTMP(IBXRF1,IBXRF2,IBI)=IBCPT_U_IBEFDT_U_IBINACT_U_+IBCHG_U_IBMOD
Q
;
SETHDR ;
N IBX S IBX="IB upload of Host file "_IBFILE_", on "_$$HTE^XLFDT($H,2)_" by "_$P($G(^VA(200,+$G(DUZ),0)),U,1)
S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
;
S ^XTMP(IBXRF1,IBXRF2)=0_U_2_U_$G(IBCS)
Q
;
;
DATE(DATE) ; return yymmdd in FM format
N IBX S IBX="" I $G(DATE)?8N S IBX=$S($E(DATE,1,2)<20:"2",1:"3")_$E(DATE,3,8)
Q IBX
;
;
LNDT(LINE) ; return the date of an individual line, in FM format
N IBX S IBX=$E($G(LINE),41,48) S IBX=$$DATE(IBX)
Q IBX
;
;
;
SETUP(IBFILE,IBNAME) ; set up Charge Sets, Billing Regions, Rate Schedule links for new charges
; if new region entered, asks user for divisions
N IBLOC,IBXRF1,IBXRF2,IBEVENT,IBCT,IBBS,IBRV,IBRG,IBCS
;
S IBLOC=$P($P($G(IBFILE),"CMAC",2),".",1),IBXRF1=$G(IBNAME)_IBFILE_" "_IBLOC
S IBEVENT="PROCEDURE",IBCT="PROF",IBBS="OUTPATIENT VISIT",IBRV=510
;
;
; Find/Create Billing Region
S IBRG=$$RG^IBCRHU2("CMAC "_IBLOC,,IBLOC)
;
;
; Category 1 Facility Physician Charges
S IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" FAC/PHYS","CMAC",IBEVENT,$P(IBRG,U,2),IBCT,IBRV,IBBS)
D RSBR^IBCRHU2(IBCS,1,$G(IBGLBEFF))
F IBXRF2="FAC/PHYS CAT 1","FAC/PHYS PC","FAC/PHYS TC" D SETHDR
;
;
; Category 3 Facility Non-Physician Charges
S IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" FAC/NONPHYS","CMAC",IBEVENT,$P(IBRG,U,2),IBCT,IBRV,IBBS)
D RSBR^IBCRHU2(IBCS,0,$G(IBGLBEFF))
F IBXRF2="FAC/NONPHYS CAT 3","FAC/NONPHYS PC","FAC/NONPHYS TC" D SETHDR
;
;
; Category 2 Non-Facility Physician Charges
S IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" NONFAC/PHYS","CMAC",IBEVENT,$P(IBRG,U,2),IBCT,IBRV,IBBS)
D RSBR^IBCRHU2(IBCS,0,$G(IBGLBEFF))
F IBXRF2="NONFAC/PHYS CAT 2","NONFAC/PHYS PC","NONFAC/PHYS TC" D SETHDR
;
;
; Category 4 Non-Facility Non-Physician Charges
S IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" NONFAC/NONPHYS","CMAC",IBEVENT,$P(IBRG,U,2),IBCT,IBRV,IBBS)
D RSBR^IBCRHU2(IBCS,0,$G(IBGLBEFF))
F IBXRF2="NONFAC/NONPHYS CAT 4","NONFAC/NONPHYS PC","NONFAC/NONPHYS TC" D SETHDR
;
;
; get divisions added to new Billing Region
I +$P(IBRG,U,3) D GETDIV^IBCRHU2(+IBRG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBC3 5768 printed Apr 09, 2024@21:03:41 Page 2
IBCRHBC3 ;ALB/ARH - RATES: UPLOAD HOST FILES (CMAC 2005+) ; 10-MAY-2005
+1 ;;2.0;INTEGRATED BILLING;**307,329**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; ROUTINE SPECIFIC FOR FORMAT OF YEAR 2005+ CMAC FILES
+5 ;
CMAC(IBPATH,IBFILE,IBNAME,IBMODP,IBMODT) ; upload CMAC file from a VMS file into ^XTMP
+1 NEW X,Y,IBI,IBXRF,IBDONE,IBXRF1,IBXRF2,IBFLINE,IBINACT,IBMOD,IBCHG
+2 NEW IBLOC,IBCPT,IBNFP,IBFP,IBNFNP,IBFNP,IBEFDT,IBTRDT,IBPPC,IBPTC,IBNPPC,IBNPTC
+3 ;
+4 DO SETUP(IBFILE,IBNAME)
+5 ;
+6 SET IBXRF=IBNAME_IBFILE
SET IBLOC=""
SET IBDONE=""
+7 ;
+8 DO OPEN^%ZISH("CMAC UPLOAD",IBPATH,IBFILE,"R")
IF POP
WRITE !!,"**** Unable to open ",IBPATH,IBFILE,!
GOTO CMACQ
+9 ;
+10 USE IO(0)
WRITE !!,"Loading ",IBFILE," into ^XTMP "
+11 ;
+12 SET IBI=0
FOR
SET IBI=IBI+1
USE IO
READ IBFLINE:5
if $$ENDF
QUIT
DO PARSE
DO STORE
IF '(IBI#100)
USE IO(0)
WRITE "."
+13 ;
+14 DO CLOSE^%ZISH("CMAC UPLOAD")
+15 ;
+16 SET IBDONE=(IBI-1)_U_IBXRF
+17 ;
CMACQ QUIT IBDONE
+1 ;
ENDF() NEW IBX
SET IBX=1
IF $TEST
IF IBFLINE'=""
SET IBX=0
+1 IF $$STATUS^%ZISH
SET IBX=1
+2 IF 'IBX
IF '$$LNFORM(IBFLINE)
Begin DoDot:1
+3 USE IO(0)
+4 WRITE !!,"**** Error while reading file: line not expected format (98 numeric characters):"
+5 WRITE !!,"Line Length=",$LENGTH(IBFLINE)," characters"
if IBFLINE=""
WRITE ?40,"Line read is null"
+6 WRITE !,"LINE='",IBFLINE,"'",!!,"Upload Aborted!"
+7 SET IBX=1
HANG 7
USE IO
End DoDot:1
+8 IF IBI=1
IF IBFLINE=""
USE IO(0)
WRITE !!,"First line of file has no data, can not continue!"
SET IBX=1
HANG 7
USE IO
+9 QUIT IBX
+10 ;
LNFORM(LINE) ; check an individual line of the file for proper format (length=98 characters)
+1 NEW IBX
SET IBX=0
SET LINE=$GET(LINE)
IF (LINE?98N)!(LINE?3N5AN90N)
SET IBX=1
+2 QUIT IBX
+3 ;
PARSE ; process a single line from a CMAC file: parse out into individual fields and store the line in XTMP
+1 ;
+2 ; locality
SET IBLOC=$EXTRACT(IBFLINE,1,3)
+3 ; CPT procedure
SET IBCPT=$EXTRACT(IBFLINE,4,8)
+4 ; category 2 Non-Facility Physician charge
SET IBNFP=$EXTRACT(IBFLINE,9,16)
+5 ; category 1 Facility Physician charge
SET IBFP=$EXTRACT(IBFLINE,17,24)
+6 ; category 4 Non-Facility Non-Physician charge
SET IBNFNP=$EXTRACT(IBFLINE,25,32)
+7 ; category 3 Facility Non-Physician charge
SET IBFNP=$EXTRACT(IBFLINE,33,40)
+8 ; effective date
SET IBEFDT=$EXTRACT(IBFLINE,41,48)
+9 ; termination date
SET IBTRDT=$EXTRACT(IBFLINE,57,64)
+10 ; Physician professional component
SET IBPPC=$EXTRACT(IBFLINE,65,72)
+11 ; Physician technical component
SET IBPTC=$EXTRACT(IBFLINE,73,80)
+12 ; Non-Physician professional component
SET IBNPPC=$EXTRACT(IBFLINE,81,88)
+13 ; Non-Physician technical component
SET IBNPTC=$EXTRACT(IBFLINE,89,96)
+14 QUIT
+15 ;
STORE ;
+1 SET IBXRF1=IBXRF_" "_IBLOC
+2 ;
+3 SET IBMOD=""
SET IBEFDT=$$DATE(IBEFDT)
SET IBINACT=""
IF IBTRDT'=99999999
IF +IBTRDT
SET IBINACT=$$DATE(IBTRDT)
+4 ;
+5 IF +IBFP
SET IBCHG=$$CGF(IBFP)
SET IBMOD=""
SET IBXRF2="FAC/PHYS CAT 1"
DO SET
+6 IF +IBFNP
SET IBCHG=$$CGF(IBFNP)
SET IBMOD=""
SET IBXRF2="FAC/NONPHYS CAT 3"
DO SET
+7 ;
+8 IF +IBNFP
SET IBCHG=$$CGF(IBNFP)
SET IBMOD=""
SET IBXRF2="NONFAC/PHYS CAT 2"
DO SET
+9 IF +IBNFNP
SET IBCHG=$$CGF(IBNFNP)
SET IBMOD=""
SET IBXRF2="NONFAC/NONPHYS CAT 4"
DO SET
+10 ;
+11 IF +IBMODP
IF +IBPPC
SET IBCHG=$$CGF(IBPPC)
SET IBMOD=IBMODP
SET IBXRF2="FAC/PHYS PC"
DO SET
SET IBXRF2="NON"_IBXRF2
DO SET
+12 IF +IBMODT
IF +IBPTC
SET IBCHG=$$CGF(IBPTC)
SET IBMOD=IBMODT
SET IBXRF2="FAC/PHYS TC"
DO SET
SET IBXRF2="NON"_IBXRF2
DO SET
+13 ;
+14 IF +IBMODP
IF +IBNPPC
SET IBCHG=$$CGF(IBNPPC)
SET IBMOD=IBMODP
SET IBXRF2="FAC/NONPHYS PC"
DO SET
SET IBXRF2="NON"_IBXRF2
DO SET
+15 IF +IBMODT
IF +IBNPTC
SET IBCHG=$$CGF(IBNPTC)
SET IBMOD=IBMODT
SET IBXRF2="FAC/NONPHYS TC"
DO SET
SET IBXRF2="NON"_IBXRF2
DO SET
+16 ;
+17 QUIT
+18 ;
CGF(AMT) ; return charge string from file line in dollar format
+1 QUIT +($EXTRACT(AMT,1,6)_"."_$EXTRACT(AMT,7,8))
+2 ;
SET ;
+1 NEW IBX
SET IBX=$GET(^XTMP(IBXRF1,0))
IF IBX=""
DO SETHDR
+2 SET $PIECE(^XTMP(IBXRF1,0),U,4)=+$PIECE(IBX,U,4)+1
+3 SET $PIECE(^XTMP(IBXRF1,IBXRF2),U,1)=+$GET(^XTMP(IBXRF1,IBXRF2))+1
+4 SET ^XTMP(IBXRF1,IBXRF2,IBI)=IBCPT_U_IBEFDT_U_IBINACT_U_+IBCHG_U_IBMOD
+5 QUIT
+6 ;
SETHDR ;
+1 NEW IBX
SET IBX="IB upload of Host file "_IBFILE_", on "_$$HTE^XLFDT($HOROLOG,2)_" by "_$PIECE($GET(^VA(200,+$GET(DUZ),0)),U,1)
+2 SET ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
+3 ;
+4 SET ^XTMP(IBXRF1,IBXRF2)=0_U_2_U_$GET(IBCS)
+5 QUIT
+6 ;
+7 ;
DATE(DATE) ; return yymmdd in FM format
+1 NEW IBX
SET IBX=""
IF $GET(DATE)?8N
SET IBX=$SELECT($EXTRACT(DATE,1,2)<20:"2",1:"3")_$EXTRACT(DATE,3,8)
+2 QUIT IBX
+3 ;
+4 ;
LNDT(LINE) ; return the date of an individual line, in FM format
+1 NEW IBX
SET IBX=$EXTRACT($GET(LINE),41,48)
SET IBX=$$DATE(IBX)
+2 QUIT IBX
+3 ;
+4 ;
+5 ;
SETUP(IBFILE,IBNAME) ; set up Charge Sets, Billing Regions, Rate Schedule links for new charges
+1 ; if new region entered, asks user for divisions
+2 NEW IBLOC,IBXRF1,IBXRF2,IBEVENT,IBCT,IBBS,IBRV,IBRG,IBCS
+3 ;
+4 SET IBLOC=$PIECE($PIECE($GET(IBFILE),"CMAC",2),".",1)
SET IBXRF1=$GET(IBNAME)_IBFILE_" "_IBLOC
+5 SET IBEVENT="PROCEDURE"
SET IBCT="PROF"
SET IBBS="OUTPATIENT VISIT"
SET IBRV=510
+6 ;
+7 ;
+8 ; Find/Create Billing Region
+9 SET IBRG=$$RG^IBCRHU2("CMAC "_IBLOC,,IBLOC)
+10 ;
+11 ;
+12 ; Category 1 Facility Physician Charges
+13 SET IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" FAC/PHYS","CMAC",IBEVENT,$PIECE(IBRG,U,2),IBCT,IBRV,IBBS)
+14 DO RSBR^IBCRHU2(IBCS,1,$GET(IBGLBEFF))
+15 FOR IBXRF2="FAC/PHYS CAT 1","FAC/PHYS PC","FAC/PHYS TC"
DO SETHDR
+16 ;
+17 ;
+18 ; Category 3 Facility Non-Physician Charges
+19 SET IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" FAC/NONPHYS","CMAC",IBEVENT,$PIECE(IBRG,U,2),IBCT,IBRV,IBBS)
+20 DO RSBR^IBCRHU2(IBCS,0,$GET(IBGLBEFF))
+21 FOR IBXRF2="FAC/NONPHYS CAT 3","FAC/NONPHYS PC","FAC/NONPHYS TC"
DO SETHDR
+22 ;
+23 ;
+24 ; Category 2 Non-Facility Physician Charges
+25 SET IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" NONFAC/PHYS","CMAC",IBEVENT,$PIECE(IBRG,U,2),IBCT,IBRV,IBBS)
+26 DO RSBR^IBCRHU2(IBCS,0,$GET(IBGLBEFF))
+27 FOR IBXRF2="NONFAC/PHYS CAT 2","NONFAC/PHYS PC","NONFAC/PHYS TC"
DO SETHDR
+28 ;
+29 ;
+30 ; Category 4 Non-Facility Non-Physician Charges
+31 SET IBCS=$$CS^IBCRHU2("CMAC "_IBLOC_" NONFAC/NONPHYS","CMAC",IBEVENT,$PIECE(IBRG,U,2),IBCT,IBRV,IBBS)
+32 DO RSBR^IBCRHU2(IBCS,0,$GET(IBGLBEFF))
+33 FOR IBXRF2="NONFAC/NONPHYS CAT 4","NONFAC/NONPHYS PC","NONFAC/NONPHYS TC"
DO SETHDR
+34 ;
+35 ;
+36 ; get divisions added to new Billing Region
+37 IF +$PIECE(IBRG,U,3)
DO GETDIV^IBCRHU2(+IBRG)
+38 QUIT
