- 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/IBCEF22.m
r613 r623 1 IBCEF22 2 ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349,389**;21-MAR-94;Build63 4 5 6 HOS(IBIFN) 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 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 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 115 116 117 118 119 120 121 122 123 124 ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54)125 126 127 ACCRV(X) 128 129 1 IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96 2 ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; OVERFLOW FROM ROUTINE IBCEF2 6 HOS(IBIFN) ; Extract rev codes for episode billed on a UB-04 into IBXDATA 7 ; IBIFN = bill ien 8 ; Format: IBXDATA(n) = 9 ; rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charge 10 ; ^ tot uncov^ FL49 value ^ ien of rev code multiple entry(s) 11 ; (separated by ";") 12 ; ^ modifiers specific to rev code/proc (separated by ",") 13 ; ^ rev code date, if it can be determined by a corresponding proc 14 ; 15 ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line 16 ; item found in an accepted EOB for the bill and = the reference 17 ; line in the first '^' piece followed by the '0' node of file 18 ; 361.115 (LINE LEVEL ADJUSTMENTS) 19 ; COB = COB seq # of adjustment's ins co, m = seq # 20 ; -- AND -- 21 ; IBXDATA(IBI,"COB",COB,m,z,p)= 22 ; the '0' node for each subordinate entry of file 23 ; 361.11511 (REASONS) (Only first 3 pieces for 837) 24 ; z = group code, sometimes preceeded by a space p = seq # 25 ; 26 N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTRA,IBX1,IBXS,IBP,IBPO,IBP1,IBDEF,Z,Z0,Z1,ZX,QQ,IBMOD 27 S IBINPAT=$$INPAT^IBCEF(IBIFN,1) 28 I 'IBINPAT D F^IBCEF("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN) 29 S IBDEF=$G(IBZ) 30 ; loop through all proc codes - sort by procedure, modifiers and print order 31 S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"CP",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ D 32 . S IBP(+$P(IBZ,U)_U_$$GETMOD^IBEFUNC(IBIFN,IBDA,1),$S($P(IBZ,U,4):$P(IBZ,U,4),1:999),IBDA)=$P(IBZ,U,2) 33 ; loop through all rev codes - sort by rev code 34 S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"RC",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ S IBMOD="" D 35 . S IBX=$G(^DGCR(399.2,+IBZ,0)),IBX1="",IBPO=0 36 . ; Auto-added procedure charge 37 . I $P(IBZ,U,10)=4,$P(IBZ,U,11) D ; Soft link to proc 38 .. S Z=$G(^DGCR(399,IBIFN,"CP",$P(IBZ,U,11),0)) 39 .. Q:Z="" 40 .. S ZX=+Z_U_$$GETMOD^IBEFUNC(IBIFN,$P(IBZ,U,11),1) 41 .. Q:'$O(IBP(ZX,0))&'$O(IBP1(ZX,0)) 42 .. I $P(IBZ,U,6) Q:$S($P(Z,U)'["ICPT":1,1:+$P(Z,U)'=$P(IBZ,U,6)) 43 .. S Z0=$S($D(IBP(ZX)):$O(IBP(ZX,0)),1:$O(IBP1(ZX,0))) 44 .. S:'Z0 Z0=999 45 .. Q:'$D(IBP(ZX,+Z0,$P(IBZ,U,11)))&'$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) 46 .. I '$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) S IBP1(ZX,+Z0,$P(IBZ,U,11))=IBP(ZX,+Z0,$P(IBZ,U,11)) K IBP(ZX,+Z0,$P(IBZ,U,11)) 47 .. S IBX1=$P(Z,U,2),IBPO=+Z0,IBMOD=$P(ZX,U,2) 48 . ; Manually added charge with a procedure 49 . I $P(IBZ,U,6),$S($P(IBZ,U,10)=4:'$P(IBZ,U,11),1:1),+$O(IBP($P(IBZ,U,6)))=$P(IBZ,U,6) D 50 .. ; No direct link, but a proc exists on rev code and in procedure mult without and then with modifiers 51 .. S ZX=$O(IBP($P(IBZ,U,6))) 52 .. F QQ=1,2 Q:IBPO S Z="" F S Z=$O(IBP(ZX,Z),-1) Q:'Z!(IBPO) S Z0=0 F S Z0=$O(IBP(ZX,Z,Z0)) Q:'Z0 S Z1=$G(^DGCR(399,IBIFN,"CP",Z0,0)) D Q:IBPO 53 ... ; Ignore if not a CPT or a modifier exists and this is first pass 54 ... S IBMOD=$$GETMOD^IBEFUNC(IBIFN,Z0,1) 55 ... Q:$S($P(Z1,U)'["ICPT":1,QQ=1:IBMOD'="",1:0) 56 ... S IBPO=+$P(Z1,U,4),IBX1=$P(Z1,U,2) 57 ... K IBP(+Z1_U_IBMOD,Z,Z0) 58 . ; 59 . I IBX'="" D ; revenue code is valid 60 .. F Z=900:1 S Z0=$S(IBPO:IBPO,$D(IBX(" "_$P(IBX,U),Z)):0,1:Z) I Z0 S IBPO=Z0 Q 61 .. S IBX(" "_$P(IBX,U),IBPO,IBDA)=IBX,IBX(" "_$P(IBX,U),IBPO,IBDA,"DT")=$S(IBX1:IBX1,1:IBDEF),IBX(" "_$P(IBX,U),IBPO,IBDA,"MOD")=IBMOD 62 ; 63 S IBS="" F S IBS=$O(IBX(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX(IBS,IBPO)) Q:'IBPO D 64 . S IBDA=0 F S IBDA=$O(IBX(IBS,IBPO,IBDA)) Q:'IBDA S IBX=$G(IBX(IBS,IBPO,IBDA)),IBZ=$G(^DGCR(399,IBIFN,"RC",IBDA,0)) I IBX'="" D 65 .. ;S IBXS=$P(IBZ,U,2)_U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) 66 .. S IBXS=U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) ;combine same proc and modifiers regardless of rate 67 .. S:IBPO'<900&'$$ACCRV($P(IBS," ",2))&$S(IBINPAT:$P(IBZ,U,6),1:1) IBCOMB(IBS,IBXS,IBPO)=IBDA 68 .. S:'$D(IBX1(IBS,IBPO,IBXS,1)) IBX1(IBS,IBPO,IBXS,1)=IBX,IBX1(IBS,IBPO,IBXS,2)=IBZ 69 .. S $P(IBX1(IBS,IBPO,IBXS),U)=$P($G(IBX1(IBS,IBPO,IBXS)),U)+$P(IBZ,U,3) 70 .. S $P(IBX1(IBS,IBPO,IBXS),U,2)=$P($G(IBX1(IBS,IBPO,IBXS)),U,2)+$P(IBZ,U,4) 71 .. S IBX1(IBS,IBPO,IBXS,"DT")=$G(IBX(IBS,IBPO,IBDA,"DT")),IBX1(IBS,IBPO,IBXS,"IEN")=$G(IBX1(IBS,IBPO,IBXS,"IEN"))_$S($G(IBX1(IBS,IBPO,IBXS,"IEN")):";",1:"")_IBDA 72 ; 73 S IBS="" F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=899 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO D ; Check to combine like rev codes without print order 74 . N Q,Q0,Q1,Z,Z0,Z1,Z2,IBZ1,IBZ2 75 . S Z="" 76 . N IBACC 77 . F S Z=$O(IBX1(IBS,IBPO,Z)) Q:Z="" S Q=IBPO F S Q=$O(IBCOMB(IBS,Z,Q)) Q:'Q I Q'=IBPO S IBZ1=$G(IBX1(IBS,IBPO,Z,1)),IBZ2=$G(IBX1(IBS,IBPO,Z,2)) D 78 .. Q:$G(IBX1(IBS,IBPO,Z,1))'=$G(IBX1(IBS,Q,Z,1)) 79 .. S Q1=1,IBACC=$$ACCRV(+$P(IBS," ",2)) 80 .. F Q0=1,5:1:7,10:1:13,15 D Q:'Q1 81 ... I IBACC Q:Q0=5!(Q0>6) 82 ... I (Q0=11!(Q0=15))&($P($G(IBX1(IBS,Q,Z,2)),U,10)=3) Q 83 ... I Q0=5,'IBINPAT Q 84 ... I $P($G(IBX1(IBS,IBPO,Z,2)),U,Q0)'=$P($G(IBX1(IBS,Q,Z,2)),U,Q0) S Q1=0 85 .. Q:'Q1 86 .. S $P(IBX1(IBS,IBPO,Z,2),U,3)=$P(IBX1(IBS,IBPO,Z,2),U,3)+$P(IBX1(IBS,Q,Z,2),U,3) 87 .. S $P(IBX1(IBS,IBPO,Z,2),U,4)=$P(IBX1(IBS,IBPO,Z,2),U,4)+$P(IBX1(IBS,Q,Z,2),U,4) 88 .. S $P(IBX1(IBS,IBPO,Z,2),U,9)=$P(IBX1(IBS,IBPO,Z,2),U,9)+$P(IBX1(IBS,Q,Z,2),U,9) 89 .. S IBX1(IBS,IBPO,Z)=$P(IBX1(IBS,IBPO,Z,2),U,3)_U_$P(IBX1(IBS,IBPO,Z,2),U,4) 90 .. S IBX1(IBS,IBPO,Z,"IEN")=IBX1(IBS,IBPO,Z,"IEN")_";"_IBX1(IBS,Q,Z,"IEN") 91 .. K IBX1(IBS,Q,Z) 92 ; 93 S IBS="",IBLN=0 94 F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO S IBSS="" F S IBSS=$O(IBX1(IBS,IBPO,IBSS)) Q:IBSS="" D 95 . S IBX=$G(IBX1(IBS,IBPO,IBSS,1)),IBZ=$G(IBX1(IBS,IBPO,IBSS,2)) 96 . S IBLN=$G(IBLN)+1,IBXDATA(IBLN)=$P(IBX,U)_U_$P(IBZ,U,6)_U_$P(IBZ,U,2)_U_+IBX1(IBS,IBPO,IBSS)_U_+$P(IBX1(IBS,IBPO,IBSS),U,2),$P(IBXDATA(IBLN),U,10)=$G(IBX1(IBS,IBPO,IBSS,"DT")) 97 . S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,2) 98 . ; Extract line lev COB data for sec or tert bill 99 . I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU6(IBIFN,IBLN,.IBXDATA,,.IBXTRA) I $D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,1) ;Handle bundled/unbundled 100 I $D(^IBA(362.4,"AIFN"_IBIFN))!$D(^IBA(362.5,"AIFN"_IBIFN)) D 101 . N IBARRAY,IBX,IBZ,IBRX,IBLCNT 102 . S IBLCNT=0 103 . ; Print prescriptions, prosthetics on front of UB-04 104 . D SET^IBCSC5A(IBIFN,.IBARRAY) 105 . I $P(IBARRAY,U,2) D 106 .. S IBX=+$P(IBARRAY,U,2)+2 107 .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="" 108 .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="PRESCRIPTION REFILLS:",IBLCNT=2 109 .. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY S IBRX=IBARRAY(IBX,IBY) D 110 ... D ZERO^IBRXUTL(+$P(IBRX,U,2)) 111 ... S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBRX,U,6):"$"_$FN($P(IBRX,U,6),",",2),1:""),10)_" "_$J($$FMTE^XLFDT(IBY,2),8)_" "_$G(^TMP($J,"IBDRUG",+$P(IBRX,U,2),.01)) 112 ... S IBZ=$S(+$P(IBRX,U,4):"QTY: "_$P(IBRX,U,4)_" ",1:"")_$S(+$P(IBRX,U,3):"for "_$P(IBRX,U,3)_" days supply ",1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ 113 ... S IBZ=$S($P(IBRX,U,5)'="":"NDC #: "_$P(IBRX,U,5),1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ 114 ... K ^TMP($J,"IBDRUG") 115 ... Q 116 . ; 117 . D SET^IBCSC5B(IBIFN,.IBARRAY) 118 . I $P(IBARRAY,U,2) D 119 .. S IBLCNT=0 120 .. S IBX=+$P(IBARRAY,U,2)+2 121 .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="" 122 .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2 123 .. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY D 124 ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54) 125 Q 126 ; 127 ACCRV(X) ; Returns 1 if X is an accomodation RC, 0 if not 128 Q ((X'<100&(X'>219))!(X=224)) 129 ;
Note:
See TracChangeset
for help on using the changeset viewer.
