- IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
- ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371,432,447,473,516,577,592,608,623,641**;21-MAR-94;Build 61
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- BOX24D(A,IB) ; Returns the lines for boxes 19-24 of the CMS-1500 display
- ; IB = flag is 1 if only box 24 is needed
- Q $S('$G(IB):"36",1:"44")_"^55"
- ;
- RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display
- Q "19^41"
- ;
- OUTPT(IBIFN,IBPRINT) ; Returns an array of service line data from
- ; CMS-1500 box 24. Output is in IBXDATA(n)
- ; IBPRINT = print flag 1: return print fields
- ; 0: return EDI fields
- ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ #
- ; if it already exists. If not, it builds it from N-DIAGNOSES element
- ;
- ; For EDI call: Returns IBXDATA(n)=
- ; begin date(YYYYMMDD) ^ end date(YYYYMMDD) ^ pos ^ tos ^
- ; proc code/revenue code - if no procedure (not the pointers) ^
- ; type of code ^ dx pointer(s ) ^ unit charge ^ units ^ modifiers separated by ;
- ; ^ purchased charge amount ^ anesthesia minutes ^ emergency indicator ^
- ; lab-type service flag ^ NDC ^ Units/Quantity ^ Unit/Basis of Measurement (vd/IB*2*577)
- ;
- ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
- ; item found in an accepted EOB for the bill and = the reference
- ; line in the first '^' piece followed by the '0' node data of file
- ; 361.115 (LINE LEVEL ADJUSTMENTS)
- ; COB = COB sequence # of adjustment's ins co, m = seq #
- ; -- AND --
- ; IBXDATA(IBI,"COB",COB,m,z,p)=
- ; the data on the '0' node for each subordinate entry of file
- ; 361.11511 (REASONS) (Only first 3 pieces for 837 output)
- ; z = group code, sometimes preceeded by a space p = seq #
- ;
- ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or
- ; null if equal to begin date^pos^tos^bedsection name(if no procedure)
- ; or procedure code(not the pointer)^ ... refer to EDI call results
- ; Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24,
- ; If no procedure code, returns IBXDATA(n,"A")=rev code abbrev
- ;
- ; For both calls, returns IBXDATA(n,item type,item ptr)=""
- ; -- AND --
- ; IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days
- ; ^chrge^ien of file 362.4^NDC format
- ; If line references a prescription
- ; -- AND --
- ; If no revenue code for a prescription, returns IBXDATA(n,"ARX")=""
- ; -- AND --
- ; IBXDATA(n,"AUX")='AUX' node of the procedure entry
- ;
- ; Also returns IBXDATA(n,"CPLNK") = soft link to corresponding entry in PROCEDURES multiple of file 399
- ;
- N IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1
- ;
- K ^TMP($J,"IBITEM")
- S ^TMP($J,"IBITEM")=""
- ; Build diagnosis array if not already built
- I $O(^TMP("IBXSAVE",$J,"DX",IBIFN,""))="",$O(^IBA(362.3,"AIFN"_IBIFN,"")) D
- .N Z,IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN)
- .S Z="" F S Z=$O(IBXDATA(Z)) K:$O(IBXDATA(0))=""&(Z="") IBXDATA Q:Z="" S:$P(IBXDATA(Z),U,2) ^TMP("IBXSAVE",$J,"DX",IBIFN,$P(IBXDATA(Z),U,2))=Z
- ;
- S IB(0)=$G(^DGCR(399,IBIFN,0)),IB("U")=$G(^("U")),IB("U1")=$G(^("U1"))
- S IBI="" F S IBI=$O(^TMP("IBXSAVE",$J,"DX",IBIFN,IBI)) Q:IBI="" S IBDXI(IBI)=^(IBI)
- I '$G(IBPRINT) D RVCE^IBCF23(IBIFN,IBIFN)
- I $G(IBPRINT) D RVCE^IBCF23(,IBIFN)
- ; Returns IBFLD(24) = begin date ^ end date ^ pos ^ tos ^
- ; proc/bedsection/revenue code ^ dx pointer ^ unit charge ^
- ; units ^ modifiers ^ purchased charge amount ^ anesthesia minutes ^
- ; emergency indicator ^ soft pointer to PROCEDURES multiple in file 399 ^
- ; NDC ^ Units
- ; IBFLD(24,n,type,item)=""
- ; IBFLD(24,n_"A") = revenue code abbreviation if no procedure
- ; IBFLD(24,n,"AUX") = 'AUX' node of line item
- ; IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld
- ; (can be null)
- ;
- D SET^IBCSC5A(IBIFN,.IBRX) ;prescriptions
- ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge
- I IBRX S IBRX="" F S IBRX=$O(IBRX(IBRX)) Q:IBRX="" S IBRX0=0 F S IBRX0=$O(IBRX(IBRX,IBRX0)) Q:'IBRX0 D
- . N IBRXH
- . S IBRXH=IBRX(IBRX,IBRX0)
- . ; **IB*2.0*432** added _U_$P(IBRXH,U,9) (Rx Date) to Output Formatter
- . S IBRX1(+IBRXH)=IBRX_U_$P(IBRXH,U,2)_U_$P(IBRXH,U,5)_U_$P(IBRXH,U,7)_U_IBRX0_U_$P(IBRXH,U,4)_U_$P(IBRXH,U,3)_U_$P(IBRXH,U,6)_U_+IBRXH_U_$P(IBRXH,U,8)_U_$P(IBRXH,U,9)
- K IBRX
- ;
- ; for EDI, remove any $0 line items from the IBFLD array before
- ; dropping down into the next loop (IB*2*371)
- ; Start IB*2.0*447 BI - Code removed to allow 0 dollars to print.
- ;I '$G(IBPRINT) D
- ;. NEW IBZ,IBI,Z
- ;. M IBZ=IBFLD K IBFLD
- ;. S (IBI,Z)=0
- ;. F S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI D
- ;.. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q
- ;.. S Z=Z+1
- ;.. M IBFLD(24,Z)=IBZ(24,IBI)
- ;.. S IBFLD(24)=Z
- ;.. Q
- ;. Q
- ; End IB*2.0*447 BI
- ;
- S IBI=0
- F S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI D
- . S IBRX1=0
- . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2))
- . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5)
- . S $P(IBXDATA(IBI),U,6)=$S($D(IBFLD(24,IBI_"X")):"CJ",1:"HC")
- . S $P(IBXDATA(IBI),U,7,13)=$P(IBFLD(24,IBI),U,6,12)
- . S $P(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI))
- . ; MRD;IB*2.0*516 - Added NDC and Units to line level of claim,
- . ; pieces 14 & 15 of IBFLD, pieces 15 & 16 of IBXDATA. Print
- . ; in Box 24 by setting in IBXDATA(IBI,"TEXT").
- . ;S $P(IBXDATA(IBI),U,15,16)=$P(IBFLD(24,IBI),U,14,15)
- . ;I $P(IBFLD(24,IBI),U,14)'="" S IBXDATA(IBI,"TEXT")="N4"_$P(IBFLD(24,IBI),U,14)_" UN"_$P(IBFLD(24,IBI),U,15)
- . ; vd/IB*2*577 - Added Unit/Basis of Measurement to line level of claim,
- . ; piece 16 of IBFLD, piece 17 of IBXDATA.
- . ; Print in Box 24 by setting in IBXDATA(IBI,"TEXT").
- . S $P(IBXDATA(IBI),U,15,17)=$P(IBFLD(24,IBI),U,14,16)
- . I $P(IBFLD(24,IBI),U,14)'="" S IBXDATA(IBI,"TEXT")="N4"_$P(IBFLD(24,IBI),U,14)_" "_$P(IBFLD(24,IBI),U,16)_$P(IBFLD(24,IBI),U,15)
- . ;
- . I $D(IBFLD(24,IBI,"RX")) D ;Rx
- .. S IBRX1=1
- .. I $P($G(IBFLD(24,IBI,"AUX")),U,8)'="" S $P(IBFLD(24,IBI,"AUX"),U,8)="",$P(IBFLD(24,IBI,"AUX"),U,9)="" ;No free text allowed for rx's
- .. I $D(IBRX1(+IBFLD(24,IBI,"RX"))) D Q ;Soft link exists
- ...D ZERO^IBRXUTL(+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2))
- ... S IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX")),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30)
- ... K IBRX1(+IBFLD(24,IBI,"RX"))
- ... ; No soft link - must find the first Rx with the same charge
- .. S IBRX="" F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX I +$P(IBRX1(IBRX),U,8)=+$P(IBXDATA(IBI),U,8) D Q
- ... D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
- ... S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) Q
- ... Q
- .. Q
- . ;
- . ; MRD;IB*2.0*516 - If additional service line comments to appear in
- . ; Box 24, concatenate to front if something (NDC) is already there.
- . I $G(IBFLD(24,IBI,"AUX"))'="" D
- .. I $G(IBPRINT),$P(IBFLD(24,IBI,"AUX"),U,8)'="" D
- ... I $G(IBXDATA(IBI,"TEXT"))'="" S IBXDATA(IBI,"TEXT")=$E($P(IBFLD(24,IBI,"AUX"),U,8)_" "_IBXDATA(IBI,"TEXT"),1,59)
- ... E S IBXDATA(IBI,"TEXT")=$P(IBFLD(24,IBI,"AUX"),U,8)
- ... S $P(IBFLD(24,IBI,"AUX"),U,8)=""
- ... Q
- .. S IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX")
- .. Q
- . ;
- . ;JWS;IB*2.0*592:US131
- . I $G(IBFLD(24,IBI,"DEN"))'="" S IBXDATA(IBI,"DEN")=IBFLD(24,IBI,"DEN")
- . I $G(IBFLD(24,IBI,"DEND"))'="" S IBXDATA(IBI,"DEND")=$P(IBFLD(24,IBI,"DEND"),"^",4)
- . I $O(IBFLD(24,IBI,"DEN1",0)) M IBXDATA(IBI,"DEN1")=IBFLD(24,IBI,"DEN1")
- . ;end - ;JWS;IB*2.0*592:US131
- . I $G(IBPRINT) D
- .. ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
- .. ; I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D Q
- .. I $P(IBXDATA(IBI),U,8)="",'$G(IBXDATA(IBI,"RX")) D Q
- ... ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
- ... I $G(IBNOSHOW) Q ; don't show errors/warnings
- ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE ="
- ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
- ... Q
- .. ;
- .. I $G(IBFLD(24,IBI_"A"))'="" D Q
- ... S IBXDATA(IBI,"A")=IBFLD(24,IBI_"A")
- ... I $G(IBNOSHOW) Q ; don't show errors/warnings
- ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A")
- ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
- ... Q
- .. ;
- .. S IBRX=$G(IBXDATA(IBI,"RX"))
- .. I IBRX'="" D ;Format Rx detail
- ... N Z
- ... S Z=$P(IBRX,U)
- ... S Z=$S(Z'="":"Rx#"_Z_" ",1:"RX: ")
- ... S IBXDATA(IBI,"TEXT")=Z_$S($P(IBRX,U,3)'="":"NDC: "_$P(IBRX,U,3),1:"NOC: "_$P(IBRX,U,2))_" Qty: "_$P(IBRX,U,6)_" Days: "_$P(IBRX,U,7)
- ... S $P(IBXDATA(IBI,"AUX"),U,9)="N4" ; service line comment qualifier for RX's
- ... Q
- .. Q
- . S IBXDATA(IBI,"CPLNK")=$P(IBFLD(24,IBI),U,13)
- . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA)
- . Q
- ;
- I $G(IBPRINT) D
- . S IBRX=0 F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX D
- .. S IBI=+$O(IBXDATA(""),-1)+1
- .. S IBXDATA(IBI)=$$DATE($P(IBRX1(IBRX),U,5))
- .. S IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$P(IBRX1(IBRX),U)_" NDC #: "_$P(IBRX1(IBRX),U,3)
- .. I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
- .. S IBXDATA(IBI,"ARX")=""
- .. D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
- .. S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX)
- .. Q
- . Q
- ;
- I '$G(IBPRINT),$D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,0) ;Handle bundled/unbundled lines
- K ^TMP($J,"IBDRUG")
- Q
- ;
- ISLAB(LDATA) ; Returns 0/1 if line item data indicates the item is a lab (1)
- ; 'LAB' is defined here as type of service = 5
- Q $E($P(LDATA,U,4))="5"
- ;
- FMT(DATA,DLEN,FLEN) ; Returns a string in DATA with a max length of DLEN
- ; and a field length of FLEN
- Q $E($E(DATA,1,DLEN)_$J("",FLEN),1,FLEN)
- ;
- DATE(X,DEL) ; Returns FM date in X as MMxDDxYYYY where x=DEL
- S DEL=$G(DEL)
- S X=$$DATE^IBCF2(X,1,1)
- I X'="" S X=$E(X,1,2)_DEL_$E(X,3,4)_DEL_$E(X,5,8)
- Q X
- ;
- BATCH() ; Sets up record for and stores/returns the next batch number
- N NUM,FAC,DO,DD,DLAYGO,DIC,X,Y
- ;Keep latest batch number for view/print edi bill extract data option
- I $D(IBVNUM) S NUM=IBVNUM G BATCHQ
- ;Check for batch resubmit - if yes, use same number as original batch
- I $P($G(^TMP("IBRESUBMIT",$J)),U,3)=1 S NUM=$P(^($J),U) G BATCHQ
- ;JWS;IB*2.0*623v24;7/17/19 increased lock timeout to 10 sec from 5
- ;JWS;IB*2.0*641v12;5/21/20 testing increase of lock timeout to 30 sec, from 10
- L +^IBA(364.1,0):30 I '$T Q 0
- S FAC=+$P($$SITE^VASITE(),U,3),NUM=$O(^IBA(364.1,"B",""),-1)
- S NUM=NUM+1
- ;JWS;IB*2.0*641v8;increase batch# field from 10 to 12
- ;;I $L(NUM)<12 S NUM=FAC_"00"_$E(NUM,4,10)
- ;I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F D Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="")
- ;. I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK
- ;. S NUM=$O(^IBA(364.1,"B",""),-1)
- ;JWS;IB*2.0*623v24;commented out code below, thus needed to set NUM=NUM+1 above
- ;JWS;IB*2.0*623;bug when number = 4424420000
- ;F S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM))
- ;JWS;IB*2.0*623v24;commented out code below, looking for unused batch#s
- ;I $E(NUM,1,3)'=FAC S NUM=FAC_"0000001"
- ;F Q:'$D(^IBA(364.1,"B",NUM)) S NUM=NUM+1
- ;
- K DO,DD S DIC="^IBA(364.1,",DLAYGO=364.1,DIC(0)="L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM=0
- L -^IBA(364.1,0)
- ;
- BATCHQ Q NUM
- ;
- GETLDAT(IBXIEN) ; Extract data for 837 transmission LDAT record
- ; IBXIEN - ien in file 399
- ; Sets up IBXSAVE("LDAT",n) array:
- ; Attachment report type ^ Attachment report transmission code ^ Attachment control number ^
- ; OB Anesthesia Additional Units ^ Purchase Service Provider ID ^ Purchase Service Amount ^
- N CPIEN,FTYPE,IBXDATA,IDS,IBIDS,NODE1,PSAMNT,PSPID,Z,PCE1,LINE
- I '+$G(IBXIEN) Q
- K IBXSAVE("LDAT")
- S FTYPE=$$FT^IBCEF(IBXIEN)
- ;JWS;IB*2.0*592; added Dental form
- I FTYPE=2!(FTYPE=7) D OUTPT(IBXIEN,0)
- I FTYPE=3 D HOS^IBCEF2(IBXIEN)
- D ALLIDS^IBCEFP(IBXIEN,.IDS,1)
- S (PSPID,PSAMNT)=""
- ; IB*2.0*473/TAZ - Convert PROVIDER code to function call to PSID^IBCEFP
- I $$SUB1OK^IBCEP8A(IBXIEN),(FTYPE=2) D
- . D PSID^IBCEFP(IBXIEN,.IDS,.IBIDS)
- . S PSPID=$G(IBIDS(0)) I PSPID="" S PSPID=$P($G(IBIDS(1)),U,1)
- ;IB*2.0*473/TAZ - END
- S Z=0 F S Z=$O(IBXDATA(Z)) Q:'Z D
- . S CPIEN=+$G(IBXDATA(Z,"CPLNK")) ;I 'CPIEN Q
- . I FTYPE=2,$$SUB1OK^IBCEP8A(IBXIEN) S PSAMNT=$$DOLLAR^IBCEFG1($P($G(IBXDATA(Z)),U,11))
- . S (PCE1,NODE1)=""
- . I CPIEN D
- . . S NODE1=$G(^DGCR(399,IBXIEN,"CP",CPIEN,1))
- . . S PCE1=$$GET1^DIQ(399.0304,CPIEN_","_IBXIEN_",",71)
- . . Q
- . ; MRD;IB*2.0*516 - Added addl. procedure description as piece 7
- . ; of IBXSAVE, which will exist only if the procedure ends in '99'
- . ; or is an 'NOC/NOS' procedure.
- . ;JWS;IB*2.0*592;do not include NOC description here for Dental claims
- . S IBXSAVE("LDAT",Z)=PCE1_U_$P(NODE1,U,3)_U_$P(NODE1,U)_U_$P(NODE1,U,5)_U_$G(PSPID)_U_$G(PSAMNT)_U_$S(FTYPE=7:"",1:$P(NODE1,U,4))
- . Q
- Q
- ;
- ;/Beginning of IB*2.0*608 (US9) - vd
- LDAT ;
- N Z K IBXDATA
- S Z=0 F S Z=$O(IBXSAVE("LDAT",Z)) Q:'Z D
- . S IBXDATA(Z)=Z D:Z>1 ID^IBCEF2(Z,"LDAT")
- ;
- I +$G(VC80) D
- . S Z=$O(IBXDATA(""),-1)+1
- . D ID^IBCEF2(Z,"LDAT")
- . D VC80L(IBXIEN,Z) ; Process for 'SNF' claims & the last claim line
- . S A=Z
- . S IBXDATA(Z)=A
- Q
- ;
- VC80L(IBIFN,LN) ; Extracts the data for the "LDAT" record for VALUE CODE 80 Line item.
- ; IBIFN = Claims internal id number
- ; LN =
- N VC80LN
- S VC80LN=LN
- S $P(IBXSAVE("LDAT",VC80LN),U,11)="6R"
- S $P(IBXSAVE("LDAT",VC80LN),U,12)=VC80LN_"_"_$$GET1^DIQ(399,IBIFN_", ",.01)
- Q
- ;/Ending of IB*2.0*608 - vd
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF11 13989 printed Jan 18, 2025@03:11:11 Page 2
- IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
- +1 ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371,432,447,473,516,577,592,608,623,641**;21-MAR-94;Build 61
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- BOX24D(A,IB) ; Returns the lines for boxes 19-24 of the CMS-1500 display
- +1 ; IB = flag is 1 if only box 24 is needed
- +2 QUIT $SELECT('$GET(IB):"36",1:"44")_"^55"
- +3 ;
- RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display
- +1 QUIT "19^41"
- +2 ;
- OUTPT(IBIFN,IBPRINT) ; Returns an array of service line data from
- +1 ; CMS-1500 box 24. Output is in IBXDATA(n)
- +2 ; IBPRINT = print flag 1: return print fields
- +3 ; 0: return EDI fields
- +4 ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ #
- +5 ; if it already exists. If not, it builds it from N-DIAGNOSES element
- +6 ;
- +7 ; For EDI call: Returns IBXDATA(n)=
- +8 ; begin date(YYYYMMDD) ^ end date(YYYYMMDD) ^ pos ^ tos ^
- +9 ; proc code/revenue code - if no procedure (not the pointers) ^
- +10 ; type of code ^ dx pointer(s ) ^ unit charge ^ units ^ modifiers separated by ;
- +11 ; ^ purchased charge amount ^ anesthesia minutes ^ emergency indicator ^
- +12 ; lab-type service flag ^ NDC ^ Units/Quantity ^ Unit/Basis of Measurement (vd/IB*2*577)
- +13 ;
- +14 ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
- +15 ; item found in an accepted EOB for the bill and = the reference
- +16 ; line in the first '^' piece followed by the '0' node data of file
- +17 ; 361.115 (LINE LEVEL ADJUSTMENTS)
- +18 ; COB = COB sequence # of adjustment's ins co, m = seq #
- +19 ; -- AND --
- +20 ; IBXDATA(IBI,"COB",COB,m,z,p)=
- +21 ; the data on the '0' node for each subordinate entry of file
- +22 ; 361.11511 (REASONS) (Only first 3 pieces for 837 output)
- +23 ; z = group code, sometimes preceeded by a space p = seq #
- +24 ;
- +25 ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or
- +26 ; null if equal to begin date^pos^tos^bedsection name(if no procedure)
- +27 ; or procedure code(not the pointer)^ ... refer to EDI call results
- +28 ; Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24,
- +29 ; If no procedure code, returns IBXDATA(n,"A")=rev code abbrev
- +30 ;
- +31 ; For both calls, returns IBXDATA(n,item type,item ptr)=""
- +32 ; -- AND --
- +33 ; IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days
- +34 ; ^chrge^ien of file 362.4^NDC format
- +35 ; If line references a prescription
- +36 ; -- AND --
- +37 ; If no revenue code for a prescription, returns IBXDATA(n,"ARX")=""
- +38 ; -- AND --
- +39 ; IBXDATA(n,"AUX")='AUX' node of the procedure entry
- +40 ;
- +41 ; Also returns IBXDATA(n,"CPLNK") = soft link to corresponding entry in PROCEDURES multiple of file 399
- +42 ;
- +43 NEW IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1
- +44 ;
- +45 KILL ^TMP($JOB,"IBITEM")
- +46 SET ^TMP($JOB,"IBITEM")=""
- +47 ; Build diagnosis array if not already built
- +48 IF $ORDER(^TMP("IBXSAVE",$JOB,"DX",IBIFN,""))=""
- IF $ORDER(^IBA(362.3,"AIFN"_IBIFN,""))
- Begin DoDot:1
- +49 NEW Z,IBXDATA
- DO F^IBCEF("N-DIAGNOSES",,,IBIFN)
- +50 SET Z=""
- FOR
- SET Z=$ORDER(IBXDATA(Z))
- if $ORDER(IBXDATA(0))=""&(Z="")
- KILL IBXDATA
- if Z=""
- QUIT
- if $PIECE(IBXDATA(Z),U,2)
- SET ^TMP("IBXSAVE",$JOB,"DX",IBIFN,$PIECE(IBXDATA(Z),U,2))=Z
- End DoDot:1
- +51 ;
- +52 SET IB(0)=$GET(^DGCR(399,IBIFN,0))
- SET IB("U")=$GET(^("U"))
- SET IB("U1")=$GET(^("U1"))
- +53 SET IBI=""
- FOR
- SET IBI=$ORDER(^TMP("IBXSAVE",$JOB,"DX",IBIFN,IBI))
- if IBI=""
- QUIT
- SET IBDXI(IBI)=^(IBI)
- +54 IF '$GET(IBPRINT)
- DO RVCE^IBCF23(IBIFN,IBIFN)
- +55 IF $GET(IBPRINT)
- DO RVCE^IBCF23(,IBIFN)
- +56 ; Returns IBFLD(24) = begin date ^ end date ^ pos ^ tos ^
- +57 ; proc/bedsection/revenue code ^ dx pointer ^ unit charge ^
- +58 ; units ^ modifiers ^ purchased charge amount ^ anesthesia minutes ^
- +59 ; emergency indicator ^ soft pointer to PROCEDURES multiple in file 399 ^
- +60 ; NDC ^ Units
- +61 ; IBFLD(24,n,type,item)=""
- +62 ; IBFLD(24,n_"A") = revenue code abbreviation if no procedure
- +63 ; IBFLD(24,n,"AUX") = 'AUX' node of line item
- +64 ; IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld
- +65 ; (can be null)
- +66 ;
- +67 ;prescriptions
- DO SET^IBCSC5A(IBIFN,.IBRX)
- +68 ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge
- +69 IF IBRX
- SET IBRX=""
- FOR
- SET IBRX=$ORDER(IBRX(IBRX))
- if IBRX=""
- QUIT
- SET IBRX0=0
- FOR
- SET IBRX0=$ORDER(IBRX(IBRX,IBRX0))
- if 'IBRX0
- QUIT
- Begin DoDot:1
- +70 NEW IBRXH
- +71 SET IBRXH=IBRX(IBRX,IBRX0)
- +72 ; **IB*2.0*432** added _U_$P(IBRXH,U,9) (Rx Date) to Output Formatter
- +73 SET IBRX1(+IBRXH)=IBRX_U_$PIECE(IBRXH,U,2)_U_$PIECE(IBRXH,U,5)_U_$PIECE(IBRXH,U,7)_U_IBRX0_U_$PIECE(IBRXH,U,4)_U_$PIECE(IBRXH,U,3)_U_$PIECE(IBRXH,U,6)_U_+IBRXH_U_$PIECE(IBRXH,U,8)_U_$PIECE(IBRXH,U,9)
- End DoDot:1
- +74 KILL IBRX
- +75 ;
- +76 ; for EDI, remove any $0 line items from the IBFLD array before
- +77 ; dropping down into the next loop (IB*2*371)
- +78 ; Start IB*2.0*447 BI - Code removed to allow 0 dollars to print.
- +79 ;I '$G(IBPRINT) D
- +80 ;. NEW IBZ,IBI,Z
- +81 ;. M IBZ=IBFLD K IBFLD
- +82 ;. S (IBI,Z)=0
- +83 ;. F S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI D
- +84 ;.. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q
- +85 ;.. S Z=Z+1
- +86 ;.. M IBFLD(24,Z)=IBZ(24,IBI)
- +87 ;.. S IBFLD(24)=Z
- +88 ;.. Q
- +89 ;. Q
- +90 ; End IB*2.0*447 BI
- +91 ;
- +92 SET IBI=0
- +93 FOR
- SET IBI=$ORDER(IBFLD(24,IBI))
- if IBI'=+IBI
- QUIT
- Begin DoDot:1
- +94 SET IBRX1=0
- +95 SET IBXDATA(IBI)=$PIECE(IBFLD(24,IBI),U)_U_$PIECE(IBFLD(24,IBI),U,$SELECT($PIECE(IBFLD(24,IBI),U,2)=""&'$GET(IBPRINT):1,1:2))
- +96 SET $PIECE(IBXDATA(IBI),U,3,5)=$PIECE(IBFLD(24,IBI),U,3,5)
- +97 SET $PIECE(IBXDATA(IBI),U,6)=$SELECT($DATA(IBFLD(24,IBI_"X")):"CJ",1:"HC")
- +98 SET $PIECE(IBXDATA(IBI),U,7,13)=$PIECE(IBFLD(24,IBI),U,6,12)
- +99 SET $PIECE(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI))
- +100 ; MRD;IB*2.0*516 - Added NDC and Units to line level of claim,
- +101 ; pieces 14 & 15 of IBFLD, pieces 15 & 16 of IBXDATA. Print
- +102 ; in Box 24 by setting in IBXDATA(IBI,"TEXT").
- +103 ;S $P(IBXDATA(IBI),U,15,16)=$P(IBFLD(24,IBI),U,14,15)
- +104 ;I $P(IBFLD(24,IBI),U,14)'="" S IBXDATA(IBI,"TEXT")="N4"_$P(IBFLD(24,IBI),U,14)_" UN"_$P(IBFLD(24,IBI),U,15)
- +105 ; vd/IB*2*577 - Added Unit/Basis of Measurement to line level of claim,
- +106 ; piece 16 of IBFLD, piece 17 of IBXDATA.
- +107 ; Print in Box 24 by setting in IBXDATA(IBI,"TEXT").
- +108 SET $PIECE(IBXDATA(IBI),U,15,17)=$PIECE(IBFLD(24,IBI),U,14,16)
- +109 IF $PIECE(IBFLD(24,IBI),U,14)'=""
- SET IBXDATA(IBI,"TEXT")="N4"_$PIECE(IBFLD(24,IBI),U,14)_" "_$PIECE(IBFLD(24,IBI),U,16)_$PIECE(IBFLD(24,IBI),U,15)
- +110 ;
- +111 ;Rx
- IF $DATA(IBFLD(24,IBI,"RX"))
- Begin DoDot:2
- +112 SET IBRX1=1
- +113 ;No free text allowed for rx's
- IF $PIECE($GET(IBFLD(24,IBI,"AUX")),U,8)'=""
- SET $PIECE(IBFLD(24,IBI,"AUX"),U,8)=""
- SET $PIECE(IBFLD(24,IBI,"AUX"),U,9)=""
- +114 ;Soft link exists
- IF $DATA(IBRX1(+IBFLD(24,IBI,"RX")))
- Begin DoDot:3
- +115 DO ZERO^IBRXUTL(+$PIECE(IBRX1(+IBFLD(24,IBI,"RX")),U,2))
- +116 SET IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX"))
- SET $PIECE(IBXDATA(IBI,"RX"),U,2)=$EXTRACT($GET(^TMP($JOB,"IBDRUG",+$PIECE(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30)
- +117 KILL IBRX1(+IBFLD(24,IBI,"RX"))
- +118 ; No soft link - must find the first Rx with the same charge
- End DoDot:3
- QUIT
- +119 SET IBRX=""
- FOR
- SET IBRX=$ORDER(IBRX1(IBRX))
- if 'IBRX
- QUIT
- IF +$PIECE(IBRX1(IBRX),U,8)=+$PIECE(IBXDATA(IBI),U,8)
- Begin DoDot:3
- +120 DO ZERO^IBRXUTL(+$PIECE(IBRX1(IBRX),U,2))
- +121 SET IBXDATA(IBI,"RX")=IBRX1(IBRX)
- SET $PIECE(IBXDATA(IBI,"RX"),U,2)=$EXTRACT($GET(^TMP($JOB,"IBDRUG",+$PIECE(IBRX1(IBRX),U,2),.01)),1,30)
- KILL IBRX1(IBRX)
- QUIT
- +122 QUIT
- End DoDot:3
- QUIT
- +123 QUIT
- End DoDot:2
- +124 ;
- +125 ; MRD;IB*2.0*516 - If additional service line comments to appear in
- +126 ; Box 24, concatenate to front if something (NDC) is already there.
- +127 IF $GET(IBFLD(24,IBI,"AUX"))'=""
- Begin DoDot:2
- +128 IF $GET(IBPRINT)
- IF $PIECE(IBFLD(24,IBI,"AUX"),U,8)'=""
- Begin DoDot:3
- +129 IF $GET(IBXDATA(IBI,"TEXT"))'=""
- SET IBXDATA(IBI,"TEXT")=$EXTRACT($PIECE(IBFLD(24,IBI,"AUX"),U,8)_" "_IBXDATA(IBI,"TEXT"),1,59)
- +130 IF '$TEST
- SET IBXDATA(IBI,"TEXT")=$PIECE(IBFLD(24,IBI,"AUX"),U,8)
- +131 SET $PIECE(IBFLD(24,IBI,"AUX"),U,8)=""
- +132 QUIT
- End DoDot:3
- +133 SET IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX")
- +134 QUIT
- End DoDot:2
- +135 ;
- +136 ;JWS;IB*2.0*592:US131
- +137 IF $GET(IBFLD(24,IBI,"DEN"))'=""
- SET IBXDATA(IBI,"DEN")=IBFLD(24,IBI,"DEN")
- +138 IF $GET(IBFLD(24,IBI,"DEND"))'=""
- SET IBXDATA(IBI,"DEND")=$PIECE(IBFLD(24,IBI,"DEND"),"^",4)
- +139 IF $ORDER(IBFLD(24,IBI,"DEN1",0))
- MERGE IBXDATA(IBI,"DEN1")=IBFLD(24,IBI,"DEN1")
- +140 ;end - ;JWS;IB*2.0*592:US131
- +141 IF $GET(IBPRINT)
- Begin DoDot:2
- +142 ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
- +143 ; I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D Q
- +144 IF $PIECE(IBXDATA(IBI),U,8)=""
- IF '$GET(IBXDATA(IBI,"RX"))
- Begin DoDot:3
- +145 ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
- +146 ; don't show errors/warnings
- IF $GET(IBNOSHOW)
- QUIT
- +147 SET IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE ="
- +148 IF $DATA(IBXDATA(IBI,"AUX"))
- SET $PIECE(IBXDATA(IBI,"AUX"),U,9)=""
- +149 QUIT
- End DoDot:3
- QUIT
- +150 ;
- +151 IF $GET(IBFLD(24,IBI_"A"))'=""
- Begin DoDot:3
- +152 SET IBXDATA(IBI,"A")=IBFLD(24,IBI_"A")
- +153 ; don't show errors/warnings
- IF $GET(IBNOSHOW)
- QUIT
- +154 SET IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A")
- +155 IF $DATA(IBXDATA(IBI,"AUX"))
- SET $PIECE(IBXDATA(IBI,"AUX"),U,9)=""
- +156 QUIT
- End DoDot:3
- QUIT
- +157 ;
- +158 SET IBRX=$GET(IBXDATA(IBI,"RX"))
- +159 ;Format Rx detail
- IF IBRX'=""
- Begin DoDot:3
- +160 NEW Z
- +161 SET Z=$PIECE(IBRX,U)
- +162 SET Z=$SELECT(Z'="":"Rx#"_Z_" ",1:"RX: ")
- +163 SET IBXDATA(IBI,"TEXT")=Z_$SELECT($PIECE(IBRX,U,3)'="":"NDC: "_$PIECE(IBRX,U,3),1:"NOC: "_$PIECE(IBRX,U,2))_" Qty: "_$PIECE(IBRX,U,6)_" Days: "_$PIECE(IBRX,U,7)
- +164 ; service line comment qualifier for RX's
- SET $PIECE(IBXDATA(IBI,"AUX"),U,9)="N4"
- +165 QUIT
- End DoDot:3
- +166 QUIT
- End DoDot:2
- +167 SET IBXDATA(IBI,"CPLNK")=$PIECE(IBFLD(24,IBI),U,13)
- +168 IF '$GET(IBPRINT)
- DO COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA)
- +169 QUIT
- End DoDot:1
- +170 ;
- +171 IF $GET(IBPRINT)
- Begin DoDot:1
- +172 SET IBRX=0
- FOR
- SET IBRX=$ORDER(IBRX1(IBRX))
- if 'IBRX
- QUIT
- Begin DoDot:2
- +173 SET IBI=+$ORDER(IBXDATA(""),-1)+1
- +174 SET IBXDATA(IBI)=$$DATE($PIECE(IBRX1(IBRX),U,5))
- +175 SET IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$PIECE(IBRX1(IBRX),U)_" NDC #: "_$PIECE(IBRX1(IBRX),U,3)
- +176 IF $DATA(IBXDATA(IBI,"AUX"))
- SET $PIECE(IBXDATA(IBI,"AUX"),U,9)=""
- +177 SET IBXDATA(IBI,"ARX")=""
- +178 DO ZERO^IBRXUTL(+$PIECE(IBRX1(IBRX),U,2))
- +179 SET IBXDATA(IBI,"RX")=IBRX1(IBRX)
- SET $PIECE(IBXDATA(IBI,"RX"),U,2)=$EXTRACT($GET(^TMP($JOB,"IBDRUG",+$PIECE(IBRX1(IBRX),U,2),.01)),1,30)
- KILL IBRX1(IBRX)
- +180 QUIT
- End DoDot:2
- +181 QUIT
- End DoDot:1
- +182 ;
- +183 ;Handle bundled/unbundled lines
- IF '$GET(IBPRINT)
- IF $DATA(IBXTRA)
- DO COMBO^IBCEU2(.IBXDATA,.IBXTRA,0)
- +184 KILL ^TMP($JOB,"IBDRUG")
- +185 QUIT
- +186 ;
- ISLAB(LDATA) ; Returns 0/1 if line item data indicates the item is a lab (1)
- +1 ; 'LAB' is defined here as type of service = 5
- +2 QUIT $EXTRACT($PIECE(LDATA,U,4))="5"
- +3 ;
- FMT(DATA,DLEN,FLEN) ; Returns a string in DATA with a max length of DLEN
- +1 ; and a field length of FLEN
- +2 QUIT $EXTRACT($EXTRACT(DATA,1,DLEN)_$JUSTIFY("",FLEN),1,FLEN)
- +3 ;
- DATE(X,DEL) ; Returns FM date in X as MMxDDxYYYY where x=DEL
- +1 SET DEL=$GET(DEL)
- +2 SET X=$$DATE^IBCF2(X,1,1)
- +3 IF X'=""
- SET X=$EXTRACT(X,1,2)_DEL_$EXTRACT(X,3,4)_DEL_$EXTRACT(X,5,8)
- +4 QUIT X
- +5 ;
- BATCH() ; Sets up record for and stores/returns the next batch number
- +1 NEW NUM,FAC,DO,DD,DLAYGO,DIC,X,Y
- +2 ;Keep latest batch number for view/print edi bill extract data option
- +3 IF $DATA(IBVNUM)
- SET NUM=IBVNUM
- GOTO BATCHQ
- +4 ;Check for batch resubmit - if yes, use same number as original batch
- +5 IF $PIECE($GET(^TMP("IBRESUBMIT",$JOB)),U,3)=1
- SET NUM=$PIECE(^($JOB),U)
- GOTO BATCHQ
- +6 ;JWS;IB*2.0*623v24;7/17/19 increased lock timeout to 10 sec from 5
- +7 ;JWS;IB*2.0*641v12;5/21/20 testing increase of lock timeout to 30 sec, from 10
- +8 LOCK +^IBA(364.1,0):30
- IF '$TEST
- QUIT 0
- +9 SET FAC=+$PIECE($$SITE^VASITE(),U,3)
- SET NUM=$ORDER(^IBA(364.1,"B",""),-1)
- +10 SET NUM=NUM+1
- +11 ;JWS;IB*2.0*641v8;increase batch# field from 10 to 12
- +12 ;;I $L(NUM)<12 S NUM=FAC_"00"_$E(NUM,4,10)
- +13 ;I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F D Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="")
- +14 ;. I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK
- +15 ;. S NUM=$O(^IBA(364.1,"B",""),-1)
- +16 ;JWS;IB*2.0*623v24;commented out code below, thus needed to set NUM=NUM+1 above
- +17 ;JWS;IB*2.0*623;bug when number = 4424420000
- +18 ;F S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM))
- +19 ;JWS;IB*2.0*623v24;commented out code below, looking for unused batch#s
- +20 ;I $E(NUM,1,3)'=FAC S NUM=FAC_"0000001"
- +21 ;F Q:'$D(^IBA(364.1,"B",NUM)) S NUM=NUM+1
- +22 ;
- +23 KILL DO,DD
- SET DIC="^IBA(364.1,"
- SET DLAYGO=364.1
- SET DIC(0)="L"
- SET X=NUM
- DO FILE^DICN
- KILL DD,DO
- IF Y'>0
- SET NUM=0
- +24 LOCK -^IBA(364.1,0)
- +25 ;
- BATCHQ QUIT NUM
- +1 ;
- GETLDAT(IBXIEN) ; Extract data for 837 transmission LDAT record
- +1 ; IBXIEN - ien in file 399
- +2 ; Sets up IBXSAVE("LDAT",n) array:
- +3 ; Attachment report type ^ Attachment report transmission code ^ Attachment control number ^
- +4 ; OB Anesthesia Additional Units ^ Purchase Service Provider ID ^ Purchase Service Amount ^
- +5 NEW CPIEN,FTYPE,IBXDATA,IDS,IBIDS,NODE1,PSAMNT,PSPID,Z,PCE1,LINE
- +6 IF '+$GET(IBXIEN)
- QUIT
- +7 KILL IBXSAVE("LDAT")
- +8 SET FTYPE=$$FT^IBCEF(IBXIEN)
- +9 ;JWS;IB*2.0*592; added Dental form
- +10 IF FTYPE=2!(FTYPE=7)
- DO OUTPT(IBXIEN,0)
- +11 IF FTYPE=3
- DO HOS^IBCEF2(IBXIEN)
- +12 DO ALLIDS^IBCEFP(IBXIEN,.IDS,1)
- +13 SET (PSPID,PSAMNT)=""
- +14 ; IB*2.0*473/TAZ - Convert PROVIDER code to function call to PSID^IBCEFP
- +15 IF $$SUB1OK^IBCEP8A(IBXIEN)
- IF (FTYPE=2)
- Begin DoDot:1
- +16 DO PSID^IBCEFP(IBXIEN,.IDS,.IBIDS)
- +17 SET PSPID=$GET(IBIDS(0))
- IF PSPID=""
- SET PSPID=$PIECE($GET(IBIDS(1)),U,1)
- End DoDot:1
- +18 ;IB*2.0*473/TAZ - END
- +19 SET Z=0
- FOR
- SET Z=$ORDER(IBXDATA(Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +20 ;I 'CPIEN Q
- SET CPIEN=+$GET(IBXDATA(Z,"CPLNK"))
- +21 IF FTYPE=2
- IF $$SUB1OK^IBCEP8A(IBXIEN)
- SET PSAMNT=$$DOLLAR^IBCEFG1($PIECE($GET(IBXDATA(Z)),U,11))
- +22 SET (PCE1,NODE1)=""
- +23 IF CPIEN
- Begin DoDot:2
- +24 SET NODE1=$GET(^DGCR(399,IBXIEN,"CP",CPIEN,1))
- +25 SET PCE1=$$GET1^DIQ(399.0304,CPIEN_","_IBXIEN_",",71)
- +26 QUIT
- End DoDot:2
- +27 ; MRD;IB*2.0*516 - Added addl. procedure description as piece 7
- +28 ; of IBXSAVE, which will exist only if the procedure ends in '99'
- +29 ; or is an 'NOC/NOS' procedure.
- +30 ;JWS;IB*2.0*592;do not include NOC description here for Dental claims
- +31 SET IBXSAVE("LDAT",Z)=PCE1_U_$PIECE(NODE1,U,3)_U_$PIECE(NODE1,U)_U_$PIECE(NODE1,U,5)_U_$GET(PSPID)_U_$GET(PSAMNT)_U_$SELECT(FTYPE=7:"",1:$PIECE(NODE1,U,4))
- +32 QUIT
- End DoDot:1
- +33 QUIT
- +34 ;
- +35 ;/Beginning of IB*2.0*608 (US9) - vd
- LDAT ;
- +1 NEW Z
- KILL IBXDATA
- +2 SET Z=0
- FOR
- SET Z=$ORDER(IBXSAVE("LDAT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +3 SET IBXDATA(Z)=Z
- if Z>1
- DO ID^IBCEF2(Z,"LDAT")
- End DoDot:1
- +4 ;
- +5 IF +$GET(VC80)
- Begin DoDot:1
- +6 SET Z=$ORDER(IBXDATA(""),-1)+1
- +7 DO ID^IBCEF2(Z,"LDAT")
- +8 ; Process for 'SNF' claims & the last claim line
- DO VC80L(IBXIEN,Z)
- +9 SET A=Z
- +10 SET IBXDATA(Z)=A
- End DoDot:1
- +11 QUIT
- +12 ;
- VC80L(IBIFN,LN) ; Extracts the data for the "LDAT" record for VALUE CODE 80 Line item.
- +1 ; IBIFN = Claims internal id number
- +2 ; LN =
- +3 NEW VC80LN
- +4 SET VC80LN=LN
- +5 SET $PIECE(IBXSAVE("LDAT",VC80LN),U,11)="6R"
- +6 SET $PIECE(IBXSAVE("LDAT",VC80LN),U,12)=VC80LN_"_"_$$GET1^DIQ(399,IBIFN_", ",.01)
- +7 QUIT
- +8 ;/Ending of IB*2.0*608 - vd
- +9 ;