- 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,"|","_")
