ABME5N4 ; IHS/ASDST/DMJ - 837 N4 Segment
;;2.6;IHS Third Party Billing System;**6,8,9**;NOV 12, 2009;Build 379
;City/State/Zip
;
EP(X,Y) ;EP - START HERE
;x=file
;y=internal entry number
K ABMREC("N4"),ABMR("N4")
S:X=3 X=9000003.1
S ABME("RTYPE")="N4"
D LOOP
K ABME
Q
LOOP ;LOOP HERE
F I=10:10:80 D
.D @I
.I $D(^ABMEXLM("AA",+$G(ABMP("INS")),+$G(ABMP("EXP")),ABME("RTYPE"),I)) D @(^(I))
.I $G(ABMREC("N4"))'="" S ABMREC("N4")=ABMREC("N4")_"*"
.S ABMREC("N4")=$G(ABMREC("N4"))_ABMR("N4",I)
Q
10 ;segment
S ABMR("N4",10)="N4"
Q
20 ;N401 - City Name
I X=2 S ABMR("N4",20)=$P($G(^DPT(Y,.11)),"^",4)
I X=4 S ABMR("N4",20)=$P($G(^DIC(4,Y,1)),"^",3)
I X=9000003.1 S ABMR("N4",20)=$P($G(^AUPN3PPH(Y,0)),"^",11)
I X=9999999.06 S ABMR("N4",20)=$P($G(^AUTTLOC(Y,0)),"^",13)
I X=9999999.18 S ABMR("N4",20)=$P($G(^AUTNINS(Y,1)),"^",3)
I X=9002274.35 S ABMR("N4",20)=$P($G(^AUTTVNDR($P($G(^ABMRLABS(Y,0)),U),13)),U,2)
I X=200 S ABMR("N4",20)=$P($G(^VA(200,Y,.11)),U,4)
I X="AMB",(Y="PU") S ABMR("N4",20)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,4)
I X="AMB",(Y="DO") D
.S ABMR("F")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
.S ABMR("IEN")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
.;start old code abm*2.6*8 HEAT45242
.;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,3)
.;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,4)
.;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,3)
.;end old code start new code HEAT45242
.;I ABMR("F")["AUTNINS" S ABMR("N4",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,3)
.I ABMR("F")["AUPNPAT" S ABMR("N4",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,4)
.I ABMR("F")["AUTTLOC" S ABMR("N4",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,3)
.I ABMR("F")["AUTTVNDR" S ABMR("N4",20)=$P($G(^AUTTVNDR(ABMR("IEN"),13)),U,2)
.;end new code HEAT45242
Q
30 ;N402 - State or Province
I X=2 S ABMR("N4",30)=$P($G(^DPT(Y,.11)),"^",5)
I X=4 S ABMR("N4",30)=$P($G(^DIC(4,Y,0)),"^",2)
I X=9000003.1 S ABMR("N4",30)=$P($G(^AUPN3PPH(Y,0)),"^",12)
I X=9999999.06 S ABMR("N4",30)=$P($G(^AUTTLOC(Y,0)),"^",14)
I X=9999999.18 S ABMR("N4",30)=$P($G(^AUTNINS(Y,1)),"^",4)
I X=9002274.35 S ABMR("N4",30)=$P($G(^AUTTVNDR($P($G(^ABMRLABS(Y,0)),U),13)),U,3)
I X=200 S ABMR("N4",30)=$P($G(^VA(200,Y,.11)),U,5)
I X="AMB",(Y="PU") S ABMR("N4",30)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,5)
I X="AMB",(Y="DO") D
.S ABMR("F")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
.S ABMR("IEN")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
.;start old code abm*2.6*8 HEAT45242
.;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,4)
.;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,5)
.;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),0)),U,2)
.;end old code start new code HEAT45242
.;I ABMR("F")["AUTNINS" S ABMR("N4",30)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,4)
.I ABMR("F")["AUPNPAT" S ABMR("N4",30)=$P($G(^DPT(ABMR("IEN"),.11)),U,5)
.I ABMR("F")["AUTTLOC" S ABMR("N4",30)=$P($G(^DIC(4,ABMR("IEN"),0)),U,2)
.I ABMR("F")["AUTTVNDR" S ABMR("N4",30)=$P($G(^AUTTVNDR(ABMR("IEN"),13)),U,3)
.;end new codes HEAT45242
S ABMR("N4",30)=$P($G(^DIC(5,+ABMR("N4",30),0)),"^",2)
Q
40 ;N403 - Postal Code
I X=2 S ABMR("N4",40)=$P($G(^DPT(Y,.11)),"^",6)
I X=4 S ABMR("N4",40)=$P($G(^DIC(4,Y,1)),"^",4)
I X=9000003.1 S ABMR("N4",40)=$P($G(^AUPN3PPH(Y,0)),"^",13)
I X=9999999.06 S ABMR("N4",40)=$P($G(^AUTTLOC(Y,0)),"^",15)
I X=9999999.18 S ABMR("N4",40)=$P($G(^AUTNINS(Y,1)),"^",5)
I X=9002274.35 S ABMR("N4",40)=$P($G(^AUTTVNDR($P($G(^ABMRLABS(Y,0)),U),13)),U,4)
I X=200 S ABMR("N4",40)=$P($G(^VA(200,Y,.11)),U,6)
;I X="AMB",(Y="PU") S ABMR("N4",40)=$P($G(^ABMDBILL(DUZ(2),Y,12)),U,6) ;abm*2.6*9 NOHEAT IHS/SD/AML 1/17/2012 - Fix delimiter
I X="AMB",(Y="PU") S ABMR("N4",40)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6) ;ABM*2.6*9 NOHEAT IHS/SD/AML 1/17/2012 - Fix delimiter
I X="AMB",(Y="DO") D
.S ABMR("F")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
.S ABMR("IEN")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
.;start old code abm*2.6*8 HEAT 45242
.;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,5)
.;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,6)
.;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,4)
.;end old code start new code HEAT45242
.I ABMR("F")["AUTNINS" S ABMR("N4",40)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,5)
.I ABMR("F")["AUPNPAT" S ABMR("N4",40)=$P($G(^DPT(ABMR("IEN"),.11)),U,6)
.I ABMR("F")["AUTTLOC" S ABMR("N4",40)=$P($G(^DIC(4,ABMR("IEN"),1)),U,4)
.I ABMR("F")["AUTTVNDR" S ABMR("N4",40)=$P($G(^AUTTVNDR(ABMR("IEN"),13)),U,4) ;abm*2.6*9 NOHEAT IHS/SD/AML 1/17/2012
.;end new code HEAT45242
;S:(+ABMR("N4",40)'=0) ABMR("N4",40)=$$FMT^ABMERUTL($TR(ABMR("N4",40)," -"),"9N") ;abm*2.6*9 NOHEAT IHS/SD/AML 12/23/2011
S ABMR("N4",40)=$TR(ABMR("N4",40)," -") ;abm*2.6*9 NOHEAT - IHS/SD/AML 12/23/2011 - Pt address only needs to be 5 characters
Q
50 ;N404 - Country Code
S ABMR("N4",50)=""
Q
60 ;N405 - Location Qualifier
S ABMR("N4",60)=""
Q
70 ;N406 - Location Identifier
S ABMR("N4",70)=""
Q
80 ;N407 - Country Subdivision Code
S ABMR("N4",80)=""
Q
ABME5N4 ; IHS/ASDST/DMJ - 837 N4 Segment
+1 ;;2.6;IHS Third Party Billing System;**6,8,9**;NOV 12, 2009;Build 379
+2 ;City/State/Zip
+3 ;
EP(X,Y) ;EP - START HERE
+1 ;x=file
+2 ;y=internal entry number
+3 KILL ABMREC("N4"),ABMR("N4")
+4 IF X=3
SET X=9000003.1
+5 SET ABME("RTYPE")="N4"
+6 DO LOOP
+7 KILL ABME
+8 QUIT
LOOP ;LOOP HERE
+1 FOR I=10:10:80
Begin DoDot:1
+2 DO @I
+3 IF $DATA(^ABMEXLM("AA",+$GET(ABMP("INS")),+$GET(ABMP("EXP")),ABME("RTYPE"),I))
DO @(^(I))
+4 IF $GET(ABMREC("N4"))'=""
SET ABMREC("N4")=ABMREC("N4")_"*"
+5 SET ABMREC("N4")=$GET(ABMREC("N4"))_ABMR("N4",I)
End DoDot:1
+6 QUIT
10 ;segment
+1 SET ABMR("N4",10)="N4"
+2 QUIT
20 ;N401 - City Name
+1 IF X=2
SET ABMR("N4",20)=$PIECE($GET(^DPT(Y,.11)),"^",4)
+2 IF X=4
SET ABMR("N4",20)=$PIECE($GET(^DIC(4,Y,1)),"^",3)
+3 IF X=9000003.1
SET ABMR("N4",20)=$PIECE($GET(^AUPN3PPH(Y,0)),"^",11)
+4 IF X=9999999.06
SET ABMR("N4",20)=$PIECE($GET(^AUTTLOC(Y,0)),"^",13)
+5 IF X=9999999.18
SET ABMR("N4",20)=$PIECE($GET(^AUTNINS(Y,1)),"^",3)
+6 IF X=9002274.35
SET ABMR("N4",20)=$PIECE($GET(^AUTTVNDR($PIECE($GET(^ABMRLABS(Y,0)),U),13)),U,2)
+7 IF X=200
SET ABMR("N4",20)=$PIECE($GET(^VA(200,Y,.11)),U,4)
+8 IF X="AMB"
IF (Y="PU")
SET ABMR("N4",20)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,4)
+9 IF X="AMB"
IF (Y="DO")
Begin DoDot:1
+10 SET ABMR("F")=$PIECE($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
+11 SET ABMR("IEN")=$PIECE($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
+12 ;start old code abm*2.6*8 HEAT45242
+13 ;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,3)
+14 ;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,4)
+15 ;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,3)
+16 ;end old code start new code HEAT45242
+17 ;I ABMR("F")["AUTNINS" S ABMR("N4",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,3)
+18 IF ABMR("F")["AUPNPAT"
SET ABMR("N4",20)=$PIECE($GET(^DPT(ABMR("IEN"),.11)),U,4)
+19 IF ABMR("F")["AUTTLOC"
SET ABMR("N4",20)=$PIECE($GET(^DIC(4,ABMR("IEN"),1)),U,3)
+20 IF ABMR("F")["AUTTVNDR"
SET ABMR("N4",20)=$PIECE($GET(^AUTTVNDR(ABMR("IEN"),13)),U,2)
+21 ;end new code HEAT45242
End DoDot:1
+22 QUIT
30 ;N402 - State or Province
+1 IF X=2
SET ABMR("N4",30)=$PIECE($GET(^DPT(Y,.11)),"^",5)
+2 IF X=4
SET ABMR("N4",30)=$PIECE($GET(^DIC(4,Y,0)),"^",2)
+3 IF X=9000003.1
SET ABMR("N4",30)=$PIECE($GET(^AUPN3PPH(Y,0)),"^",12)
+4 IF X=9999999.06
SET ABMR("N4",30)=$PIECE($GET(^AUTTLOC(Y,0)),"^",14)
+5 IF X=9999999.18
SET ABMR("N4",30)=$PIECE($GET(^AUTNINS(Y,1)),"^",4)
+6 IF X=9002274.35
SET ABMR("N4",30)=$PIECE($GET(^AUTTVNDR($PIECE($GET(^ABMRLABS(Y,0)),U),13)),U,3)
+7 IF X=200
SET ABMR("N4",30)=$PIECE($GET(^VA(200,Y,.11)),U,5)
+8 IF X="AMB"
IF (Y="PU")
SET ABMR("N4",30)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,5)
+9 IF X="AMB"
IF (Y="DO")
Begin DoDot:1
+10 SET ABMR("F")=$PIECE($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
+11 SET ABMR("IEN")=$PIECE($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
+12 ;start old code abm*2.6*8 HEAT45242
+13 ;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,4)
+14 ;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,5)
+15 ;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),0)),U,2)
+16 ;end old code start new code HEAT45242
+17 ;I ABMR("F")["AUTNINS" S ABMR("N4",30)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,4)
+18 IF ABMR("F")["AUPNPAT"
SET ABMR("N4",30)=$PIECE($GET(^DPT(ABMR("IEN"),.11)),U,5)
+19 IF ABMR("F")["AUTTLOC"
SET ABMR("N4",30)=$PIECE($GET(^DIC(4,ABMR("IEN"),0)),U,2)
+20 IF ABMR("F")["AUTTVNDR"
SET ABMR("N4",30)=$PIECE($GET(^AUTTVNDR(ABMR("IEN"),13)),U,3)
+21 ;end new codes HEAT45242
End DoDot:1
+22 SET ABMR("N4",30)=$PIECE($GET(^DIC(5,+ABMR("N4",30),0)),"^",2)
+23 QUIT
40 ;N403 - Postal Code
+1 IF X=2
SET ABMR("N4",40)=$PIECE($GET(^DPT(Y,.11)),"^",6)
+2 IF X=4
SET ABMR("N4",40)=$PIECE($GET(^DIC(4,Y,1)),"^",4)
+3 IF X=9000003.1
SET ABMR("N4",40)=$PIECE($GET(^AUPN3PPH(Y,0)),"^",13)
+4 IF X=9999999.06
SET ABMR("N4",40)=$PIECE($GET(^AUTTLOC(Y,0)),"^",15)
+5 IF X=9999999.18
SET ABMR("N4",40)=$PIECE($GET(^AUTNINS(Y,1)),"^",5)
+6 IF X=9002274.35
SET ABMR("N4",40)=$PIECE($GET(^AUTTVNDR($PIECE($GET(^ABMRLABS(Y,0)),U),13)),U,4)
+7 IF X=200
SET ABMR("N4",40)=$PIECE($GET(^VA(200,Y,.11)),U,6)
+8 ;I X="AMB",(Y="PU") S ABMR("N4",40)=$P($G(^ABMDBILL(DUZ(2),Y,12)),U,6) ;abm*2.6*9 NOHEAT IHS/SD/AML 1/17/2012 - Fix delimiter
+9 ;ABM*2.6*9 NOHEAT IHS/SD/AML 1/17/2012 - Fix delimiter
IF X="AMB"
IF (Y="PU")
SET ABMR("N4",40)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6)
+10 IF X="AMB"
IF (Y="DO")
Begin DoDot:1
+11 SET ABMR("F")=$PIECE($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
+12 SET ABMR("IEN")=$PIECE($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
+13 ;start old code abm*2.6*8 HEAT 45242
+14 ;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,5)
+15 ;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,6)
+16 ;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,4)
+17 ;end old code start new code HEAT45242
+18 IF ABMR("F")["AUTNINS"
SET ABMR("N4",40)=$PIECE($GET(^AUTNINS(ABMR("IEN"),0)),U,5)
+19 IF ABMR("F")["AUPNPAT"
SET ABMR("N4",40)=$PIECE($GET(^DPT(ABMR("IEN"),.11)),U,6)
+20 IF ABMR("F")["AUTTLOC"
SET ABMR("N4",40)=$PIECE($GET(^DIC(4,ABMR("IEN"),1)),U,4)
+21 ;abm*2.6*9 NOHEAT IHS/SD/AML 1/17/2012
IF ABMR("F")["AUTTVNDR"
SET ABMR("N4",40)=$PIECE($GET(^AUTTVNDR(ABMR("IEN"),13)),U,4)
+22 ;end new code HEAT45242
End DoDot:1
+23 ;S:(+ABMR("N4",40)'=0) ABMR("N4",40)=$$FMT^ABMERUTL($TR(ABMR("N4",40)," -"),"9N") ;abm*2.6*9 NOHEAT IHS/SD/AML 12/23/2011
+24 ;abm*2.6*9 NOHEAT - IHS/SD/AML 12/23/2011 - Pt address only needs to be 5 characters
SET ABMR("N4",40)=$TRANSLATE(ABMR("N4",40)," -")
+25 QUIT
50 ;N404 - Country Code
+1 SET ABMR("N4",50)=""
+2 QUIT
60 ;N405 - Location Qualifier
+1 SET ABMR("N4",60)=""
+2 QUIT
70 ;N406 - Location Identifier
+1 SET ABMR("N4",70)=""
+2 QUIT
80 ;N407 - Country Subdivision Code
+1 SET ABMR("N4",80)=""
+2 QUIT
