IBCRHBC2.m

IBCRHBC2 ;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 YEAR 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 (91 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?91N)!(LINE?3N1A87N) 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,43) ; effective date

 S IBTRDT=$E(IBFLINE,52,59) ; termination date

 S IBCL1P=$E(IBFLINE,60,67) ; class 1 professional component

 S IBCL1T=$E(IBFLINE,68,75) ; class 1 technical component

 S IBCL4P=$E(IBFLINE,76,83) ; class 4 professional component

 S IBCL4T=$E(IBFLINE,84,91) ; class 4 technical component

 Q

 ;

STORE ;

 S IBXRF1=IBXRF_"  "_IBLOC

 ;

 S IBMOD="",IBEFDT=$$DATE(IBEFDT),IBINACT="" I IBTRDT'=99999999,+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)?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),36,43) S IBX=$$DATE(IBX)

 Q IBX

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCRHBC2   3717     printed  Feb 18, 2025@23:45:35                                                                                                                                                                                                    Page 2

IBCRHBC2  ;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 YEAR 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 (91 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?91N)!(LINE?3N1A87N)

               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,43)

 +8       ; termination date

           SET IBTRDT=$EXTRACT(IBFLINE,52,59)

 +9       ; class 1 professional component

           SET IBCL1P=$EXTRACT(IBFLINE,60,67)

 +10      ; class 1 technical component

           SET IBCL1T=$EXTRACT(IBFLINE,68,75)

 +11      ; class 4 professional component

           SET IBCL4P=$EXTRACT(IBFLINE,76,83)

 +12      ; class 4 technical component

           SET IBCL4T=$EXTRACT(IBFLINE,84,91)

 +13       QUIT 

 +14      ;

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       ; 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)?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),36,43)

           SET IBX=$$DATE(IBX)

 +2        QUIT IBX