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 Oct 16, 2024@18:13:33 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 ;
