IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96
;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389,488,516,592,665**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
MPG(PG,FLDS,FORM) ; Set static flds on pages after page 1
; for either 1500 or UB
; PG = page #
; FORM= 1 for UB, otherwise for 1500
; FLDS: array passed by reference and containing lines OR
; line/column from pg 1 to repeat on subsequent pages
; Format: FLDS(LINE,COL) or FLDS(LINE) for whole line
; CMS-1500: LINES 1-5,7-43,57 from col 1 to 50, 58-63
; UB: see CKPGUB for lines and columns
;
N Z,Z0,Z1,LPG
S FORM=$S($G(FORM)=1:3,1:2)
;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as the 1500
;I FORM=2 D ; print page # on each pg, totals on last page of 1500 ;JRA IB*2.0*592 ';'
I FORM=2!(FORM=7) D ; print page # on each pg, totals on last page of 1500 (or J430D) ;JRA IB*2.0*592
. S LPG=+$O(^TMP("IBXDATA",$J,IBXREC,""),-1)
. S Z="[Page "_PG_" of "_LPG_"]"
. S Z=$$FO^IBCNEUT1(Z,17,"R")
. D SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE)
. I PG=2 S Z=$P(Z,"[",1)_"[Page 1 of "_LPG_"]" D SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE)
. I LPG=PG D
.. ;
.. ; esg - IB*2*348 - update dollar format for last page of 1500
.. ;
.. D SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($G(IBXSAVE("TOT")),9),.IBXSIZE)
.. D SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($G(IBXSAVE("PAID")),8),.IBXSIZE)
.. ;IB*2.0*516/DRF - Blank Box 30 on last page of multi-page claims
.. ;D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE)
.. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID")
;
S Z=0 F S Z=$O(FLDS(Z)) Q:'Z D
. I $O(FLDS(Z,""))="" D Q ;repeats line
.. S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) Q:'Z0 S Z1=$G(^(Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
. S Z0=0 F S Z0=$O(FLDS(Z,Z0)) Q:'Z0 S Z1=$G(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
. I FORM=2,LPG'=PG D
.. D SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE)
.. D SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE)
Q
;
NONSERV(Z,Z0) ; Set variable if non-service/non-text data is present for box
; 24 of CMS-1500
; Z = sequence of IBXSAVE being processed
; Z0 = sequnce within IBXDATA to indicate actual line #
I $P(IBXSAVE("BOX24",Z),U)="" S IBXSAVE("NON-SERV",Z0)=""
Q
;
PG(VAL,LNCT) ;Set next pg for CMS-1500 lines
;VAL = value of fld
;LNCT = line # from IBXSAVE("BOX24") array
N IBP,IBL
S IBP=LNCT\12+(LNCT#12>0),IBL=LNCT-(12*(IBP-1))-1
I IBL'<0 S VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) D SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE)
K IBXDATA(LNCT)
Q
;
MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) ; Set up pages > 1 for UB overflows
; PG = Page # to set (REQUIRED)
; OFFSET = offset from first line this should be extracted into
; 0 = first line (REQUIRED)
; VAL = value to set (REQUIRED)
; IBLN = line to set data at (if null, uses IBXLN)
; IBCOL = column to set data at (if null, uses IBXCOL)
; NOFORM = don't format, just output data as passed
; Assumes formatter IBXLN,IBXCOL variables exist
;
I $G(IBLN)="" S IBLN=IBXLN
I $G(IBCOL)="" S IBCOL=IBXCOL
S:'$G(NOFORM) VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA))
D SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE)
Q
;
CKREV(CT,VAL) ; Check too many rev code lines to fit on page
; This procedure is only called when CT>22 (i.e. 23 or more)
;
D MPGUB((CT-1)\22+1,CT-1#22,VAL) ; 22 codes on a single page
Q
;
CKPGUB ; Check to see if multiple UB pages are needed then populate
; static flds from page 1, add page numbers
;
N FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2
;
S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1),IBP=0
S Z="" F S Z=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z),-1) Q:'Z S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z,Z0)) Q:'Z0 I $G(^(Z0))'="" S IBP=1 Q
I 'IBP K ^TMP("IBXDATA",$J,IBXREC,LPG) S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1) Q:LPG=1
;
; Static flds
F Z=2:1:7 S FLDS(Z)="" ; FL-1 thru FL-9
F Z=1,10,13,19,22,25,28,31 S FLDS(9,Z)="" ; FL-10 thru FL-17
F Z=13:1:17 S FLDS(Z,1)="" ; payer address in FL-38
S FLDS(41,46)="" ; creation date
F Z=42,43,44,45,47,48,49,51,52,53 S FLDS(Z)="" ; FL-50 thru FL-65
F Z=57,59,61,63 S (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))="" ; FL-76-79 ID's
F Z=58,60,62,64 S (FLDS(Z,53),FLDS(Z,71))="" ; FL-76-79 Names
;
F IBPG=1:1:LPG D
. ; Add pg # to last line of rev codes if multiple pages
. N IB,IBP
. S IB=$G(^TMP("IBXDATA",$J,IBXREC,IBPG,41,6))
. D MPGUB(IBPG,0,IBPG,41,10,1)
. D MPGUB(IBPG,0,LPG,41,16,1)
. D:IBPG>1 MPG(IBPG,.FLDS,1)
. Q
; print totals on line 41 of the last page
S (TOT1,TOT2)=0
F Z=1:1 Q:'$D(^TMP($J,"IBC-RC",Z)) S Z0=^(Z) I +Z0=1 S TOT1=TOT1+$P(Z0,U,7),TOT2=TOT2+$P(Z0,U,8)
; Make sure totals are only 9 digits => baa IB*2.0*488
S TOT1=$$DOL^IBCEF77(TOT1,9)
S TOT1=$E(TOT1,1,9)
S TOT2=$$DOL^IBCEF77(TOT2,9)
S TOT2=$E(TOT2,1,9)
D MPGUB(IBPG,0,"0001",41,1,1)
D MPGUB(IBPG,0,TOT1,41,61,1)
D MPGUB(IBPG,0,TOT2,41,71,1)
;End changes => baa IB*2.0*488
Q
;
HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value)
; R = flag for type of fld (1/2/3) being printed in rev code block
Q R ;No longer used as of patch IB*2.0*51
;
PROS(IBIFN) ; Extract billable prosthetics for 837
N IBARRAY,Z,Z0,CT,PROS
D SET^IBCSC5B(IBIFN,.IBARRAY)
I '$P(IBARRAY,U,2) S CT="" G PROSQ
S Z="",CT=0
F S Z=$O(IBARRAY(Z)) Q:Z="" S Z0="" F S Z0=$O(IBARRAY(Z,Z0)) Q:Z0="" S CT=CT+1 D
.S PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0)) ; P389 removed p2 - item ptr file 661
.;date^^short descr^entry # in file 362.5
.S IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0)
PROSQ Q CT
;
B24(IBXSV,IBIFN,IBNOSHOW) ; Code to execute to set up IBXSV("BOX24") for
; print or IBXSAVE("OUTPT") for transmit - called by output formatter
; IBNOSHOW = 1 if not to show error/warning text lines
; Pass IBXSV by reference
N IBSUB
S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
K IBXSV(IBSUB)
I '$D(IBIFN) S IBIFN=$G(IBXIEN)
I IBIFN D F^IBCEF("N-HCFA 1500 SERVICE"_$S(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN)
I $S(IBSUB'["24":1,1:'$G(IBNOSHOW)) D
. M IBXSV(IBSUB)=IBXDATA
E D
. N Z,CT
. S (Z,CT)=0 F S Z=$O(IBXDATA(Z)) Q:'Z I '$D(IBXDATA(Z,"ARX")) S CT=CT+1 M IBXSV(IBSUB,CT)=IBXDATA(Z)
Q
;
; esg - 11/14/03 - Moved the below functions due to space constraints
;
ALLTYP(IBIFN) Q $$ALLTYP^IBCEF31(IBIFN)
INSTYP(IBIFN,SEQ) Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ))
POLTYP(IBIFN,IBSEQ) Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ))
ALLPTYP(IBIFN) Q $$ALLPTYP^IBCEF31(IBIFN)
;
FILL(Z) ;
Q
;
; *****
; The following code performs the multi-page set up for
; printing overflow data on the UB
; *****
;
XPROC(DATA,CT) ; Output any UB procedures after 6 on new page(s)
; DATA = output data from IBXSAVE("PROC",CT)
; CT = array sequence # of the procedure being output
; Only used for local prints
N OFFSET,PG,COL,PRCODE,Q,XCT
;JWS;IB*2.0*665;US45880;for pages 2 thru N, do not print principle procedure in box 74
S XCT=$S(CT<7:CT,1:CT+(CT-7\5)+1)
S Q=(XCT-1)\3#2,OFFSET=$S('Q:0,1:2)
S PG=(XCT-1)\6+1,COL=1+(XCT-1#3*15)
;end;IB*2.0*665;replaced CT var with XCT
D MPGUB(PG,OFFSET,$P(DATA,U,1),58,COL)
D MPGUB(PG,OFFSET,$P(DATA,U,2),58,COL+9)
Q
;
XDIAG(DATA,CT) ; Output any UB other diagnoses after 8 on new page(s)
; DATA = output data from IBXSAVE("DX",CT)
; CT = array sequence # of the diagnosis being output
; Only used for local prints
N COL,PG
S PG=(CT-1)\8+1,COL=8+(CT-1#9*7)
S DATA=$P($$ICD9^IBACSV(+DATA),U,1)
D MPGUB(PG,0,DATA,56,COL)
Q
;
XVAL(DATA,CT) ; Output any UB value codes after 12 on new page(s)
; DATA = output data from IBXSAVE("VC",CT)
; CT = array sequence # of the value code being output
;
N COL,PG,OFFSET
S PG=(CT-1)\12+1,COL=44+(CT-1#3*13),OFFSET=(CT-(12*(PG-1))-1)\3
D MPGUB(PG,OFFSET,$P(DATA,U,1),14,COL)
D MPGUB(PG,OFFSET,$P(DATA,U,2),14,COL+3)
Q
;
XCC(DATA,CT) ; Output any UB condition codes after 11 on new page(s)
; 11 condition codes per page, starting columns 34 thru 64
; DATA = output data from IBXSAVE("CC",CT)
; CT = array sequence # of the condition code being output
;
N COL,PG
S PG=(CT-1)\11+1,COL=34+(CT-1#11*3)
D MPGUB(PG,0,DATA,9,COL)
Q
;
XOCC(DATA,CT,FL) ; Output any UB occurrence codes after 8 (2 per form
; locators 31-34) on new page(s)
; DATA = data from IBXSAVE("OCC",z) to be output
; CT = array sequence # of occurrence code being output
; FL = # of form locator being populated with the occ code
;
N COL,PG,OFFSET
S PG=(CT-1)\2+1,COL=1+((FL-31)*10),OFFSET=$S(CT#2:0,1:1)
D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
Q
;
XOCCS(DATA,CT,FL) ; Output any UB occurrence span codes after 4 on new page(s)
; DATA = data from IBXSAVE("OCCS",z) to be output
; CT = array sequence # of occurrence span code being output
; FL = # of form locator being populated (either FL 35 or 36)
;
N COL,PG,OFFSET
S PG=(CT-1)\2+1,OFFSET=$S(CT#2:0,1:1)
S COL=41+((FL-35)*17)
D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
D MPGUB(PG,OFFSET,$P(DATA,U,3),11,COL+11)
Q
;
FORMAT(VAL,IBX0,IBXDA) ;
I IBX0'="",IBXDA S VAL=$$FORMAT^IBCEFG(VAL,$P($G(^IBA(364.6,+IBXDA,0)),U,9),$P(IBX0,U,7),IBX0)
Q VAL
;
OUTPDT(IBIFN,IBXSAVE,IBXDATA) ; Returns outpatient service to date
; formatted CCYYMMDD for UB 837
; IBIFN = ien of bill (file 399)
; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE")
; IBXDATA = array with formatted date or each line item - CCYYMMDD
N Z
S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,10):$$DT^IBCEFG1($P(IBXSAVE("INPT",Z),U,10),,"D8"),1:IBXSAVE("DATE"))
K IBXSAVE("DATE")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF3 9967 printed Dec 13, 2024@02:10:02 Page 2
IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96
+1 ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389,488,516,592,665**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
MPG(PG,FLDS,FORM) ; Set static flds on pages after page 1
+1 ; for either 1500 or UB
+2 ; PG = page #
+3 ; FORM= 1 for UB, otherwise for 1500
+4 ; FLDS: array passed by reference and containing lines OR
+5 ; line/column from pg 1 to repeat on subsequent pages
+6 ; Format: FLDS(LINE,COL) or FLDS(LINE) for whole line
+7 ; CMS-1500: LINES 1-5,7-43,57 from col 1 to 50, 58-63
+8 ; UB: see CKPGUB for lines and columns
+9 ;
+10 NEW Z,Z0,Z1,LPG
+11 SET FORM=$SELECT($GET(FORM)=1:3,1:2)
+12 ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as the 1500
+13 ;I FORM=2 D ; print page # on each pg, totals on last page of 1500 ;JRA IB*2.0*592 ';'
+14 ; print page # on each pg, totals on last page of 1500 (or J430D) ;JRA IB*2.0*592
IF FORM=2!(FORM=7)
Begin DoDot:1
+15 SET LPG=+$ORDER(^TMP("IBXDATA",$JOB,IBXREC,""),-1)
+16 SET Z="[Page "_PG_" of "_LPG_"]"
+17 SET Z=$$FO^IBCNEUT1(Z,17,"R")
+18 DO SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE)
+19 IF PG=2
SET Z=$PIECE(Z,"[",1)_"[Page 1 of "_LPG_"]"
DO SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE)
+20 IF LPG=PG
Begin DoDot:2
+21 ;
+22 ; esg - IB*2*348 - update dollar format for last page of 1500
+23 ;
+24 DO SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($GET(IBXSAVE("TOT")),9),.IBXSIZE)
+25 DO SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($GET(IBXSAVE("PAID")),8),.IBXSIZE)
+26 ;IB*2.0*516/DRF - Blank Box 30 on last page of multi-page claims
+27 ;D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE)
+28 KILL IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID")
End DoDot:2
End DoDot:1
+29 ;
+30 SET Z=0
FOR
SET Z=$ORDER(FLDS(Z))
if 'Z
QUIT
Begin DoDot:1
+31 ;repeats line
IF $ORDER(FLDS(Z,""))=""
Begin DoDot:2
+32 SET Z0=0
FOR
SET Z0=$ORDER(^TMP("IBXDATA",$JOB,IBXREC,1,Z,Z0))
if 'Z0
QUIT
SET Z1=$GET(^(Z0))
IF Z1'=""
DO SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
End DoDot:2
QUIT
+33 SET Z0=0
FOR
SET Z0=$ORDER(FLDS(Z,Z0))
if 'Z0
QUIT
SET Z1=$GET(^TMP("IBXDATA",$JOB,IBXREC,1,Z,Z0))
IF Z1'=""
DO SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
+34 IF FORM=2
IF LPG'=PG
Begin DoDot:2
+35 DO SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE)
+36 DO SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE)
End DoDot:2
End DoDot:1
+37 QUIT
+38 ;
NONSERV(Z,Z0) ; Set variable if non-service/non-text data is present for box
+1 ; 24 of CMS-1500
+2 ; Z = sequence of IBXSAVE being processed
+3 ; Z0 = sequnce within IBXDATA to indicate actual line #
+4 IF $PIECE(IBXSAVE("BOX24",Z),U)=""
SET IBXSAVE("NON-SERV",Z0)=""
+5 QUIT
+6 ;
PG(VAL,LNCT) ;Set next pg for CMS-1500 lines
+1 ;VAL = value of fld
+2 ;LNCT = line # from IBXSAVE("BOX24") array
+3 NEW IBP,IBL
+4 SET IBP=LNCT\12+(LNCT#12>0)
SET IBL=LNCT-(12*(IBP-1))-1
+5 IF IBL'<0
SET VAL=$$FORMAT(VAL,$GET(IBXLOOP("IBX0")),$GET(IBXDA))
DO SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE)
+6 KILL IBXDATA(LNCT)
+7 QUIT
+8 ;
MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) ; Set up pages > 1 for UB overflows
+1 ; PG = Page # to set (REQUIRED)
+2 ; OFFSET = offset from first line this should be extracted into
+3 ; 0 = first line (REQUIRED)
+4 ; VAL = value to set (REQUIRED)
+5 ; IBLN = line to set data at (if null, uses IBXLN)
+6 ; IBCOL = column to set data at (if null, uses IBXCOL)
+7 ; NOFORM = don't format, just output data as passed
+8 ; Assumes formatter IBXLN,IBXCOL variables exist
+9 ;
+10 IF $GET(IBLN)=""
SET IBLN=IBXLN
+11 IF $GET(IBCOL)=""
SET IBCOL=IBXCOL
+12 if '$GET(NOFORM)
SET VAL=$$FORMAT(VAL,$GET(IBXLOOP("IBX0")),$GET(IBXDA))
+13 DO SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE)
+14 QUIT
+15 ;
CKREV(CT,VAL) ; Check too many rev code lines to fit on page
+1 ; This procedure is only called when CT>22 (i.e. 23 or more)
+2 ;
+3 ; 22 codes on a single page
DO MPGUB((CT-1)\22+1,CT-1#22,VAL)
+4 QUIT
+5 ;
CKPGUB ; Check to see if multiple UB pages are needed then populate
+1 ; static flds from page 1, add page numbers
+2 ;
+3 NEW FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2
+4 ;
+5 SET LPG=$ORDER(^TMP("IBXDATA",$JOB,IBXREC,""),-1)
SET IBP=0
+6 SET Z=""
FOR
SET Z=$ORDER(^TMP("IBXDATA",$JOB,IBXREC,LPG,Z),-1)
if 'Z
QUIT
SET Z0=0
FOR
SET Z0=$ORDER(^TMP("IBXDATA",$JOB,IBXREC,LPG,Z,Z0))
if 'Z0
QUIT
IF $GET(^(Z0))'=""
SET IBP=1
QUIT
+7 IF 'IBP
KILL ^TMP("IBXDATA",$JOB,IBXREC,LPG)
SET LPG=$ORDER(^TMP("IBXDATA",$JOB,IBXREC,""),-1)
if LPG=1
QUIT
+8 ;
+9 ; Static flds
+10 ; FL-1 thru FL-9
FOR Z=2:1:7
SET FLDS(Z)=""
+11 ; FL-10 thru FL-17
FOR Z=1,10,13,19,22,25,28,31
SET FLDS(9,Z)=""
+12 ; payer address in FL-38
FOR Z=13:1:17
SET FLDS(Z,1)=""
+13 ; creation date
SET FLDS(41,46)=""
+14 ; FL-50 thru FL-65
FOR Z=42,43,44,45,47,48,49,51,52,53
SET FLDS(Z)=""
+15 ; FL-76-79 ID's
FOR Z=57,59,61,63
SET (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))=""
+16 ; FL-76-79 Names
FOR Z=58,60,62,64
SET (FLDS(Z,53),FLDS(Z,71))=""
+17 ;
+18 FOR IBPG=1:1:LPG
Begin DoDot:1
+19 ; Add pg # to last line of rev codes if multiple pages
+20 NEW IB,IBP
+21 SET IB=$GET(^TMP("IBXDATA",$JOB,IBXREC,IBPG,41,6))
+22 DO MPGUB(IBPG,0,IBPG,41,10,1)
+23 DO MPGUB(IBPG,0,LPG,41,16,1)
+24 if IBPG>1
DO MPG(IBPG,.FLDS,1)
+25 QUIT
End DoDot:1
+26 ; print totals on line 41 of the last page
+27 SET (TOT1,TOT2)=0
+28 FOR Z=1:1
if '$DATA(^TMP($JOB,"IBC-RC",Z))
QUIT
SET Z0=^(Z)
IF +Z0=1
SET TOT1=TOT1+$PIECE(Z0,U,7)
SET TOT2=TOT2+$PIECE(Z0,U,8)
+29 ; Make sure totals are only 9 digits => baa IB*2.0*488
+30 SET TOT1=$$DOL^IBCEF77(TOT1,9)
+31 SET TOT1=$EXTRACT(TOT1,1,9)
+32 SET TOT2=$$DOL^IBCEF77(TOT2,9)
+33 SET TOT2=$EXTRACT(TOT2,1,9)
+34 DO MPGUB(IBPG,0,"0001",41,1,1)
+35 DO MPGUB(IBPG,0,TOT1,41,61,1)
+36 DO MPGUB(IBPG,0,TOT2,41,71,1)
+37 ;End changes => baa IB*2.0*488
+38 QUIT
+39 ;
HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value)
+1 ; R = flag for type of fld (1/2/3) being printed in rev code block
+2 ;No longer used as of patch IB*2.0*51
QUIT R
+3 ;
PROS(IBIFN) ; Extract billable prosthetics for 837
+1 NEW IBARRAY,Z,Z0,CT,PROS
+2 DO SET^IBCSC5B(IBIFN,.IBARRAY)
+3 IF '$PIECE(IBARRAY,U,2)
SET CT=""
GOTO PROSQ
+4 SET Z=""
SET CT=0
+5 FOR
SET Z=$ORDER(IBARRAY(Z))
if Z=""
QUIT
SET Z0=""
FOR
SET Z0=$ORDER(IBARRAY(Z,Z0))
if Z0=""
QUIT
SET CT=CT+1
Begin DoDot:1
+6 ; P389 removed p2 - item ptr file 661
SET PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0))
+7 ;date^^short descr^entry # in file 362.5
+8 SET IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0)
End DoDot:1
PROSQ QUIT CT
+1 ;
B24(IBXSV,IBIFN,IBNOSHOW) ; Code to execute to set up IBXSV("BOX24") for
+1 ; print or IBXSAVE("OUTPT") for transmit - called by output formatter
+2 ; IBNOSHOW = 1 if not to show error/warning text lines
+3 ; Pass IBXSV by reference
+4 NEW IBSUB
+5 SET IBSUB=$SELECT('$GET(^TMP("IBTX",$JOB,IBIFN)):"BOX24",1:"OUTPT")
+6 KILL IBXSV(IBSUB)
+7 IF '$DATA(IBIFN)
SET IBIFN=$GET(IBXIEN)
+8 IF IBIFN
DO F^IBCEF("N-HCFA 1500 SERVICE"_$SELECT(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN)
+9 IF $SELECT(IBSUB'["24":1,1:'$GET(IBNOSHOW))
Begin DoDot:1
+10 MERGE IBXSV(IBSUB)=IBXDATA
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 NEW Z,CT
+13 SET (Z,CT)=0
FOR
SET Z=$ORDER(IBXDATA(Z))
if 'Z
QUIT
IF '$DATA(IBXDATA(Z,"ARX"))
SET CT=CT+1
MERGE IBXSV(IBSUB,CT)=IBXDATA(Z)
End DoDot:1
+14 QUIT
+15 ;
+16 ; esg - 11/14/03 - Moved the below functions due to space constraints
+17 ;
ALLTYP(IBIFN) QUIT $$ALLTYP^IBCEF31(IBIFN)
INSTYP(IBIFN,SEQ) QUIT $$INSTYP^IBCEF31(IBIFN,$GET(SEQ))
POLTYP(IBIFN,IBSEQ) QUIT $$POLTYP^IBCEF31(IBIFN,$GET(IBSEQ))
ALLPTYP(IBIFN) QUIT $$ALLPTYP^IBCEF31(IBIFN)
+1 ;
FILL(Z) ;
+1 QUIT
+2 ;
+3 ; *****
+4 ; The following code performs the multi-page set up for
+5 ; printing overflow data on the UB
+6 ; *****
+7 ;
XPROC(DATA,CT) ; Output any UB procedures after 6 on new page(s)
+1 ; DATA = output data from IBXSAVE("PROC",CT)
+2 ; CT = array sequence # of the procedure being output
+3 ; Only used for local prints
+4 NEW OFFSET,PG,COL,PRCODE,Q,XCT
+5 ;JWS;IB*2.0*665;US45880;for pages 2 thru N, do not print principle procedure in box 74
+6 SET XCT=$SELECT(CT<7:CT,1:CT+(CT-7\5)+1)
+7 SET Q=(XCT-1)\3#2
SET OFFSET=$SELECT('Q:0,1:2)
+8 SET PG=(XCT-1)\6+1
SET COL=1+(XCT-1#3*15)
+9 ;end;IB*2.0*665;replaced CT var with XCT
+10 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,1),58,COL)
+11 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,2),58,COL+9)
+12 QUIT
+13 ;
XDIAG(DATA,CT) ; Output any UB other diagnoses after 8 on new page(s)
+1 ; DATA = output data from IBXSAVE("DX",CT)
+2 ; CT = array sequence # of the diagnosis being output
+3 ; Only used for local prints
+4 NEW COL,PG
+5 SET PG=(CT-1)\8+1
SET COL=8+(CT-1#9*7)
+6 SET DATA=$PIECE($$ICD9^IBACSV(+DATA),U,1)
+7 DO MPGUB(PG,0,DATA,56,COL)
+8 QUIT
+9 ;
XVAL(DATA,CT) ; Output any UB value codes after 12 on new page(s)
+1 ; DATA = output data from IBXSAVE("VC",CT)
+2 ; CT = array sequence # of the value code being output
+3 ;
+4 NEW COL,PG,OFFSET
+5 SET PG=(CT-1)\12+1
SET COL=44+(CT-1#3*13)
SET OFFSET=(CT-(12*(PG-1))-1)\3
+6 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,1),14,COL)
+7 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,2),14,COL+3)
+8 QUIT
+9 ;
XCC(DATA,CT) ; Output any UB condition codes after 11 on new page(s)
+1 ; 11 condition codes per page, starting columns 34 thru 64
+2 ; DATA = output data from IBXSAVE("CC",CT)
+3 ; CT = array sequence # of the condition code being output
+4 ;
+5 NEW COL,PG
+6 SET PG=(CT-1)\11+1
SET COL=34+(CT-1#11*3)
+7 DO MPGUB(PG,0,DATA,9,COL)
+8 QUIT
+9 ;
XOCC(DATA,CT,FL) ; Output any UB occurrence codes after 8 (2 per form
+1 ; locators 31-34) on new page(s)
+2 ; DATA = data from IBXSAVE("OCC",z) to be output
+3 ; CT = array sequence # of occurrence code being output
+4 ; FL = # of form locator being populated with the occ code
+5 ;
+6 NEW COL,PG,OFFSET
+7 SET PG=(CT-1)\2+1
SET COL=1+((FL-31)*10)
SET OFFSET=$SELECT(CT#2:0,1:1)
+8 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,1),11,COL)
+9 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,2),11,COL+4)
+10 QUIT
+11 ;
XOCCS(DATA,CT,FL) ; Output any UB occurrence span codes after 4 on new page(s)
+1 ; DATA = data from IBXSAVE("OCCS",z) to be output
+2 ; CT = array sequence # of occurrence span code being output
+3 ; FL = # of form locator being populated (either FL 35 or 36)
+4 ;
+5 NEW COL,PG,OFFSET
+6 SET PG=(CT-1)\2+1
SET OFFSET=$SELECT(CT#2:0,1:1)
+7 SET COL=41+((FL-35)*17)
+8 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,1),11,COL)
+9 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,2),11,COL+4)
+10 DO MPGUB(PG,OFFSET,$PIECE(DATA,U,3),11,COL+11)
+11 QUIT
+12 ;
FORMAT(VAL,IBX0,IBXDA) ;
+1 IF IBX0'=""
IF IBXDA
SET VAL=$$FORMAT^IBCEFG(VAL,$PIECE($GET(^IBA(364.6,+IBXDA,0)),U,9),$PIECE(IBX0,U,7),IBX0)
+2 QUIT VAL
+3 ;
OUTPDT(IBIFN,IBXSAVE,IBXDATA) ; Returns outpatient service to date
+1 ; formatted CCYYMMDD for UB 837
+2 ; IBIFN = ien of bill (file 399)
+3 ; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE")
+4 ; IBXDATA = array with formatted date or each line item - CCYYMMDD
+5 NEW Z
+6 SET Z=0
FOR
SET Z=$ORDER(IBXSAVE("INPT",Z))
if 'Z
QUIT
SET IBXDATA(Z)=$SELECT($PIECE(IBXSAVE("INPT",Z),U,10):$$DT^IBCEFG1($PIECE(IBXSAVE("INPT",Z),U,10),,"D8"),1:IBXSAVE("DATE"))
+7 KILL IBXSAVE("DATE")
+8 QUIT
+9 ;
