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