IBCRHBC1 ;ALB/ARH - RATES: UPLOAD HOST FILES (CMAC <2000) ; 14-FEB-2000
;;2.0;INTEGRATED BILLING;**124**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; ROUTINE SPECIFIC FOR FORMAT OF PRE-2000 CMAC FILES
;
CMAC(IBPATH,IBFILE,IBNAME,IBMODP,IBMODT) ; upload CMAC file from a VMS file into ^XTMP
N X,Y,IBI,IBXRF,IBLOC,IBDONE,IBXRF1,IBXRF2,IBFLINE,IBINACT,IBMOD,IBCHG
N IBCPT,IBCL1,IBCL2,IBCL34,IBEFDT,IBTRDT,IBCL1P,IBCL1T,IBCL4P,IBCL4T
;
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 (85 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
N IBX S IBX=0,LINE=$G(LINE) I (LINE?85N)!(LINE?3N1A81N) S IBX=1
Q IBX
;
PARSE ; process a single lin 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 IBCL1=$E(IBFLINE,9,16) ; class 1 charge
S IBCL2=$E(IBFLINE,17,24) ; class 2 charge
S IBCL34=$E(IBFLINE,25,32) ; class 3&4 charge
S IBEFDT=$E(IBFLINE,36,41) ; effective date
S IBTRDT=$E(IBFLINE,48,53) ; termination date
S IBCL1P=$E(IBFLINE,54,61) ; class 1 professional component
S IBCL1T=$E(IBFLINE,62,69) ; class 1 technical component
S IBCL4P=$E(IBFLINE,70,77) ; class 4 professional component
S IBCL4T=$E(IBFLINE,78,85) ; class 4 technical component
Q
;
STORE ;
S IBXRF1=IBXRF_" "_IBLOC
;
S IBMOD="",IBEFDT=$$DATE(IBEFDT),IBINACT="" I IBTRDT'=999999,+IBTRDT S IBINACT=$$DATE(IBTRDT)
;
I +IBCL1 S IBXRF2="CLASS 1",IBCHG=$E(IBCL1,1,6)_"."_$E(IBCL1,7,8) D SET ; class 1 charge
I +IBCL2 S IBXRF2="CLASS 2",IBCHG=$E(IBCL2,1,6)_"."_$E(IBCL2,7,8) D SET ; class 2 charge
I +IBCL34 S IBXRF2="CLASS 3&4",IBCHG=$E(IBCL34,1,6)_"."_$E(IBCL34,7,8) D SET ; class 3&4 charge
;
I +IBMODP,+IBCL1P S IBXRF2="CLASS 1 PC",IBCHG=$E(IBCL1P,1,6)_"."_$E(IBCL1P,7,8),IBMOD=IBMODP D SET
I +IBMODT,+IBCL1T S IBXRF2="CLASS 1 TC",IBCHG=$E(IBCL1T,1,6)_"."_$E(IBCL1T,7,8),IBMOD=IBMODT D SET
;
I +IBMODP,+IBCL4P S IBXRF2="CLASS 4 PC",IBCHG=$E(IBCL4P,1,6)_"."_$E(IBCL4P,7,8),IBMOD=IBMODP D SET
I +IBMODT,+IBCL4T S IBXRF2="CLASS 4 TC",IBCHG=$E(IBCL4T,1,6)_"."_$E(IBCL4T,7,8),IBMOD=IBMODT D SET
;
Q
;
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 ^XTMP(IBXRF1,IBXRF2)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)_U_2
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
Q
;
;
DATE(DATE) ; return yymmdd in FM format
N IBX S IBX="" I $G(DATE)?6N S IBX=$S($E(DATE,1,2)>70:"2",1:"3")_DATE
Q IBX
;
;
LNDT(LINE) ; return the date of an individual line, in FM format
N IBX S IBX=$E($G(LINE),36,41) S IBX=$$DATE(IBX)
Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBC1 3705 printed Jun 11, 2024@21:48:18 Page 2
IBCRHBC1 ;ALB/ARH - RATES: UPLOAD HOST FILES (CMAC <2000) ; 14-FEB-2000
+1 ;;2.0;INTEGRATED BILLING;**124**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; ROUTINE SPECIFIC FOR FORMAT OF PRE-2000 CMAC FILES
+5 ;
CMAC(IBPATH,IBFILE,IBNAME,IBMODP,IBMODT) ; upload CMAC file from a VMS file into ^XTMP
+1 NEW X,Y,IBI,IBXRF,IBLOC,IBDONE,IBXRF1,IBXRF2,IBFLINE,IBINACT,IBMOD,IBCHG
+2 NEW IBCPT,IBCL1,IBCL2,IBCL34,IBEFDT,IBTRDT,IBCL1P,IBCL1T,IBCL4P,IBCL4T
+3 ;
+4 SET IBXRF=IBNAME_IBFILE
SET IBLOC=""
SET IBDONE=""
+5 ;
+6 DO OPEN^%ZISH("CMAC UPLOAD",IBPATH,IBFILE,"R")
IF POP
WRITE !!,"**** Unable to open ",IBPATH,IBFILE,!
GOTO CMACQ
+7 ;
+8 USE IO(0)
WRITE !!,"Loading ",IBFILE," into ^XTMP "
+9 ;
+10 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 "."
+11 ;
+12 DO CLOSE^%ZISH("CMAC UPLOAD")
+13 ;
+14 SET IBDONE=(IBI-1)_U_IBXRF
+15 ;
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 (85 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
+1 NEW IBX
SET IBX=0
SET LINE=$GET(LINE)
IF (LINE?85N)!(LINE?3N1A81N)
SET IBX=1
+2 QUIT IBX
+3 ;
PARSE ; process a single lin 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 ; class 1 charge
SET IBCL1=$EXTRACT(IBFLINE,9,16)
+5 ; class 2 charge
SET IBCL2=$EXTRACT(IBFLINE,17,24)
+6 ; class 3&4 charge
SET IBCL34=$EXTRACT(IBFLINE,25,32)
+7 ; effective date
SET IBEFDT=$EXTRACT(IBFLINE,36,41)
+8 ; termination date
SET IBTRDT=$EXTRACT(IBFLINE,48,53)
+9 ; class 1 professional component
SET IBCL1P=$EXTRACT(IBFLINE,54,61)
+10 ; class 1 technical component
SET IBCL1T=$EXTRACT(IBFLINE,62,69)
+11 ; class 4 professional component
SET IBCL4P=$EXTRACT(IBFLINE,70,77)
+12 ; class 4 technical component
SET IBCL4T=$EXTRACT(IBFLINE,78,85)
+13 QUIT
+14 ;
STORE ;
+1 SET IBXRF1=IBXRF_" "_IBLOC
+2 ;
+3 SET IBMOD=""
SET IBEFDT=$$DATE(IBEFDT)
SET IBINACT=""
IF IBTRDT'=999999
IF +IBTRDT
SET IBINACT=$$DATE(IBTRDT)
+4 ;
+5 ; class 1 charge
IF +IBCL1
SET IBXRF2="CLASS 1"
SET IBCHG=$EXTRACT(IBCL1,1,6)_"."_$EXTRACT(IBCL1,7,8)
DO SET
+6 ; class 2 charge
IF +IBCL2
SET IBXRF2="CLASS 2"
SET IBCHG=$EXTRACT(IBCL2,1,6)_"."_$EXTRACT(IBCL2,7,8)
DO SET
+7 ; class 3&4 charge
IF +IBCL34
SET IBXRF2="CLASS 3&4"
SET IBCHG=$EXTRACT(IBCL34,1,6)_"."_$EXTRACT(IBCL34,7,8)
DO SET
+8 ;
+9 IF +IBMODP
IF +IBCL1P
SET IBXRF2="CLASS 1 PC"
SET IBCHG=$EXTRACT(IBCL1P,1,6)_"."_$EXTRACT(IBCL1P,7,8)
SET IBMOD=IBMODP
DO SET
+10 IF +IBMODT
IF +IBCL1T
SET IBXRF2="CLASS 1 TC"
SET IBCHG=$EXTRACT(IBCL1T,1,6)_"."_$EXTRACT(IBCL1T,7,8)
SET IBMOD=IBMODT
DO SET
+11 ;
+12 IF +IBMODP
IF +IBCL4P
SET IBXRF2="CLASS 4 PC"
SET IBCHG=$EXTRACT(IBCL4P,1,6)_"."_$EXTRACT(IBCL4P,7,8)
SET IBMOD=IBMODP
DO SET
+13 IF +IBMODT
IF +IBCL4T
SET IBXRF2="CLASS 4 TC"
SET IBCHG=$EXTRACT(IBCL4T,1,6)_"."_$EXTRACT(IBCL4T,7,8)
SET IBMOD=IBMODT
DO SET
+14 ;
+15 QUIT
+16 ;
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 ^XTMP(IBXRF1,IBXRF2)=(+$GET(^XTMP(IBXRF1,IBXRF2))+1)_U_2
+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 QUIT
+4 ;
+5 ;
DATE(DATE) ; return yymmdd in FM format
+1 NEW IBX
SET IBX=""
IF $GET(DATE)?6N
SET IBX=$SELECT($EXTRACT(DATE,1,2)>70:"2",1:"3")_DATE
+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),36,41)
SET IBX=$$DATE(IBX)
+2 QUIT IBX
