Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCF22

IBCF22.m

Go to the documentation of this file.
  1. IBCF22 ;ALB/ARH - HCFA 1500 19-90 DATA (gather other data) ;12-JUN-93
  1. ;;2.0;INTEGRATED BILLING;**52,80,122,51,210,488,576**;21-MAR-94;Build 45
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;JRA IB*2*576 Stop automatically defaulting the date of service as the onset date versus the actual
  1. ; date that the current illness or symptom first appeared (if no such actual date then leave blank).
  1. ;
  1. ; requires DFN, IBIFN, IB(0)
  1. F IBI="C","U","U1","U2","UF2" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
  1. S IBFLD(12)="PUBLIC LAW 99-272/SECTION 1729 TITLE 38"
  1. S IBFLD(13)="PUBLIC LAW 99-272"
  1. DATES ;S IBFLD(14)=$$DATE($$EVENT(IBIFN))
  1. ;I $G(IBFLD(15))="",IBIFN'=$P(IB(0),U,17) S IBFLD(15)=$$DATE($P($G(^DGCR(399,+$P(IB(0),U,17),0)),U,3))
  1. ;The following sets up the dates and qualifiers for the dates in boxes 14 & 15 *488*
  1. S IBFLD(14)=$$QUAL(IBIFN,14),IBFLD(14.1)=$P(IBFLD(14),U,2)
  1. S IBFLD(14)=$$DATE($P(IBFLD(14),U,1))
  1. S IBFLD(15)=$$QUAL(IBIFN,15),IBFLD(15.1)=$P(IBFLD(15),U,2)
  1. S IBFLD(15)=$$DATE($P(IBFLD(15),U,1))
  1. S IBFLD("16A")=$$DATE($P(IB("U"),U,16)),IBFLD("16B")=$$DATE($P(IB("U"),U,17))
  1. S:$$NEEDMRA^IBEFUNC(IBIFN) IBFLD(17)="Dept. Of Veterans Affairs"
  1. I $P(IB(0),U,5)<3 S IBFLD("18A")=$$DATE($P(IB("U"),U,1)),IBFLD("18B")=$$DATE($P(IB("U"),U,2))
  1. I $P(IB(0),U,5)>2 S VAINDT=$P(IB(0),U,3) D INP^VADPT I +VAIN(1) D
  1. . S IBFLD("18A")=$$DATE(VAIN(7)),IBFLD("18B")=$$DATE(+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0)))
  1. K VAINDT,VAIN
  1. ;S IBFLD(19)="THE UNDERSIGNED CERTIFIES TREATMENT IS NOT FOR A SERVICE-CONNECTED CONDITION" *488*
  1. S IBFLD(20)=0
  1. ;
  1. DX ;S X=14 F IBI="21A","21B","21C","21D" S IBFLD(IBI)=$P($G(^ICD9(+$P(IB("C"),U,X),0)),U,1),X=X+1
  1. ;F IBI="21A","21B","21C","21D" S IBFLD(IBI)=""
  1. ;N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) S X=0,Y="21@" D
  1. ;. F S X=$O(IBINDXX(X)) Q:'X S Y=$O(IBFLD(Y)) Q:+Y'=21 S IBFLD(Y)=$P($G(^ICD9(+IBINDXX(X),0)),U,1)
  1. ; *488* changes 4 to 12 for the number of ICD codes
  1. N IBDXX,IBPOX
  1. D SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX)
  1. S X=0 F IBI=1:1:12 S IBFLD(21,IBI)="" I IBI'>$P(IBPOX,U,2) D
  1. . S X=$O(IBPOX(X)) Q:X=""
  1. . S IBFLD(21,IBI)=$P($$ICD9^IBACSV(+IBPOX(X)),U)
  1. . S IBDXI(+$G(IBDXX(+IBPOX(X))))=IBI
  1. S IBFLD("21A")=9 ; NEED TO ADD CODE TO DETERMIN IF ICD10 CODES USED WHEN
  1. ; ICD10 PROJECT GOES LIVE ->BAA *488*
  1. S IBFLD(23)=$P(IB("U"),U,13)
  1. ;
  1. D ^IBCF23 ; block 24
  1. ;
  1. S IBFLD(25)=$P($G(^IBE(350.9,1,1)),U,5)
  1. S IBFLD(26)=$$BN1^PRCAFN(IBIFN)
  1. S IBFLD(28)=+IB("U1")
  1. S IBFLD(29)=+$P(IB("U1"),U,2)
  1. S IBFLD(30)=IBFLD(28)-IBFLD(29)
  1. LAST3 S IBFLD(31)=$G(^DGCR(399,IBIFN,"UF2")) ;assuming there are 3 available lines
  1. S X=+$P($G(^IBE(350.9,1,0)),U,2),Y=$G(^DIC(4,X,0)),IBI=1 I Y'="" D
  1. . S IBFLD(32,1)=$P(Y,U,1),IBX=+$P(Y,U,2),Y=$G(^DIC(4,X,1))
  1. . S IBFLD(32,2)=$P(Y,U,1) I $P(Y,U,2)'="" S IBFLD(32,2)=IBFLD(32,2)_", "_$P(Y,U,2)
  1. . S IBFLD(32,3)=$P(Y,U,3),IBFLD(32,"X")=$$STATE^IBCF2(IBX)_" "_$P(Y,U,4)
  1. S X=$G(^IBE(350.9,1,2))
  1. S IBFLD(33,1)=$P(X,U,1),IBFLD(33,2)=$P(X,U,2)
  1. S IBFLD(33,3)=$P(X,U,3),IBFLD(33,"X")=$$STATE^IBCF2($P(X,U,4))_" "_$P(X,U,5)
  1. S IBFLD(33,4)=$P(X,U,6)
  1. ;
  1. END Q
  1. ;
  1. EVENT(IBIFN,IBXSAVE,IBERR,IBD) ; The event date for box 14 on the
  1. ; HCFA 1500
  1. ; IBIFN = bill ien
  1. ; IBXSAVE = the array returned by the output formatter for data element
  1. ; N-OCCURRENCE CODES
  1. ; Returns IBERR=1 if passed by reference meaning more than one condition
  1. ; has been found
  1. ; IBD("LMP"), IBD("ACC"), IBD("ONS"), IBD("EVT") returned with
  1. ; Last menstrual period date, accident date, date of onset,
  1. ; event date if IBD passed by reference
  1. ; Function returns the appropriate date
  1. ;
  1. N Z,Z0,IBX,IBF,A
  1. ;
  1. ; Default if no applicable occurrence codes found is event date on bill
  1. ;JRA IB*2*576 Default to '0' instead of Event Date
  1. ;S IBX=$P($G(^DGCR(399,IBIFN,0)),U,3),IBF=0 S IBD("EVT")=IBX ;JRA IB*2*576 ';'
  1. S IBX="",IBD("EVT")=$P($G(^DGCR(399,IBIFN,0)),U,3),IBF=0
  1. ;
  1. I '$D(IBXSAVE("OCC")) D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
  1. S Z=0 F S Z=$O(IBXSAVE("OCC",Z)) Q:'Z S Z0(+IBXSAVE("OCC",Z))=$P(IBXSAVE("OCC",Z),U,2)
  1. ;JRA IB*2*576 Re-calculate Accident Codes, Last Menstrual Period, and Onset of Illness
  1. I $O(Z0(5.99),-1) D
  1. . ;S A=$O(Z0(5.99),-1),IBF=IBF+1 ;Accident codes 1-5 ;JRA IB*2*576 ';'
  1. . ;S IBD("ACC")=Z0(A) S:IBF'>1 IBX=Z0(A) ;JRA IB*2*576 ';'
  1. . S A=$O(Z0(5.99),-1) ;Accident codes 1-5 ;JRA IB*2*576
  1. . S IBD("ACC")=Z0(A) ;JRA IB*2*576
  1. ;I $D(Z0(10)) S IBF=IBF+1,IBD("LMP")=IBX S:IBF'>1 IBX=Z0(10) ;Last Menstrual period ;JRA IB*2*576 ';'
  1. ;I $D(Z0(11)) S (IBD("ONS"),IBX)=Z0(11),IBF=IBF+1 ;Onset of Illness ;JRA IB*2*576 ';'
  1. ;Change in requirements: Do NOT default the Onset Date to the Occ Code 10 (LMP) date -
  1. ; commented line previously added below for IB*2.0*576 and replaced.
  1. ;I $D(Z0(10)) S IBF=IBF+1,(IBD("LMP"),IBX)=Z0(10) ;Last Menstrual period ;JRA IB*2*576
  1. I $D(Z0(10)) S IBF=IBF+1,IBD("LMP")=Z0(10) ;Last Menstrual period ;JRA IB*2*576
  1. I $D(Z0(11)) S IBF=IBF+1,(IBD("ONS"),IBX)=Z0(11) ;Onset of Illness ;JRA IB*2*576
  1. S IBERR=(IBF>1)
  1. Q IBX
  1. ;
  1. DATE(X) ; format date(X) as MM DD YYYY
  1. Q $$DATE^IBCF2(X,1)
  1. ;
  1. ; below are changes for *488*
  1. QUAL(IBIFN,IBXBOX,IBXSAVE,IBD) ; The event date for box 14 & box 15 on the
  1. ; HCFA 1500
  1. ; IBIFN = bill ien
  1. ; IBXBOX = BOX 14 OR BOX 15 of CMS-1500 form
  1. ; IBXSAVE = the array returned by the output formatter for data element
  1. ; N-OCCURRENCE CODES
  1. ;
  1. ; IBD("LMP"), IBD("ACC"), IBD("ONS"), IBD("EVT") returned with
  1. ; Last menstrual period date, accident date, date of onset,
  1. ; event date if IBD passed by reference
  1. ; Function returns the appropriate date
  1. ;
  1. ;N Z,Z0,IBX,IBF,A ;JRA IB*2*576 ';'
  1. N Z,Z0,IBX,A ;JRA IB*2*576
  1. ;
  1. I '$D(IBXSAVE("OCC")) D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
  1. S Z=0 F S Z=$O(IBXSAVE("OCC",Z)) Q:'Z S Z0(+IBXSAVE("OCC",Z))=$P(IBXSAVE("OCC",Z),U,2)
  1. ;
  1. S IBX=""
  1. I IBXBOX=14 D
  1. . ;Default if no applicable occurrence codes found is event date on bill
  1. . ;JRA IB*2*576 Modify default values
  1. . ;S IBX=$P($G(^DGCR(399,IBIFN,0)),U,3)_U_431,IBF=0 S IBD("EVT")=IBX ;JRA IB*2*576 ';'
  1. . ;I $D(Z0(11)) S (IBD("ONS"),IBX)=Z0(11),IBF=IBF+1,IBX=IBX_U_431 ;Onset of Illness ;JRA IB*2*576 ';'
  1. . ;I $D(Z0(10)) S IBF=IBF+1,IBD("LMP")=IBX S:IBF'>1 IBX=Z0(10)_U_484 ;Last Menstrual period ;JRA IB*2*576 ';'
  1. . S IBD("EVT")=$P($G(^DGCR(399,IBIFN,0)),U,3)_U_431 ; JRA IB*2*576
  1. . I $D(Z0(11)) S (IBD("ONS"),IBX)=Z0(11),IBX=IBX_U_431 Q ;Onset of Illness ; JRA IB*2*576
  1. . I $D(Z0(10)) S (IBD("LMP"),IBX)=Z0(10),IBX=IBX_U_484 ;Last Menstrual period ; JRA IB*2*576
  1. ;
  1. I IBXBOX=15 D
  1. .S IBX=""
  1. .D ACC I IBX'="" Q
  1. .D LXRY I IBX'="" Q
  1. .D AMCC I IBX'="" Q
  1. .D SCPT I IBX'="" Q
  1. .D INTTRT I IBX'="" Q
  1. .D LVC
  1. ;
  1. Q IBX
  1. ;
  1. ACC ;Accident - 439
  1. N IBF
  1. S IBF=0
  1. I $O(Z0(5.99),-1) D
  1. . S A=$O(Z0(5.99),-1),IBF=IBF+1 ;Accident codes 1-5
  1. . S IBD("ACC")=Z0(A) S:IBF'>1 IBX=Z0(A)
  1. . I IBX'="" S IBX=IBX_U_"439"
  1. Q
  1. ;
  1. LXRY ; Last X-Ray - 455
  1. S IBX=$P($G(^DGCR(399,IBIFN,"U3")),U,4)
  1. I IBX'="" S IBX=IBX_U_"455",IBD("AMC")=IBX
  1. ;
  1. SCPT ; Prescription - 471
  1. N IBRX,RXNM,RXDT
  1. D SET^IBCSC5A(IBIFN,.IBRX)
  1. I 'IBRX Q
  1. S RXNM=$O(IBRX(""))
  1. I RXNM="" Q
  1. S RXDT=$O(IBRX(RXNM,""))
  1. I RXDT="" Q
  1. S IBX=RXDT_U_"471"
  1. Q
  1. ;
  1. LVC ;Latest Visit or Consultation - 304
  1. S IBXDATA=""
  1. D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
  1. I IBXDATA'="" S IBD("LVC")=IBXDATA,IBX=IBXDATA_U_"304"
  1. Q
  1. ;
  1. INTTRT ;Initial Treatment - 454
  1. S IBX=$P($G(^DGCR(399,IBIFN,"U3")),U,5)
  1. I IBX'="" S IBX=IBX_U_"454",IBD("INT")=IBX
  1. Q
  1. ;
  1. AMCC ;Acute Manifestation of Chronic Condition - 453
  1. S IBX=$P($G(^DGCR(399,IBIFN,"U3")),U,6)
  1. I IBX'="" S IBX=IBX_U_"453",IBD("AMC")=IBX
  1. Q
  1. ;