BADEHLI ;IHS/MSC/MGH/PLS - Insurance or Dental Interface ;08-May-2009 20:54;PLS
;;1.0;DENTAL/EDR INTERFACE;**1**;AUG 22, 2011
;; Modified IHS/MSC/AMF 11/23/10 More descriptive alert messages, N for BHS variables
;=====================================================================================;
INS ;Entry point - Create the Insurance segment
N CNT,INSARRAY,DGNAME,IN1,IN2
;IHS/MSC/AMF 1/4/2011 Newed BHS variables
N BHSCOV,BHSDTL,BHSDTN,BHSDTS,BHSEDN,BHSI,BHSIDN,BHSINS,BHSITB,BHSJ,BHSN,BHSNM,BHSP,BHSPDN,BHSUFF,BHSXDT,BHSQ
S CNT=0
D MAID,MCARE,THIRD,RR
I 'CNT D
.D CRTNULL ;force creation of empty IN1/IN2 segments
Q
MAID ;See if the patient is on MEDICAID
K BHSITB
S BHSPDN=0 F S BHSPDN=$O(^AUPNMCD("B",DFN,BHSPDN)) Q:BHSPDN="" D BMAID
S BHSI=0 F S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" D
.S BHSJ=$O(BHSITB(BHSI,0))
.S BHSP=BHSITB(BHSI,BHSJ)
.S BHSPDN=$P(BHSP,";",1),BHSEDN=$P(BHSP,";",2)
.D DMAID
MAIDX K BHSCOV,BHSDTL,BHSDTN,BHSDTS,BHSEDN,BHSI,BHSIDN,BHSINS,BHSJ,BHSN,BHSPDN,BHSUFF,Y,BHSXDT,BHSNM,BHSP,BHSQ
Q
BMAID Q:'$D(^AUPNMCD(BHSPDN))
S BHSEDN=0 F S BHSEDN=$O(^AUPNMCD(BHSPDN,11,BHSEDN)) Q:'BHSEDN D
.S BHSP=$G(^AUPNMCD(BHSPDN,11,BHSEDN,0))
.S BHSI=$P(^AUPNMCD(BHSPDN,0),U,4)_"-"_$P(BHSP,U,3)
.S BHSJ=9999999-$P(BHSP,U,1)
.S BHSITB(BHSI,BHSJ)=BHSPDN_";"_BHSEDN
Q
DMAID ;
N INS,ADDR,PHONE,POLICY
S BHSNM=$G(^AUPNMCD(BHSPDN,11,BHSEDN,0))
;-- add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSNM,U,2)
S:BHSXDT="" BHSXDT=9999999
Q:BHSXDT<$$DT^XLFDT()
S CNT=CNT+1
D SET^BADEHL1(.ARY,"IN1",0)
D SET^BADEHL1(.ARY,CNT,1)
S BHSN=$G(^AUPNMCD(BHSPDN,0))
S INSCO=+$P(BHSN,U,2)
D SET^BADEHL1(.ARY,INSCO,2) ;Insurer IEN
D SET^BADEHL1(.ARY,INSCO,3) ;Insurer IEN
S BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
S BHSINS=$S($L(BHSINS):BHSINS,1:"???")
D SET^BADEHL1(.ARY,BHSINS,4) ;Insurance company name
;Get data on the insurer
S INS=$G(^AUTNINS(INSCO,0))
D MSCINS
;Get the eligibility and expiration dates
S X=$$HLDATE^HLFNC($P(BHSNM,U,1))
D SET^BADEHL1(.ARY,X,12)
S X=$$HLDATE^HLFNC($P(BHSNM,U,2))
D SET^BADEHL1(.ARY,X,13)
S X=$$VAL^XBDIQ1(9000004,BHSPDN,.11)
;D SET^BADEHL1(.ARY,X,15) ;Plan type
;Name of insured
S X=$$HLNAME^HLFNC($$GET1^DIQ(9000004,BHSPDN,2101),HLECH) ;was .05
F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,16,LP)
D SET^BADEHL1(.ARY,$$GETREL($P(BHSN,U,6)),17) ;Relationship to patient
D SET^BADEHL1(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(9000004,BHSPDN,2102,"I")),18) ;Medicaid Eligible DOB
S POLICY=+$P(BHSN,U,9)
;Policy Holder's Address
S POLICY=$G(^AUPN3PPH(POLICY,0))
I $L(POLICY) D
.D SET^BADEHL1(.ARY,$P(POLICY,U,9),19,1) ; Street Address
.D SET^BADEHL1(.ARY,$P(POLICY,U,11),19,3) ; City
.S BADEPOLP=$P(POLICY,U,12) ;SAIC/FJE FIX STATE POINTER 08/22/2011
.D SET^BADEHL1(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(9000003.1,+BADEPOLP,.12,"I"),1),19,4) ; State Abbrev
.D SET^BADEHL1(.ARY,$P(POLICY,U,13),19,5) ; Zip
; IN1-36 is left blank
D SET^BADEHL1(.ARY,$$GET1^DIQ(9000004,BHSPDN,.07,"I"),43) ; Gender of Insured
D SET^BADEHL1(.ARY,$P(BHSNM,U,3),47) ;Coverage Type
D SET^BADEHL1(.ARY,$P(BHSN,U,3),49) ; Insured's Medicaid ID number
S IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create IN1. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert
;Setup the IN2 segment
D IN2(INSCO,POLICY,$P(BHSN,U,3))
Q
MCARE ;ENTRY POINT
; See if patient is on MEDICARE
Q:'$D(^AUPNMCR(DFN))
S BHSN=$G(^AUPNMCR(DFN,0))
Q:'$D(^AUPNMCR(DFN,0))
K BHSITB
S BHSEDN=0 F S BHSEDN=$O(^AUPNMCR(DFN,11,BHSEDN)) Q:BHSEDN'=+BHSEDN D
.S BHSP=$G(^AUPNMCR(DFN,11,BHSEDN,0))
.S BHSI=$P(BHSN,U,2)_"-"_$P(BHSP,U,3)
.S BHSJ=9999999-$P(BHSP,U,1)
.S BHSITB(BHSI,BHSJ)=DFN_";"_BHSEDN
S BHSI=0 F BHSQ=0:0 S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" D
.S BHSJ=$O(BHSITB(BHSI,0)) S BHSP=BHSITB(BHSI,BHSJ)
.S BHSPDN=$P(BHSP,";",1),BHSEDN=$P(BHSP,";",2) D DMCARE
Q
DMCARE ;
S BHSNM=^AUPNMCR(BHSPDN,11,BHSEDN,0)
S X=$P(BHSNM,U,1)
;--add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSNM,U,2)
S:BHSXDT="" BHSXDT=9999999
Q:BHSXDT<$$DT^XLFDT()
S CNT=CNT+1
S BHSUFF=$P(BHSN,U,4) S BHSUFF=$P($G(^AUTTMCS(+BHSUFF,0)),U,1)
D SET^BADEHL1(.ARY,"IN1",0)
D SET^BADEHL1(.ARY,CNT,1)
S BHSN=$G(^AUPNMCR(BHSPDN,0))
S INSCO=+$P(BHSN,U,2)
D SET^BADEHL1(.ARY,INSCO,2) ;Insurer IEN
D SET^BADEHL1(.ARY,INSCO,3) ;Insurer IEN
S BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
S BHSINS=$S($L(BHSINS):BHSINS,1:"???")
D SET^BADEHL1(.ARY,BHSINS,4) ;Insurance Company name
;Get data on the insurer
S INS=$G(^AUTNINS(INSCO,0))
D MSCINS
;Get the eligibility and expiration dates
S X=$$HLDATE^HLFNC($P(BHSNM,U,1))
D SET^BADEHL1(.ARY,X,12)
S X=$$HLDATE^HLFNC($P(BHSNM,U,2))
D SET^BADEHL1(.ARY,X,13)
;D SET^BADEHL1(.ARY,$$GET1^DIQ(9000003,DFN,.04),8) ;Group Number
;D SET^BADEHL1(.ARY,$P(BHSNM,U,11),9) ;Group name
;D SET^BADEHL1(.ARY,$P(BHSNM,U,3),15) ;Plan type
S X=$$HLNAME^HLFNC($$GET1^DIQ(9000003,DFN,2101),HLECH)
F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,16,LP)
D SET^BADEHL1(.ARY,"SEL",17) ;Relationship to patient - File doesn't have .06 field
D SET^BADEHL1(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(9000003,DFN,2102,"I")),18) ;Medicare Eligible DOB
;No policy so no policy holder address
D SET^BADEHL1(.ARY,$P(BHSNM,U,8),43) ; Gender of Insured
D SET^BADEHL1(.ARY,$P(BHSNM,U,3),47) ;Coverage Type
D SET^BADEHL1(.ARY,$P(BHSN,U,3),49) ; Insured's Medicare ID Number
S IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create Medicaid IN1. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert
D IN2(INSCO,"")
K BHSXDT,BHSNM
Q
THIRD ;EP
; OTHER THIRD PARTY
Q:$O(^AUPNPRVT(DFN,11,0))="" ; Private Insurance Eligible
N BHSITB,BHSIDN,BHSP,BHSI,BHSJ
S BHSIDN=0 F S BHSIDN=$O(^AUPNPRVT(DFN,11,BHSIDN)) Q:'BHSIDN D
.S BHSP=$G(^AUPNPRVT(DFN,11,BHSIDN,0))
.S BHSITB($P(BHSP,U,1)_"-"_$P(BHSP,U,3),9999999-$P(BHSP,U,6))=BHSIDN
S BHSI="" F S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" D
.S BHSJ="" F S BHSJ=$O(BHSITB(BHSI,BHSJ)) Q:BHSJ="" D
..S BHSIDN=BHSITB(BHSI,BHSJ) D DTHIRD
Q
DTHIRD ;Private insurance data
N BADEPOLP,INS,ADDR,BHSINS,GRPIEN
N BHSN,X,BHSXDT,INSCO,POLICY,MEMID
S (BADEPOLP,INS)=""
S BHSN=$G(^AUPNPRVT(DFN,11,BHSIDN,0))
S MEMID=$P($G(^AUPNPRVT(DFN,11,BHSIDN,2)),U)
S BADEPLCY=$P(BHSN,U,2) ;Policy Number
S BHSINS=$P($G(^AUTNINS(+$P(BHSN,U,1),0)),U,1) ;Insurer name
S BADEPOLP=$P(BHSN,U,8) ;policy holder pointer
;-- add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSN,U,7)
S:BHSXDT="" BHSXDT=9999999
Q:BHSXDT<$$DT^XLFDT()
S INSCO=+BHSN
S CNT=CNT+1
D SET^BADEHL1(.ARY,"IN1",0)
D SET^BADEHL1(.ARY,CNT,1)
D SET^BADEHL1(.ARY,INSCO,2) ; Insurer IEN
D SET^BADEHL1(.ARY,INSCO,3) ; Insurer IEN
S BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
S BHSINS=$S($L(BHSINS):BHSINS,1:"???")
D SET^BADEHL1(.ARY,BHSINS,4) ;Insurance company name
;Get data on the insurer
S INS=$G(^AUTNINS(INSCO,0))
D MSCINS
;
S POLICY=$G(^AUPN3PPH(+BADEPOLP,0)) ;Policy Node 0
S GRPIEN=$P(POLICY,U,6) ; Pointer to Employer Group Insurance
D SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.77,GRPIEN,.02),8) ;Group Number
D SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.77,GRPIEN,.01),9) ;Group Name
;Get the eligibility and expiration dates
S X=$$HLDATE^HLFNC($P(POLICY,U,17))
D SET^BADEHL1(.ARY,X,12)
S X=$$HLDATE^HLFNC($P(POLICY,U,18))
D SET^BADEHL1(.ARY,X,13)
;Name of insured
S X=$$HLNAME^HLFNC($P(POLICY,U))
F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,16,LP)
;Relationship to patient
D SET^BADEHL1(.ARY,$$GETREL($P(BHSN,U,5)),17)
;
S X=$$HLDATE^HLFNC($P(POLICY,U,19))
D SET^BADEHL1(.ARY,X,18) ;Insured's DOB
;Holder's Address
D SET^BADEHL1(.ARY,$P(POLICY,U,9),19,1) ; Street Address
D SET^BADEHL1(.ARY,$P(POLICY,U,11),19,3) ; City
D SET^BADEHL1(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(9000003.1,+BADEPOLP,.12,"I"),1),19,4) ; State Abbrev
D SET^BADEHL1(.ARY,$P(POLICY,U,13),19,5) ; Zip
;
D SET^BADEHL1(.ARY,$P(POLICY,U,8),43) ; Gender of Insured
I BADEPOLP D
.;Not Self
.D SET^BADEHL1(.ARY,MEMID,36) ;Member Number
.D SET^BADEHL1(.ARY,$P(POLICY,U,4),49) ;Insured's Member ID number
E D
.;Self
.D SET^BADEHL1(.ARY,MEMID,36) ;Member Number
D SET^BADEHL1(.ARY,$$GET1^DIQ(9000003.1,+BADEPOLP,.05),47) ;Coverage Type
;D SET^BADEHL1(.ARY,$P(POLICY,U,4),49) ;Insured's ID number
S IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create IN1. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert
;Do IN2 segment
D IN2(INSCO,POLICY)
Q
RR ;EP
; RAILROAD RETIREMENT
Q:'$D(^AUPNRRE(DFN))
N BHSN,BHSITB,BHSUFF,BHSEDN,BHSP,BHSI,BHSJ,BHSQ,BHSP,BHSPDN
N BHSNM,BHSPFX,BHSCTYP
S BHSN=^AUPNRRE(DFN,0)
;S BHSINS=$P(^AUTNINS($P(BHSN,U,2),0),U,1)
;S BHSUFF=$P(BHSN,U,3)
S BHSEDN=0 F S BHSEDN=$O(^AUPNRRE(DFN,11,BHSEDN)) Q:BHSEDN'=+BHSEDN D
.S BHSP=$G(^AUPNRRE(DFN,11,BHSEDN,0))
.S BHSI=$P(BHSN,U,2)_"-"_$P(BHSP,U,3),BHSJ=9999999-$P(BHSP,U,1)
.S BHSITB(BHSI,BHSJ)=DFN_";"_BHSEDN
S BHSI=0 F BHSQ=0:0 S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" D
.S BHSJ=$O(BHSITB(BHSI,0)) S BHSP=BHSITB(BHSI,BHSJ)
.S BHSPDN=$P(BHSP,";",1),BHSEDN=$P(BHSP,";",2) D DRR
Q
DRR ;
N X,BHSXDT,BHSINS
S BHSNM=^AUPNRRE(BHSPDN,11,BHSEDN,0)
S X=$P(BHSNM,U,1)
;-- add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSNM,U,2)
S:BHSXDT="" BHSXDT=9999999
Q:BHSXDT<$$DT^XLFDT()
S CNT=CNT+1
D SET^BADEHL1(.ARY,"IN1",0)
D SET^BADEHL1(.ARY,CNT,1)
S BHSN=^AUPNRRE(DFN,0)
S INSCO=+$P(BHSN,U,2)
S BHSPFX=$$GET1^DIQ(9000005,DFN,.03) ; Prefix
S BHSCTYP=$P(BHSNM,U,3) ; Coverage Type
D SET^BADEHL1(.ARY,INSCO,2) ; Insurer IEN
D SET^BADEHL1(.ARY,INSCO,3) ; Insurer IEN
S BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
S BHSINS=$S($L(BHSINS):BHSINS,1:"???")
D SET^BADEHL1(.ARY,BHSINS,4) ;Insurance Company name
;Get data on the insurer
S INS=$G(^AUTNINS(INSCO,0))
D MSCINS
;Get the eligibility and expiration dates
S X=$$HLDATE^HLFNC($P(BHSNM,U,1))
D SET^BADEHL1(.ARY,X,12)
S X=$$HLDATE^HLFNC($P(BHSNM,U,2))
D SET^BADEHL1(.ARY,X,13)
D SET^BADEHL1(.ARY,$$GET1^DIQ(9000005,DFN,.04),8) ;Group Number
S X=$$HLNAME^HLFNC($$GET1^DIQ(9000005,DFN,2101),HLECH) ;Name of insured
F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,16,LP)
D SET^BADEHL1(.ARY,"SEL",17) ;Relationship to patient - File doesn't have .06 field
D SET^BADEHL1(.ARY,$$HLDATE^HLFNC($P(BHSNM,U,9)),18) ;Insured's DOB
D SET^BADEHL1(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(9000005,DFN,2102,"I")),18)
;Insured's address
; No policy so no policy holder address
;S FLD=$$PTADDR(DFN)
;F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D
;.D SET^BADEHL1(.ARY,VAL,19,LP)
;D SET^BADEHL1(.ARY,$P(BHSN,U,4),36) ;policy number
D SET^BADEHL1(.ARY,$P(BHSNM,U,8),43) ; Gender of Insured
D SET^BADEHL1(.ARY,$P(BHSNM,U,3),47) ; Coverage Type
D SET^BADEHL1(.ARY,$S(BHSCTYP="D":$P(BHSNM,U,6),1:BHSPFX_$P(BHSN,U,4)),49) ; ID Number
S IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create Railroad IN1. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert
;Setup the IN2 segment
D IN2(INSCO,"")
K BHSNM,BHSXDT
Q
MSCINS ;Insurance company data
Q:'$L(INS)
N ST,ZIP,ADDR,LP,VAL,PHONE,PHD
S ST=$$GET1^DIQ(5,$P(INS,U,4),1) ;State Abbrev
S ZIP=$E($P(INS,U,5),1,5)
S ADDR=$P(INS,U,2)_"^^"_$P(INS,U,3)_"^"_ST_"^"_ZIP
F LP=1:1:$L(ADDR,$E(HLECH)) S VAL=$P(ADDR,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,5,LP)
S PHD=$P(BHSN,U,9) ;Company Contact Name
S PHD=$$HLNAME^HLFNC($$GET1^DIQ(9000003.1,PHD,.01),HLECH)
F LP=1:1:$L(PHD,$E(HLECH)) S VAL=$P(PHD,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,6,LP)
S PHONE=$$HLPHONE^HLFNC($P(INS,U,6))
I $L(PHONE) D
.D SET^BADEHL1(.ARY,PHONE,7,1) ;Company Phone Number
.D SET^BADEHL1(.ARY,"WPH",7,2)
Q
GETREL(RIEN) ;Find the relationship
N Y,REL
S REL=""
I +RIEN D
.S Y=$$GET1^DIQ(9999999.36,RIEN,.01)
.I Y="SPOUSE"!(Y="HUSBAND")!(Y="WIFE")!(Y="LIFE PARTNER") S REL="SPO"
.E I Y="SELF" S REL="SEL"
.E I Y="SON"!(Y="DAUGHTER")!(Y="CHILD")!(Y="STEPSON")!(Y="STEPDAUGHTER")!(Y="STEP CHILD") S REL="CHD"
.E S REL="OTH"
Q REL
IN2(INSCO,POLICY,CASENUM) ;Do the IN2 Segment
N BADEEMPP,BADEEMPN,BADEPPAT,DEN,DENI
S CASENUM=$G(CASENUM,"")
D SET^BADEHL1(.ARY,"IN2",0)
D SET^BADEHL1(.ARY,CNT,1)
D SET^BADEHL1(.ARY,CASENUM,8) ; Medicaid Case Number
I POLICY'="" D
.S BADEEMPP=$P(POLICY,U,16)
.I BADEEMPP'="" D
..S BADEEMPN=$P($G(^AUTNEMPL(+BADEEMPP,0)),U,1) ;Employer name
..S X=BADEEMPP_"^"_BADEEMPN
..F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
...D SET^BADEHL1(.ARY,VAL,3,LP)
S DEN=$P($G(^AUTNINS(+INSCO,2)),U,5)
I DEN="U"!(DEN="") S DENI="MD"
E S DENI="DN"
D SET^BADEHL1(.ARY,DENI,59)
S IN2=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create IN2. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert
Q
;
CRTNULL ; Creates empty IN1/IN2
D SET^BADEHL1(.ARY,"IN1",0)
D SET^BADEHL1(.ARY,1,1)
S IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create IN1. "_ERR) Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
D SET^BADEHL1(.ARY,"IN2",0)
D SET^BADEHL1(.ARY,1,1)
S IN2=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create IN2. "_ERR) Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
Q
; Return HL7 formed patient address
PTADDR(DFN) ;EP
N HLQ,FLD,PID
S HLQ=HL1("Q")
S PID=$$EN^VAFHLPID(DFN,"11")
S FLD=$P(PID,HLFS,12)
Q FLD
BADEHLI ;IHS/MSC/MGH/PLS - Insurance or Dental Interface ;08-May-2009 20:54;PLS
+1 ;;1.0;DENTAL/EDR INTERFACE;**1**;AUG 22, 2011
+2 ;; Modified IHS/MSC/AMF 11/23/10 More descriptive alert messages, N for BHS variables
+3 ;=====================================================================================;
INS ;Entry point - Create the Insurance segment
+1 NEW CNT,INSARRAY,DGNAME,IN1,IN2
+2 ;IHS/MSC/AMF 1/4/2011 Newed BHS variables
+3 NEW BHSCOV,BHSDTL,BHSDTN,BHSDTS,BHSEDN,BHSI,BHSIDN,BHSINS,BHSITB,BHSJ,BHSN,BHSNM,BHSP,BHSPDN,BHSUFF,BHSXDT,BHSQ
+4 SET CNT=0
+5 DO MAID
DO MCARE
DO THIRD
DO RR
+6 IF 'CNT
Begin DoDot:1
+7 ;force creation of empty IN1/IN2 segments
DO CRTNULL
End DoDot:1
+8 QUIT
MAID ;See if the patient is on MEDICAID
+1 KILL BHSITB
+2 SET BHSPDN=0
FOR
SET BHSPDN=$ORDER(^AUPNMCD("B",DFN,BHSPDN))
IF BHSPDN=""
QUIT
DO BMAID
+3 SET BHSI=0
FOR
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
Begin DoDot:1
+4 SET BHSJ=$ORDER(BHSITB(BHSI,0))
+5 SET BHSP=BHSITB(BHSI,BHSJ)
+6 SET BHSPDN=$PIECE(BHSP,";",1)
SET BHSEDN=$PIECE(BHSP,";",2)
+7 DO DMAID
End DoDot:1
MAIDX KILL BHSCOV,BHSDTL,BHSDTN,BHSDTS,BHSEDN,BHSI,BHSIDN,BHSINS,BHSJ,BHSN,BHSPDN,BHSUFF,Y,BHSXDT,BHSNM,BHSP,BHSQ
+1 QUIT
BMAID IF '$DATA(^AUPNMCD(BHSPDN))
QUIT
+1 SET BHSEDN=0
FOR
SET BHSEDN=$ORDER(^AUPNMCD(BHSPDN,11,BHSEDN))
IF 'BHSEDN
QUIT
Begin DoDot:1
+2 SET BHSP=$GET(^AUPNMCD(BHSPDN,11,BHSEDN,0))
+3 SET BHSI=$PIECE(^AUPNMCD(BHSPDN,0),U,4)_"-"_$PIECE(BHSP,U,3)
+4 SET BHSJ=9999999-$PIECE(BHSP,U,1)
+5 SET BHSITB(BHSI,BHSJ)=BHSPDN_";"_BHSEDN
End DoDot:1
+6 QUIT
DMAID ;
+1 NEW INS,ADDR,PHONE,POLICY
+2 SET BHSNM=$GET(^AUPNMCD(BHSPDN,11,BHSEDN,0))
+3 ;-- add set of exp date variable, quit if not current
+4 SET (BHSXDT,X)=$PIECE(BHSNM,U,2)
+5 IF BHSXDT=""
SET BHSXDT=9999999
+6 IF BHSXDT<$$DT^XLFDT()
QUIT
+7 SET CNT=CNT+1
+8 DO SET^BADEHL1(.ARY,"IN1",0)
+9 DO SET^BADEHL1(.ARY,CNT,1)
+10 SET BHSN=$GET(^AUPNMCD(BHSPDN,0))
+11 SET INSCO=+$PIECE(BHSN,U,2)
+12 ;Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,2)
+13 ;Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,3)
+14 SET BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
+15 SET BHSINS=$SELECT($LENGTH(BHSINS):BHSINS,1:"???")
+16 ;Insurance company name
DO SET^BADEHL1(.ARY,BHSINS,4)
+17 ;Get data on the insurer
+18 SET INS=$GET(^AUTNINS(INSCO,0))
+19 DO MSCINS
+20 ;Get the eligibility and expiration dates
+21 SET X=$$HLDATE^HLFNC($PIECE(BHSNM,U,1))
+22 DO SET^BADEHL1(.ARY,X,12)
+23 SET X=$$HLDATE^HLFNC($PIECE(BHSNM,U,2))
+24 DO SET^BADEHL1(.ARY,X,13)
+25 SET X=$$VAL^XBDIQ1(9000004,BHSPDN,.11)
+26 ;D SET^BADEHL1(.ARY,X,15) ;Plan type
+27 ;Name of insured
+28 ;was .05
SET X=$$HLNAME^HLFNC($$GET1^DIQ(9000004,BHSPDN,2101),HLECH)
+29 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:1
+30 DO SET^BADEHL1(.ARY,VAL,16,LP)
End DoDot:1
+31 ;Relationship to patient
DO SET^BADEHL1(.ARY,$$GETREL($PIECE(BHSN,U,6)),17)
+32 ;Medicaid Eligible DOB
DO SET^BADEHL1(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(9000004,BHSPDN,2102,"I")),18)
+33 SET POLICY=+$PIECE(BHSN,U,9)
+34 ;Policy Holder's Address
+35 SET POLICY=$GET(^AUPN3PPH(POLICY,0))
+36 IF $LENGTH(POLICY)
Begin DoDot:1
+37 ; Street Address
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,9),19,1)
+38 ; City
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,11),19,3)
+39 ;SAIC/FJE FIX STATE POINTER 08/22/2011
SET BADEPOLP=$PIECE(POLICY,U,12)
+40 ; State Abbrev
DO SET^BADEHL1(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(9000003.1,+BADEPOLP,.12,"I"),1),19,4)
+41 ; Zip
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,13),19,5)
End DoDot:1
+42 ; IN1-36 is left blank
+43 ; Gender of Insured
DO SET^BADEHL1(.ARY,$$GET1^DIQ(9000004,BHSPDN,.07,"I"),43)
+44 ;Coverage Type
DO SET^BADEHL1(.ARY,$PIECE(BHSNM,U,3),47)
+45 ; Insured's Medicaid ID number
DO SET^BADEHL1(.ARY,$PIECE(BHSN,U,3),49)
+46 SET IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+47 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create IN1. "_ERR)
+48 ;Setup the IN2 segment
+49 DO IN2(INSCO,POLICY,$PIECE(BHSN,U,3))
+50 QUIT
MCARE ;ENTRY POINT
+1 ; See if patient is on MEDICARE
+2 IF '$DATA(^AUPNMCR(DFN))
QUIT
+3 SET BHSN=$GET(^AUPNMCR(DFN,0))
+4 IF '$DATA(^AUPNMCR(DFN,0))
QUIT
+5 KILL BHSITB
+6 SET BHSEDN=0
FOR
SET BHSEDN=$ORDER(^AUPNMCR(DFN,11,BHSEDN))
IF BHSEDN'=+BHSEDN
QUIT
Begin DoDot:1
+7 SET BHSP=$GET(^AUPNMCR(DFN,11,BHSEDN,0))
+8 SET BHSI=$PIECE(BHSN,U,2)_"-"_$PIECE(BHSP,U,3)
+9 SET BHSJ=9999999-$PIECE(BHSP,U,1)
+10 SET BHSITB(BHSI,BHSJ)=DFN_";"_BHSEDN
End DoDot:1
+11 SET BHSI=0
FOR BHSQ=0:0
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
Begin DoDot:1
+12 SET BHSJ=$ORDER(BHSITB(BHSI,0))
SET BHSP=BHSITB(BHSI,BHSJ)
+13 SET BHSPDN=$PIECE(BHSP,";",1)
SET BHSEDN=$PIECE(BHSP,";",2)
DO DMCARE
End DoDot:1
+14 QUIT
DMCARE ;
+1 SET BHSNM=^AUPNMCR(BHSPDN,11,BHSEDN,0)
+2 SET X=$PIECE(BHSNM,U,1)
+3 ;--add set of exp date variable, quit if not current
+4 SET (BHSXDT,X)=$PIECE(BHSNM,U,2)
+5 IF BHSXDT=""
SET BHSXDT=9999999
+6 IF BHSXDT<$$DT^XLFDT()
QUIT
+7 SET CNT=CNT+1
+8 SET BHSUFF=$PIECE(BHSN,U,4)
SET BHSUFF=$PIECE($GET(^AUTTMCS(+BHSUFF,0)),U,1)
+9 DO SET^BADEHL1(.ARY,"IN1",0)
+10 DO SET^BADEHL1(.ARY,CNT,1)
+11 SET BHSN=$GET(^AUPNMCR(BHSPDN,0))
+12 SET INSCO=+$PIECE(BHSN,U,2)
+13 ;Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,2)
+14 ;Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,3)
+15 SET BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
+16 SET BHSINS=$SELECT($LENGTH(BHSINS):BHSINS,1:"???")
+17 ;Insurance Company name
DO SET^BADEHL1(.ARY,BHSINS,4)
+18 ;Get data on the insurer
+19 SET INS=$GET(^AUTNINS(INSCO,0))
+20 DO MSCINS
+21 ;Get the eligibility and expiration dates
+22 SET X=$$HLDATE^HLFNC($PIECE(BHSNM,U,1))
+23 DO SET^BADEHL1(.ARY,X,12)
+24 SET X=$$HLDATE^HLFNC($PIECE(BHSNM,U,2))
+25 DO SET^BADEHL1(.ARY,X,13)
+26 ;D SET^BADEHL1(.ARY,$$GET1^DIQ(9000003,DFN,.04),8) ;Group Number
+27 ;D SET^BADEHL1(.ARY,$P(BHSNM,U,11),9) ;Group name
+28 ;D SET^BADEHL1(.ARY,$P(BHSNM,U,3),15) ;Plan type
+29 SET X=$$HLNAME^HLFNC($$GET1^DIQ(9000003,DFN,2101),HLECH)
+30 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:1
+31 DO SET^BADEHL1(.ARY,VAL,16,LP)
End DoDot:1
+32 ;Relationship to patient - File doesn't have .06 field
DO SET^BADEHL1(.ARY,"SEL",17)
+33 ;Medicare Eligible DOB
DO SET^BADEHL1(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(9000003,DFN,2102,"I")),18)
+34 ;No policy so no policy holder address
+35 ; Gender of Insured
DO SET^BADEHL1(.ARY,$PIECE(BHSNM,U,8),43)
+36 ;Coverage Type
DO SET^BADEHL1(.ARY,$PIECE(BHSNM,U,3),47)
+37 ; Insured's Medicare ID Number
DO SET^BADEHL1(.ARY,$PIECE(BHSN,U,3),49)
+38 SET IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+39 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create Medicaid IN1. "_ERR)
+40 DO IN2(INSCO,"")
+41 KILL BHSXDT,BHSNM
+42 QUIT
THIRD ;EP
+1 ; OTHER THIRD PARTY
+2 ; Private Insurance Eligible
IF $ORDER(^AUPNPRVT(DFN,11,0))=""
QUIT
+3 NEW BHSITB,BHSIDN,BHSP,BHSI,BHSJ
+4 SET BHSIDN=0
FOR
SET BHSIDN=$ORDER(^AUPNPRVT(DFN,11,BHSIDN))
IF 'BHSIDN
QUIT
Begin DoDot:1
+5 SET BHSP=$GET(^AUPNPRVT(DFN,11,BHSIDN,0))
+6 SET BHSITB($PIECE(BHSP,U,1)_"-"_$PIECE(BHSP,U,3),9999999-$PIECE(BHSP,U,6))=BHSIDN
End DoDot:1
+7 SET BHSI=""
FOR
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
Begin DoDot:1
+8 SET BHSJ=""
FOR
SET BHSJ=$ORDER(BHSITB(BHSI,BHSJ))
IF BHSJ=""
QUIT
Begin DoDot:2
+9 SET BHSIDN=BHSITB(BHSI,BHSJ)
DO DTHIRD
End DoDot:2
End DoDot:1
+10 QUIT
DTHIRD ;Private insurance data
+1 NEW BADEPOLP,INS,ADDR,BHSINS,GRPIEN
+2 NEW BHSN,X,BHSXDT,INSCO,POLICY,MEMID
+3 SET (BADEPOLP,INS)=""
+4 SET BHSN=$GET(^AUPNPRVT(DFN,11,BHSIDN,0))
+5 SET MEMID=$PIECE($GET(^AUPNPRVT(DFN,11,BHSIDN,2)),U)
+6 ;Policy Number
SET BADEPLCY=$PIECE(BHSN,U,2)
+7 ;Insurer name
SET BHSINS=$PIECE($GET(^AUTNINS(+$PIECE(BHSN,U,1),0)),U,1)
+8 ;policy holder pointer
SET BADEPOLP=$PIECE(BHSN,U,8)
+9 ;-- add set of exp date variable, quit if not current
+10 SET (BHSXDT,X)=$PIECE(BHSN,U,7)
+11 IF BHSXDT=""
SET BHSXDT=9999999
+12 IF BHSXDT<$$DT^XLFDT()
QUIT
+13 SET INSCO=+BHSN
+14 SET CNT=CNT+1
+15 DO SET^BADEHL1(.ARY,"IN1",0)
+16 DO SET^BADEHL1(.ARY,CNT,1)
+17 ; Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,2)
+18 ; Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,3)
+19 SET BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
+20 SET BHSINS=$SELECT($LENGTH(BHSINS):BHSINS,1:"???")
+21 ;Insurance company name
DO SET^BADEHL1(.ARY,BHSINS,4)
+22 ;Get data on the insurer
+23 SET INS=$GET(^AUTNINS(INSCO,0))
+24 DO MSCINS
+25 ;
+26 ;Policy Node 0
SET POLICY=$GET(^AUPN3PPH(+BADEPOLP,0))
+27 ; Pointer to Employer Group Insurance
SET GRPIEN=$PIECE(POLICY,U,6)
+28 ;Group Number
DO SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.77,GRPIEN,.02),8)
+29 ;Group Name
DO SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.77,GRPIEN,.01),9)
+30 ;Get the eligibility and expiration dates
+31 SET X=$$HLDATE^HLFNC($PIECE(POLICY,U,17))
+32 DO SET^BADEHL1(.ARY,X,12)
+33 SET X=$$HLDATE^HLFNC($PIECE(POLICY,U,18))
+34 DO SET^BADEHL1(.ARY,X,13)
+35 ;Name of insured
+36 SET X=$$HLNAME^HLFNC($PIECE(POLICY,U))
+37 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:1
+38 DO SET^BADEHL1(.ARY,VAL,16,LP)
End DoDot:1
+39 ;Relationship to patient
+40 DO SET^BADEHL1(.ARY,$$GETREL($PIECE(BHSN,U,5)),17)
+41 ;
+42 SET X=$$HLDATE^HLFNC($PIECE(POLICY,U,19))
+43 ;Insured's DOB
DO SET^BADEHL1(.ARY,X,18)
+44 ;Holder's Address
+45 ; Street Address
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,9),19,1)
+46 ; City
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,11),19,3)
+47 ; State Abbrev
DO SET^BADEHL1(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(9000003.1,+BADEPOLP,.12,"I"),1),19,4)
+48 ; Zip
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,13),19,5)
+49 ;
+50 ; Gender of Insured
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,8),43)
+51 IF BADEPOLP
Begin DoDot:1
+52 ;Not Self
+53 ;Member Number
DO SET^BADEHL1(.ARY,MEMID,36)
+54 ;Insured's Member ID number
DO SET^BADEHL1(.ARY,$PIECE(POLICY,U,4),49)
End DoDot:1
+55 IF '$TEST
Begin DoDot:1
+56 ;Self
+57 ;Member Number
DO SET^BADEHL1(.ARY,MEMID,36)
End DoDot:1
+58 ;Coverage Type
DO SET^BADEHL1(.ARY,$$GET1^DIQ(9000003.1,+BADEPOLP,.05),47)
+59 ;D SET^BADEHL1(.ARY,$P(POLICY,U,4),49) ;Insured's ID number
+60 SET IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+61 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create IN1. "_ERR)
+62 ;Do IN2 segment
+63 DO IN2(INSCO,POLICY)
+64 QUIT
RR ;EP
+1 ; RAILROAD RETIREMENT
+2 IF '$DATA(^AUPNRRE(DFN))
QUIT
+3 NEW BHSN,BHSITB,BHSUFF,BHSEDN,BHSP,BHSI,BHSJ,BHSQ,BHSP,BHSPDN
+4 NEW BHSNM,BHSPFX,BHSCTYP
+5 SET BHSN=^AUPNRRE(DFN,0)
+6 ;S BHSINS=$P(^AUTNINS($P(BHSN,U,2),0),U,1)
+7 ;S BHSUFF=$P(BHSN,U,3)
+8 SET BHSEDN=0
FOR
SET BHSEDN=$ORDER(^AUPNRRE(DFN,11,BHSEDN))
IF BHSEDN'=+BHSEDN
QUIT
Begin DoDot:1
+9 SET BHSP=$GET(^AUPNRRE(DFN,11,BHSEDN,0))
+10 SET BHSI=$PIECE(BHSN,U,2)_"-"_$PIECE(BHSP,U,3)
SET BHSJ=9999999-$PIECE(BHSP,U,1)
+11 SET BHSITB(BHSI,BHSJ)=DFN_";"_BHSEDN
End DoDot:1
+12 SET BHSI=0
FOR BHSQ=0:0
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
Begin DoDot:1
+13 SET BHSJ=$ORDER(BHSITB(BHSI,0))
SET BHSP=BHSITB(BHSI,BHSJ)
+14 SET BHSPDN=$PIECE(BHSP,";",1)
SET BHSEDN=$PIECE(BHSP,";",2)
DO DRR
End DoDot:1
+15 QUIT
DRR ;
+1 NEW X,BHSXDT,BHSINS
+2 SET BHSNM=^AUPNRRE(BHSPDN,11,BHSEDN,0)
+3 SET X=$PIECE(BHSNM,U,1)
+4 ;-- add set of exp date variable, quit if not current
+5 SET (BHSXDT,X)=$PIECE(BHSNM,U,2)
+6 IF BHSXDT=""
SET BHSXDT=9999999
+7 IF BHSXDT<$$DT^XLFDT()
QUIT
+8 SET CNT=CNT+1
+9 DO SET^BADEHL1(.ARY,"IN1",0)
+10 DO SET^BADEHL1(.ARY,CNT,1)
+11 SET BHSN=^AUPNRRE(DFN,0)
+12 SET INSCO=+$PIECE(BHSN,U,2)
+13 ; Prefix
SET BHSPFX=$$GET1^DIQ(9000005,DFN,.03)
+14 ; Coverage Type
SET BHSCTYP=$PIECE(BHSNM,U,3)
+15 ; Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,2)
+16 ; Insurer IEN
DO SET^BADEHL1(.ARY,INSCO,3)
+17 SET BHSINS=$$GET1^DIQ(9999999.18,INSCO,.01)
+18 SET BHSINS=$SELECT($LENGTH(BHSINS):BHSINS,1:"???")
+19 ;Insurance Company name
DO SET^BADEHL1(.ARY,BHSINS,4)
+20 ;Get data on the insurer
+21 SET INS=$GET(^AUTNINS(INSCO,0))
+22 DO MSCINS
+23 ;Get the eligibility and expiration dates
+24 SET X=$$HLDATE^HLFNC($PIECE(BHSNM,U,1))
+25 DO SET^BADEHL1(.ARY,X,12)
+26 SET X=$$HLDATE^HLFNC($PIECE(BHSNM,U,2))
+27 DO SET^BADEHL1(.ARY,X,13)
+28 ;Group Number
DO SET^BADEHL1(.ARY,$$GET1^DIQ(9000005,DFN,.04),8)
+29 ;Name of insured
SET X=$$HLNAME^HLFNC($$GET1^DIQ(9000005,DFN,2101),HLECH)
+30 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:1
+31 DO SET^BADEHL1(.ARY,VAL,16,LP)
End DoDot:1
+32 ;Relationship to patient - File doesn't have .06 field
DO SET^BADEHL1(.ARY,"SEL",17)
+33 ;Insured's DOB
DO SET^BADEHL1(.ARY,$$HLDATE^HLFNC($PIECE(BHSNM,U,9)),18)
+34 DO SET^BADEHL1(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(9000005,DFN,2102,"I")),18)
+35 ;Insured's address
+36 ; No policy so no policy holder address
+37 ;S FLD=$$PTADDR(DFN)
+38 ;F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D
+39 ;.D SET^BADEHL1(.ARY,VAL,19,LP)
+40 ;D SET^BADEHL1(.ARY,$P(BHSN,U,4),36) ;policy number
+41 ; Gender of Insured
DO SET^BADEHL1(.ARY,$PIECE(BHSNM,U,8),43)
+42 ; Coverage Type
DO SET^BADEHL1(.ARY,$PIECE(BHSNM,U,3),47)
+43 ; ID Number
DO SET^BADEHL1(.ARY,$SELECT(BHSCTYP="D":$PIECE(BHSNM,U,6),1:BHSPFX_$PIECE(BHSN,U,4)),49)
+44 SET IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+45 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create Railroad IN1. "_ERR)
+46 ;Setup the IN2 segment
+47 DO IN2(INSCO,"")
+48 KILL BHSNM,BHSXDT
+49 QUIT
MSCINS ;Insurance company data
+1 IF '$LENGTH(INS)
QUIT
+2 NEW ST,ZIP,ADDR,LP,VAL,PHONE,PHD
+3 ;State Abbrev
SET ST=$$GET1^DIQ(5,$PIECE(INS,U,4),1)
+4 SET ZIP=$EXTRACT($PIECE(INS,U,5),1,5)
+5 SET ADDR=$PIECE(INS,U,2)_"^^"_$PIECE(INS,U,3)_"^"_ST_"^"_ZIP
+6 FOR LP=1:1:$LENGTH(ADDR,$EXTRACT(HLECH))
SET VAL=$PIECE(ADDR,$EXTRACT(HLECH),LP)
Begin DoDot:1
+7 DO SET^BADEHL1(.ARY,VAL,5,LP)
End DoDot:1
+8 ;Company Contact Name
SET PHD=$PIECE(BHSN,U,9)
+9 SET PHD=$$HLNAME^HLFNC($$GET1^DIQ(9000003.1,PHD,.01),HLECH)
+10 FOR LP=1:1:$LENGTH(PHD,$EXTRACT(HLECH))
SET VAL=$PIECE(PHD,$EXTRACT(HLECH),LP)
Begin DoDot:1
+11 DO SET^BADEHL1(.ARY,VAL,6,LP)
End DoDot:1
+12 SET PHONE=$$HLPHONE^HLFNC($PIECE(INS,U,6))
+13 IF $LENGTH(PHONE)
Begin DoDot:1
+14 ;Company Phone Number
DO SET^BADEHL1(.ARY,PHONE,7,1)
+15 DO SET^BADEHL1(.ARY,"WPH",7,2)
End DoDot:1
+16 QUIT
GETREL(RIEN) ;Find the relationship
+1 NEW Y,REL
+2 SET REL=""
+3 IF +RIEN
Begin DoDot:1
+4 SET Y=$$GET1^DIQ(9999999.36,RIEN,.01)
+5 IF Y="SPOUSE"!(Y="HUSBAND")!(Y="WIFE")!(Y="LIFE PARTNER")
SET REL="SPO"
+6 IF '$TEST
IF Y="SELF"
SET REL="SEL"
+7 IF '$TEST
IF Y="SON"!(Y="DAUGHTER")!(Y="CHILD")!(Y="STEPSON")!(Y="STEPDAUGHTER")!(Y="STEP CHILD")
SET REL="CHD"
+8 IF '$TEST
SET REL="OTH"
End DoDot:1
+9 QUIT REL
IN2(INSCO,POLICY,CASENUM) ;Do the IN2 Segment
+1 NEW BADEEMPP,BADEEMPN,BADEPPAT,DEN,DENI
+2 SET CASENUM=$GET(CASENUM,"")
+3 DO SET^BADEHL1(.ARY,"IN2",0)
+4 DO SET^BADEHL1(.ARY,CNT,1)
+5 ; Medicaid Case Number
DO SET^BADEHL1(.ARY,CASENUM,8)
+6 IF POLICY'=""
Begin DoDot:1
+7 SET BADEEMPP=$PIECE(POLICY,U,16)
+8 IF BADEEMPP'=""
Begin DoDot:2
+9 ;Employer name
SET BADEEMPN=$PIECE($GET(^AUTNEMPL(+BADEEMPP,0)),U,1)
+10 SET X=BADEEMPP_"^"_BADEEMPN
+11 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:3
+12 DO SET^BADEHL1(.ARY,VAL,3,LP)
End DoDot:3
End DoDot:2
End DoDot:1
+13 SET DEN=$PIECE($GET(^AUTNINS(+INSCO,2)),U,5)
+14 IF DEN="U"!(DEN="")
SET DENI="MD"
+15 IF '$TEST
SET DENI="DN"
+16 DO SET^BADEHL1(.ARY,DENI,59)
+17 SET IN2=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+18 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create IN2. "_ERR)
+19 QUIT
+20 ;
CRTNULL ; Creates empty IN1/IN2
+1 DO SET^BADEHL1(.ARY,"IN1",0)
+2 DO SET^BADEHL1(.ARY,1,1)
+3 SET IN1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+4 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create IN1. "_ERR)
QUIT
+5 DO SET^BADEHL1(.ARY,"IN2",0)
+6 DO SET^BADEHL1(.ARY,1,1)
+7 SET IN2=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+8 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create IN2. "_ERR)
QUIT
+9 QUIT
+10 ; Return HL7 formed patient address
PTADDR(DFN) ;EP
+1 NEW HLQ,FLD,PID
+2 SET HLQ=HL1("Q")
+3 SET PID=$$EN^VAFHLPID(DFN,"11")
+4 SET FLD=$PIECE(PID,HLFS,12)
+5 QUIT FLD
