- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m
r613 r623 1 IBCEF3 2 ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389**;21-MAR-94;Build63 4 5 MPG(PG,FLDS,FORM) 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 NONSERV(Z,Z0) 42 43 44 45 46 47 48 PG(VAL,LNCT) 49 50 51 52 53 54 55 56 57 MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 CKREV(CT,VAL) 74 75 76 77 78 79 CKPGUB 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 HCPC(R) 115 116 117 118 PROS(IBIFN) 119 120 121 122 123 124 .S PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0)) ; P389 removed p2 - item ptr file 661 125 .;date^^short descr^entry # in file 362.5126 .S IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0)127 PROSQ 128 129 B24(IBXSV,IBIFN,IBNOSHOW) 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 ALLTYP(IBIFN) 148 INSTYP(IBIFN,SEQ) 149 POLTYP(IBIFN,IBSEQ) 150 ALLPTYP(IBIFN) 151 152 FILL(Z) 153 154 155 156 157 158 159 160 XPROC(DATA,CT) 161 162 163 164 165 166 167 168 169 170 171 XDIAG(DATA,CT) 172 173 174 175 176 177 178 179 180 181 XVAL(DATA,CT) 182 183 184 185 186 187 188 189 190 191 XCC(DATA,CT) 192 193 194 195 196 197 198 199 200 201 XOCC(DATA,CT,FL) 202 203 204 205 206 207 208 209 210 211 212 213 XOCCS(DATA,CT,FL) 214 215 216 217 218 219 220 221 222 223 224 225 226 FORMAT(VAL,IBX0,IBXDA) 227 228 229 230 OUTPDT(IBIFN,IBXSAVE,IBXDATA) 231 232 233 234 235 236 237 238 239 1 IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96 2 ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 MPG(PG,FLDS,FORM) ; Set static flds on pages after page 1 6 ; for either 1500 or UB 7 ; PG = page # 8 ; FORM= 1 for UB, otherwise for 1500 9 ; FLDS: array passed by reference and containing lines OR 10 ; line/column from pg 1 to repeat on subsequent pages 11 ; Format: FLDS(LINE,COL) or FLDS(LINE) for whole line 12 ; CMS-1500: LINES 1-5,7-43,57 from col 1 to 50, 58-63 13 ; UB: see CKPGUB for lines and columns 14 ; 15 N Z,Z0,Z1,LPG 16 S FORM=$S($G(FORM)=1:3,1:2) 17 I FORM=2 D ; print page # on each pg, totals on last page of 1500 18 . S LPG=+$O(^TMP("IBXDATA",$J,IBXREC,""),-1) 19 . S Z="[Page "_PG_" of "_LPG_"]" 20 . S Z=$$FO^IBCNEUT1(Z,17,"R") 21 . D SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE) 22 . I PG=2 S Z=$P(Z,"[",1)_"[Page 1 of "_LPG_"]" D SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE) 23 . I LPG=PG D 24 .. ; 25 .. ; esg - IB*2*348 - update dollar format for last page of 1500 26 .. ; 27 .. D SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($G(IBXSAVE("TOT")),9),.IBXSIZE) 28 .. D SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($G(IBXSAVE("PAID")),8),.IBXSIZE) 29 .. D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE) 30 .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID") 31 ; 32 S Z=0 F S Z=$O(FLDS(Z)) Q:'Z D 33 . I $O(FLDS(Z,""))="" D Q ;repeats line 34 .. 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) 35 . 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) 36 . I FORM=2,LPG'=PG D 37 .. D SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE) 38 .. D SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE) 39 Q 40 ; 41 NONSERV(Z,Z0) ; Set variable if non-service/non-text data is present for box 42 ; 24 of CMS-1500 43 ; Z = sequence of IBXSAVE being processed 44 ; Z0 = sequnce within IBXDATA to indicate actual line # 45 I $P(IBXSAVE("BOX24",Z),U)="" S IBXSAVE("NON-SERV",Z0)="" 46 Q 47 ; 48 PG(VAL,LNCT) ;Set next pg for CMS-1500 lines 49 ;VAL = value of fld 50 ;LNCT = line # from IBXSAVE("BOX24") array 51 N IBP,IBL 52 S IBP=LNCT\12+(LNCT#12>0),IBL=LNCT-(12*(IBP-1))-1 53 I IBL'<0 S VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) D SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE) 54 K IBXDATA(LNCT) 55 Q 56 ; 57 MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) ; Set up pages > 1 for UB overflows 58 ; PG = Page # to set (REQUIRED) 59 ; OFFSET = offset from first line this should be extracted into 60 ; 0 = first line (REQUIRED) 61 ; VAL = value to set (REQUIRED) 62 ; IBLN = line to set data at (if null, uses IBXLN) 63 ; IBCOL = column to set data at (if null, uses IBXCOL) 64 ; NOFORM = don't format, just output data as passed 65 ; Assumes formatter IBXLN,IBXCOL variables exist 66 ; 67 I $G(IBLN)="" S IBLN=IBXLN 68 I $G(IBCOL)="" S IBCOL=IBXCOL 69 S:'$G(NOFORM) VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) 70 D SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE) 71 Q 72 ; 73 CKREV(CT,VAL) ; Check too many rev code lines to fit on page 74 ; This procedure is only called when CT>22 (i.e. 23 or more) 75 ; 76 D MPGUB((CT-1)\22+1,CT-1#22,VAL) ; 22 codes on a single page 77 Q 78 ; 79 CKPGUB ; Check to see if multiple UB pages are needed then populate 80 ; static flds from page 1, add page numbers 81 ; 82 N FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2 83 ; 84 S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1),IBP=0 85 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 86 I 'IBP K ^TMP("IBXDATA",$J,IBXREC,LPG) S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1) Q:LPG=1 87 ; 88 ; Static flds 89 F Z=2:1:7 S FLDS(Z)="" ; FL-1 thru FL-9 90 F Z=1,10,13,19,22,25,28,31 S FLDS(9,Z)="" ; FL-10 thru FL-17 91 F Z=13:1:17 S FLDS(Z,1)="" ; payer address in FL-38 92 S FLDS(41,46)="" ; creation date 93 F Z=42,43,44,45,47,48,49,51,52,53 S FLDS(Z)="" ; FL-50 thru FL-65 94 F Z=57,59,61,63 S (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))="" ; FL-76-79 ID's 95 F Z=58,60,62,64 S (FLDS(Z,53),FLDS(Z,71))="" ; FL-76-79 Names 96 ; 97 F IBPG=1:1:LPG D 98 . ; Add pg # to last line of rev codes if multiple pages 99 . N IB,IBP 100 . S IB=$G(^TMP("IBXDATA",$J,IBXREC,IBPG,41,6)) 101 . D MPGUB(IBPG,0,IBPG,41,10,1) 102 . D MPGUB(IBPG,0,LPG,41,16,1) 103 . D:IBPG>1 MPG(IBPG,.FLDS,1) 104 . Q 105 ; print totals on line 41 of the last page 106 S (TOT1,TOT2)=0 107 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) 108 D MPGUB(IBPG,0,"0001",41,1,1) 109 D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT1,9),41,61,1) 110 D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT2,9),41,71,1) 111 ; 112 Q 113 ; 114 HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value) 115 ; R = flag for type of fld (1/2/3) being printed in rev code block 116 Q R ;No longer used as of patch IB*2.0*51 117 ; 118 PROS(IBIFN) ; Extract billable prosthetics for 837 119 N IBARRAY,Z,Z0,CT,PROS 120 D SET^IBCSC5B(IBIFN,.IBARRAY) 121 I '$P(IBARRAY,U,2) S CT="" G PROSQ 122 S Z="",CT=0 123 F S Z=$O(IBARRAY(Z)) Q:Z="" S Z0="" F S Z0=$O(IBARRAY(Z,Z0)) Q:Z0="" S CT=CT+1 D 124 .S PROS=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+IBARRAY(Z,Z0),0)),U,3)),U,2) 125 .;date^item ptr file 661^short descr from file 441^entry # in file 362.5 126 .S IBXDATA(CT)=Z_U_Z0_U_PROS_U_+IBARRAY(Z,Z0) 127 PROSQ Q CT 128 ; 129 B24(IBXSV,IBIFN,IBNOSHOW) ; Code to execute to set up IBXSV("BOX24") for 130 ; print or IBXSAVE("OUTPT") for transmit - called by output formatter 131 ; IBNOSHOW = 1 if not to show error/warning text lines 132 ; Pass IBXSV by reference 133 N IBSUB 134 S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT") 135 K IBXSV(IBSUB) 136 I '$D(IBIFN) S IBIFN=$G(IBXIEN) 137 I IBIFN D F^IBCEF("N-HCFA 1500 SERVICE"_$S(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN) 138 I $S(IBSUB'["24":1,1:'$G(IBNOSHOW)) D 139 . M IBXSV(IBSUB)=IBXDATA 140 E D 141 . N Z,CT 142 . 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) 143 Q 144 ; 145 ; esg - 11/14/03 - Moved the below functions due to space constraints 146 ; 147 ALLTYP(IBIFN) Q $$ALLTYP^IBCEF31(IBIFN) 148 INSTYP(IBIFN,SEQ) Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ)) 149 POLTYP(IBIFN,IBSEQ) Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ)) 150 ALLPTYP(IBIFN) Q $$ALLPTYP^IBCEF31(IBIFN) 151 ; 152 FILL(Z) ; 153 Q 154 ; 155 ; ***** 156 ; The following code performs the multi-page set up for 157 ; printing overflow data on the UB 158 ; ***** 159 ; 160 XPROC(DATA,CT) ; Output any UB procedures after 6 on new page(s) 161 ; DATA = output data from IBXSAVE("PROC",CT) 162 ; CT = array sequence # of the procedure being output 163 ; Only used for local prints 164 N OFFSET,PG,COL,PRCODE,Q 165 S Q=(CT-1)\3#2,OFFSET=$S('Q:0,1:2) 166 S PG=(CT-1)\6+1,COL=1+(CT-1#3*15) 167 D MPGUB(PG,OFFSET,$P(DATA,U,1),58,COL) 168 D MPGUB(PG,OFFSET,$P(DATA,U,2),58,COL+9) 169 Q 170 ; 171 XDIAG(DATA,CT) ; Output any UB other diagnoses after 8 on new page(s) 172 ; DATA = output data from IBXSAVE("DX",CT) 173 ; CT = array sequence # of the diagnosis being output 174 ; Only used for local prints 175 N COL,PG 176 S PG=(CT-1)\8+1,COL=8+(CT-1#9*7) 177 S DATA=$P($$ICD9^IBACSV(+DATA),U,1) 178 D MPGUB(PG,0,DATA,56,COL) 179 Q 180 ; 181 XVAL(DATA,CT) ; Output any UB value codes after 12 on new page(s) 182 ; DATA = output data from IBXSAVE("VC",CT) 183 ; CT = array sequence # of the value code being output 184 ; 185 N COL,PG,OFFSET 186 S PG=(CT-1)\12+1,COL=44+(CT-1#3*13),OFFSET=(CT-(12*(PG-1))-1)\3 187 D MPGUB(PG,OFFSET,$P(DATA,U,1),14,COL) 188 D MPGUB(PG,OFFSET,$P(DATA,U,2),14,COL+3) 189 Q 190 ; 191 XCC(DATA,CT) ; Output any UB condition codes after 11 on new page(s) 192 ; 11 condition codes per page, starting columns 34 thru 64 193 ; DATA = output data from IBXSAVE("CC",CT) 194 ; CT = array sequence # of the condition code being output 195 ; 196 N COL,PG 197 S PG=(CT-1)\11+1,COL=34+(CT-1#11*3) 198 D MPGUB(PG,0,DATA,9,COL) 199 Q 200 ; 201 XOCC(DATA,CT,FL) ; Output any UB occurrence codes after 8 (2 per form 202 ; locators 31-34) on new page(s) 203 ; DATA = data from IBXSAVE("OCC",z) to be output 204 ; CT = array sequence # of occurrence code being output 205 ; FL = # of form locator being populated with the occ code 206 ; 207 N COL,PG,OFFSET 208 S PG=(CT-1)\2+1,COL=1+((FL-31)*10),OFFSET=$S(CT#2:0,1:1) 209 D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL) 210 D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4) 211 Q 212 ; 213 XOCCS(DATA,CT,FL) ; Output any UB occurrence span codes after 4 on new page(s) 214 ; DATA = data from IBXSAVE("OCCS",z) to be output 215 ; CT = array sequence # of occurrence span code being output 216 ; FL = # of form locator being populated (either FL 35 or 36) 217 ; 218 N COL,PG,OFFSET 219 S PG=(CT-1)\2+1,OFFSET=$S(CT#2:0,1:1) 220 S COL=41+((FL-35)*17) 221 D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL) 222 D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4) 223 D MPGUB(PG,OFFSET,$P(DATA,U,3),11,COL+11) 224 Q 225 ; 226 FORMAT(VAL,IBX0,IBXDA) ; 227 I IBX0'="",IBXDA S VAL=$$FORMAT^IBCEFG(VAL,$P($G(^IBA(364.6,+IBXDA,0)),U,9),$P(IBX0,U,7),IBX0) 228 Q VAL 229 ; 230 OUTPDT(IBIFN,IBXSAVE,IBXDATA) ; Returns outpatient service to date 231 ; formatted CCYYMMDD for UB 837 232 ; IBIFN = ien of bill (file 399) 233 ; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE") 234 ; IBXDATA = array with formatted date or each line item - CCYYMMDD 235 N Z 236 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")) 237 K IBXSAVE("DATE") 238 Q 239 ;
Note:
See TracChangeset
for help on using the changeset viewer.
