BADEHLZ ;IHS/MSC/MGH/PLS/VAC - Dentrix HL7 interface ;16-Jul-2009 10:35;PLS
;;1.0;DENTAL/EDR INTERFACE;**1**;AUG 22, 2011
;; Modified IHS/MSC/AMF 11/23/10 More descriptive alerts
Q
ZP2 ;Create the ZP2 segment
N AFFIL,TRIBE,ZP2,NODE,NODE11,NODE26,SSN,FLD,K,X,CNT,TEXT,CODE
N LP,VAL,BENE,ERR,SSNSTAT
N BCITY,BSTATE,TMV,TMVE,EMC,EMCE,FCITY,FNAME,FSTATE,MCITY,MSTATE,HLOC
N HREG,LOC,REG,REM,REM1
S CNT=0
S NODE=$G(^AUPNPAT(DFN,0))
S NODE11=$G(^AUPNPAT(DFN,11))
S NODE26=$G(^AUPNPAT(DFN,26))
Q:NODE=""
S CNT=CNT+1
D SET^BADEHL1(.ARY,"ZP2",0)
D SET^BADEHL1(.ARY,CNT,1)
;Date of last reg
S X=$$HLDATE^HLFNC($P(NODE,U,3))
D SET^BADEHL1(.ARY,X,2)
;outpt release date
S X=$$HLDATE^HLFNC($P(NODE,U,4))
D SET^BADEHL1(.ARY,X,3)
;revoked date
S X=$$HLDATE^HLFNC($P(NODE,U,5))
D SET^BADEHL1(.ARY,X,4)
;Enrollment Number
D SET^BADEHL1(.ARY,$P(NODE,U,7),5)
;Tribal affiliation
S AFFIL=$P(NODE,U,9)
I AFFIL'="" D
.S TRIBE=$P($G(^AUTTTRI(AFFIL,0)),U,1)
.S CODE=$P($G(^AUTTTRI(AFFIL,0)),U,2)
.S X=CODE_"^"_TRIBE
.F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
..D SET^BADEHL1(.ARY,VAL,6,LP)
;Blood type code
D SET^BADEHL1(.ARY,$P(NODE,U,13),7)
;Assigned benefits obtained date
S X=$$HLDATE^HLFNC($P(NODE,U,17))
D SET^BADEHL1(.ARY,X,9)
;Assigned benefits expired date
S X=$$HLDATE^HLFNC($P(NODE,U,18))
D SET^BADEHL1(.ARY,X,10)
;SSN verification status
S SSN=$P(NODE,U,23)
I SSN'="" D
.S SSNSTAT=$P($G(^AUTTSSN(SSN,0)),U,1),TEXT=$P($G(^AUTTSSN(SSN,0)),U,2)
.D SET^BADEHL1(.ARY,SSNSTAT,11,1) ;SSN Verification Status Code
.D SET^BADEHL1(.ARY,TEXT,11,2) ;SSN Verification Status Text
.D SET^BADEHL1(.ARY,"99IHS",11,3)
;Reason for no SSN
S SSN=$P(NODE,U,24)
I SSN'="" D
.S TEXT=$S(SSN=1:"Not Available",SSN=2:"Patient Refused",SSN=3:"Patient will submit",1:"")
.S X=SSN_"^"_TEXT_"^99IHS"
.F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
..D SET^BADEHL1(.ARY,VAL,12,LP)
;Birth place city/state
S BCITY=$P($G(^DPT(DFN,0)),U,11)
S BSTATE=$P($G(^DPT(DFN,0)),U,12)
S BSTATE=$$GET1^DIQ(5,BSTATE,1)
D SET^BADEHL1(.ARY,BCITY,13,3) ; Birth City
D SET^BADEHL1(.ARY,BSTATE,13,4) ; Birth State Abbrev
;S X="^^"_BCITY_"^"_BSTATE
;F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
;.D SET^BADEHL1(.ARY,VAL,13,LP)
;Birth certificate number
D SET^BADEHL1(.ARY,$P(NODE11,U,5),14)
;Tribe of membership
S TRIBE=$P(NODE11,U,8)
I TRIBE'="" D
.S TEXT=$P($G(^AUTTTRI(TRIBE,0)),U,1)
.S CODE=$P($G(^AUTTTRI(TRIBE,0)),U,2)
.S X=CODE_"^"_TEXT_"^99IHS"
.F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
..D SET^BADEHL1(.ARY,VAL,15,LP)
;Tribe quantum
D SET^BADEHL1(.ARY,$P(NODE11,U,9),16)
;Indian quantum
D SET^BADEHL1(.ARY,$P(NODE11,U,10),17)
;classification beneficiary
S BENE=$P(NODE11,U,11)
I BENE D
.D SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.25,BENE,.02),18,1)
.D SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.25,BENE,.01),18,2)
.D SET^BADEHL1(.ARY,"99IHS",18,3)
;Current residence date
S X=$$HLDATE^HLFNC($P(NODE11,U,13))
D SET^BADEHL1(.ARY,X,19)
D SET^BADEHL1(.ARY,$$GET1^DIQ(5,$P(NODE11,U,15),1),20) ;State of Death
D SET^BADEHL1(.ARY,$P(NODE11,U,16),21) ;Death Certificate Number
;current community
D SET^BADEHL1(.ARY,$P(NODE11,U,18),22)
;tribe membership verified
S TMV=$P(NODE11,U,19)
I TMV'="" D
.S TMVE=$$EXTERNAL^DILFD(9000001,1119,"",TMV)
.S X=TMV_"^"_TMVE_"^99IHS"
.F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
..D SET^BADEHL1(.ARY,VAL,23,LP)
;residence verified
D SET^BADEHL1(.ARY,$P(NODE11,U,21),24)
;date eligibility determined
D SET^BADEHL1(.ARY,$$HLDATE^HLFNC($P(NODE11,U,23)),25)
;eligible minor child code
S EMC=$P(NODE11,U,25)
I EMC'="" D
.S EMCE=$$EXTERNAL^DILFD(9000001,1125,"",EMC)
.S X=EMC_"^"_EMCE_"^99IHS"
.F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
..D SET^BADEHL1(.ARY,VAL,26,LP)
D SET^BADEHL1(.ARY,$$GETWP(DFN,12,100,HLECH),27) ; Location of Home
D SET^BADEHL1(.ARY,$$GETWP(DFN,13,100,HLECH),28) ; Additional reg information
D SET^BADEHL1(.ARY,$$GETWP(DFN,14,100,HLECH),29) ; Remarks
;father's name
S FNAME=$$GET1^DIQ(2,DFN_",",.2401)
D SET^BADEHL1(.ARY,FNAME,31)
;father's city/state
S FCITY=$P(NODE26,U,2),FSTATE=+$P(NODE26,U,3)
;I FSTATE'="" S FSTATE=$P($G(^DIC(5,FSTATE,0)),U,1)
S FSTATE=$$GET1^DIQ(5,FSTATE,1) ; State Abbrev
S X="^^"_FCITY_"^"_FSTATE
F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,32,LP)
;mother's city/state
S MCITY=$P(NODE26,U,5),MSTATE=+$P(NODE26,U,6)
;I MSTATE'="" S MSTATE=$P($G(^DIC(5,MSTATE,0)),U,1)
S MSTATE=$$GET1^DIQ(5,MSTATE,1) ; State Abbrev
S X="^^"_MCITY_"^"_MSTATE
F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
.D SET^BADEHL1(.ARY,VAL,33,LP)
S ZP2=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create ZP2. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert
Q
;Return text in WP array
;Input:
; DFN: Patient pointer
; NODE: File 9000001
; LIMIT: Max characters (defaults to 500)
GETWP(DFN,NODE,LIMIT,HLECH) ;
N RET,LP,VAL
S LIMIT=$G(LIMIT,500)
S RET="",LP=0
Q:'$D(^AUPNPAT(DFN,NODE)) RET
F S LP=$O(^AUPNPAT(DFN,NODE,LP)) Q:'LP D Q:$L(RET)>(LIMIT-1)
.S VAL=$G(^AUPNPAT(DFN,NODE,LP,0))
.I ($L(RET)+($L(VAL)-1))>LIMIT D
..S RET=RET_" "_$E(VAL,1,(LIMIT-($L(RET)+1)))
.E D
..S RET=RET_" "_VAL
Q $TR(RET,"|","_") ; translate field separator to underscore
BADEHLZ ;IHS/MSC/MGH/PLS/VAC - Dentrix HL7 interface ;16-Jul-2009 10:35;PLS
+1 ;;1.0;DENTAL/EDR INTERFACE;**1**;AUG 22, 2011
+2 ;; Modified IHS/MSC/AMF 11/23/10 More descriptive alerts
+3 QUIT
ZP2 ;Create the ZP2 segment
+1 NEW AFFIL,TRIBE,ZP2,NODE,NODE11,NODE26,SSN,FLD,K,X,CNT,TEXT,CODE
+2 NEW LP,VAL,BENE,ERR,SSNSTAT
+3 NEW BCITY,BSTATE,TMV,TMVE,EMC,EMCE,FCITY,FNAME,FSTATE,MCITY,MSTATE,HLOC
+4 NEW HREG,LOC,REG,REM,REM1
+5 SET CNT=0
+6 SET NODE=$GET(^AUPNPAT(DFN,0))
+7 SET NODE11=$GET(^AUPNPAT(DFN,11))
+8 SET NODE26=$GET(^AUPNPAT(DFN,26))
+9 IF NODE=""
QUIT
+10 SET CNT=CNT+1
+11 DO SET^BADEHL1(.ARY,"ZP2",0)
+12 DO SET^BADEHL1(.ARY,CNT,1)
+13 ;Date of last reg
+14 SET X=$$HLDATE^HLFNC($PIECE(NODE,U,3))
+15 DO SET^BADEHL1(.ARY,X,2)
+16 ;outpt release date
+17 SET X=$$HLDATE^HLFNC($PIECE(NODE,U,4))
+18 DO SET^BADEHL1(.ARY,X,3)
+19 ;revoked date
+20 SET X=$$HLDATE^HLFNC($PIECE(NODE,U,5))
+21 DO SET^BADEHL1(.ARY,X,4)
+22 ;Enrollment Number
+23 DO SET^BADEHL1(.ARY,$PIECE(NODE,U,7),5)
+24 ;Tribal affiliation
+25 SET AFFIL=$PIECE(NODE,U,9)
+26 IF AFFIL'=""
Begin DoDot:1
+27 SET TRIBE=$PIECE($GET(^AUTTTRI(AFFIL,0)),U,1)
+28 SET CODE=$PIECE($GET(^AUTTTRI(AFFIL,0)),U,2)
+29 SET X=CODE_"^"_TRIBE
+30 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:2
+31 DO SET^BADEHL1(.ARY,VAL,6,LP)
End DoDot:2
End DoDot:1
+32 ;Blood type code
+33 DO SET^BADEHL1(.ARY,$PIECE(NODE,U,13),7)
+34 ;Assigned benefits obtained date
+35 SET X=$$HLDATE^HLFNC($PIECE(NODE,U,17))
+36 DO SET^BADEHL1(.ARY,X,9)
+37 ;Assigned benefits expired date
+38 SET X=$$HLDATE^HLFNC($PIECE(NODE,U,18))
+39 DO SET^BADEHL1(.ARY,X,10)
+40 ;SSN verification status
+41 SET SSN=$PIECE(NODE,U,23)
+42 IF SSN'=""
Begin DoDot:1
+43 SET SSNSTAT=$PIECE($GET(^AUTTSSN(SSN,0)),U,1)
SET TEXT=$PIECE($GET(^AUTTSSN(SSN,0)),U,2)
+44 ;SSN Verification Status Code
DO SET^BADEHL1(.ARY,SSNSTAT,11,1)
+45 ;SSN Verification Status Text
DO SET^BADEHL1(.ARY,TEXT,11,2)
+46 DO SET^BADEHL1(.ARY,"99IHS",11,3)
End DoDot:1
+47 ;Reason for no SSN
+48 SET SSN=$PIECE(NODE,U,24)
+49 IF SSN'=""
Begin DoDot:1
+50 SET TEXT=$SELECT(SSN=1:"Not Available",SSN=2:"Patient Refused",SSN=3:"Patient will submit",1:"")
+51 SET X=SSN_"^"_TEXT_"^99IHS"
+52 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:2
+53 DO SET^BADEHL1(.ARY,VAL,12,LP)
End DoDot:2
End DoDot:1
+54 ;Birth place city/state
+55 SET BCITY=$PIECE($GET(^DPT(DFN,0)),U,11)
+56 SET BSTATE=$PIECE($GET(^DPT(DFN,0)),U,12)
+57 SET BSTATE=$$GET1^DIQ(5,BSTATE,1)
+58 ; Birth City
DO SET^BADEHL1(.ARY,BCITY,13,3)
+59 ; Birth State Abbrev
DO SET^BADEHL1(.ARY,BSTATE,13,4)
+60 ;S X="^^"_BCITY_"^"_BSTATE
+61 ;F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
+62 ;.D SET^BADEHL1(.ARY,VAL,13,LP)
+63 ;Birth certificate number
+64 DO SET^BADEHL1(.ARY,$PIECE(NODE11,U,5),14)
+65 ;Tribe of membership
+66 SET TRIBE=$PIECE(NODE11,U,8)
+67 IF TRIBE'=""
Begin DoDot:1
+68 SET TEXT=$PIECE($GET(^AUTTTRI(TRIBE,0)),U,1)
+69 SET CODE=$PIECE($GET(^AUTTTRI(TRIBE,0)),U,2)
+70 SET X=CODE_"^"_TEXT_"^99IHS"
+71 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:2
+72 DO SET^BADEHL1(.ARY,VAL,15,LP)
End DoDot:2
End DoDot:1
+73 ;Tribe quantum
+74 DO SET^BADEHL1(.ARY,$PIECE(NODE11,U,9),16)
+75 ;Indian quantum
+76 DO SET^BADEHL1(.ARY,$PIECE(NODE11,U,10),17)
+77 ;classification beneficiary
+78 SET BENE=$PIECE(NODE11,U,11)
+79 IF BENE
Begin DoDot:1
+80 DO SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.25,BENE,.02),18,1)
+81 DO SET^BADEHL1(.ARY,$$GET1^DIQ(9999999.25,BENE,.01),18,2)
+82 DO SET^BADEHL1(.ARY,"99IHS",18,3)
End DoDot:1
+83 ;Current residence date
+84 SET X=$$HLDATE^HLFNC($PIECE(NODE11,U,13))
+85 DO SET^BADEHL1(.ARY,X,19)
+86 ;State of Death
DO SET^BADEHL1(.ARY,$$GET1^DIQ(5,$PIECE(NODE11,U,15),1),20)
+87 ;Death Certificate Number
DO SET^BADEHL1(.ARY,$PIECE(NODE11,U,16),21)
+88 ;current community
+89 DO SET^BADEHL1(.ARY,$PIECE(NODE11,U,18),22)
+90 ;tribe membership verified
+91 SET TMV=$PIECE(NODE11,U,19)
+92 IF TMV'=""
Begin DoDot:1
+93 SET TMVE=$$EXTERNAL^DILFD(9000001,1119,"",TMV)
+94 SET X=TMV_"^"_TMVE_"^99IHS"
+95 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:2
+96 DO SET^BADEHL1(.ARY,VAL,23,LP)
End DoDot:2
End DoDot:1
+97 ;residence verified
+98 DO SET^BADEHL1(.ARY,$PIECE(NODE11,U,21),24)
+99 ;date eligibility determined
+100 DO SET^BADEHL1(.ARY,$$HLDATE^HLFNC($PIECE(NODE11,U,23)),25)
+101 ;eligible minor child code
+102 SET EMC=$PIECE(NODE11,U,25)
+103 IF EMC'=""
Begin DoDot:1
+104 SET EMCE=$$EXTERNAL^DILFD(9000001,1125,"",EMC)
+105 SET X=EMC_"^"_EMCE_"^99IHS"
+106 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:2
+107 DO SET^BADEHL1(.ARY,VAL,26,LP)
End DoDot:2
End DoDot:1
+108 ; Location of Home
DO SET^BADEHL1(.ARY,$$GETWP(DFN,12,100,HLECH),27)
+109 ; Additional reg information
DO SET^BADEHL1(.ARY,$$GETWP(DFN,13,100,HLECH),28)
+110 ; Remarks
DO SET^BADEHL1(.ARY,$$GETWP(DFN,14,100,HLECH),29)
+111 ;father's name
+112 SET FNAME=$$GET1^DIQ(2,DFN_",",.2401)
+113 DO SET^BADEHL1(.ARY,FNAME,31)
+114 ;father's city/state
+115 SET FCITY=$PIECE(NODE26,U,2)
SET FSTATE=+$PIECE(NODE26,U,3)
+116 ;I FSTATE'="" S FSTATE=$P($G(^DIC(5,FSTATE,0)),U,1)
+117 ; State Abbrev
SET FSTATE=$$GET1^DIQ(5,FSTATE,1)
+118 SET X="^^"_FCITY_"^"_FSTATE
+119 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:1
+120 DO SET^BADEHL1(.ARY,VAL,32,LP)
End DoDot:1
+121 ;mother's city/state
+122 SET MCITY=$PIECE(NODE26,U,5)
SET MSTATE=+$PIECE(NODE26,U,6)
+123 ;I MSTATE'="" S MSTATE=$P($G(^DIC(5,MSTATE,0)),U,1)
+124 ; State Abbrev
SET MSTATE=$$GET1^DIQ(5,MSTATE,1)
+125 SET X="^^"_MCITY_"^"_MSTATE
+126 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:1
+127 DO SET^BADEHL1(.ARY,VAL,33,LP)
End DoDot:1
+128 SET ZP2=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+129 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create ZP2. "_ERR)
+130 QUIT
+131 ;Return text in WP array
+132 ;Input:
+133 ; DFN: Patient pointer
+134 ; NODE: File 9000001
+135 ; LIMIT: Max characters (defaults to 500)
GETWP(DFN,NODE,LIMIT,HLECH) ;
+1 NEW RET,LP,VAL
+2 SET LIMIT=$GET(LIMIT,500)
+3 SET RET=""
SET LP=0
+4 IF '$DATA(^AUPNPAT(DFN,NODE))
QUIT RET
+5 FOR
SET LP=$ORDER(^AUPNPAT(DFN,NODE,LP))
IF 'LP
QUIT
Begin DoDot:1
+6 SET VAL=$GET(^AUPNPAT(DFN,NODE,LP,0))
+7 IF ($LENGTH(RET)+($LENGTH(VAL)-1))>LIMIT
Begin DoDot:2
+8 SET RET=RET_" "_$EXTRACT(VAL,1,(LIMIT-($LENGTH(RET)+1)))
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 SET RET=RET_" "_VAL
End DoDot:2
End DoDot:1
IF $LENGTH(RET)>(LIMIT-1)
QUIT
+11 ; translate field separator to underscore
QUIT $TRANSLATE(RET,"|","_")
