Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABME5N4

ABME5N4.m

Go to the documentation of this file.
  1. ABME5N4 ; IHS/ASDST/DMJ - 837 N4 Segment
  1. ;;2.6;IHS Third Party Billing System;**6,8,9**;NOV 12, 2009;Build 379
  1. ;City/State/Zip
  1. ;
  1. EP(X,Y) ;EP - START HERE
  1. ;x=file
  1. ;y=internal entry number
  1. K ABMREC("N4"),ABMR("N4")
  1. S:X=3 X=9000003.1
  1. S ABME("RTYPE")="N4"
  1. D LOOP
  1. K ABME
  1. Q
  1. LOOP ;LOOP HERE
  1. F I=10:10:80 D
  1. .D @I
  1. .I $D(^ABMEXLM("AA",+$G(ABMP("INS")),+$G(ABMP("EXP")),ABME("RTYPE"),I)) D @(^(I))
  1. .I $G(ABMREC("N4"))'="" S ABMREC("N4")=ABMREC("N4")_"*"
  1. .S ABMREC("N4")=$G(ABMREC("N4"))_ABMR("N4",I)
  1. Q
  1. 10 ;segment
  1. S ABMR("N4",10)="N4"
  1. Q
  1. 20 ;N401 - City Name
  1. I X=2 S ABMR("N4",20)=$P($G(^DPT(Y,.11)),"^",4)
  1. I X=4 S ABMR("N4",20)=$P($G(^DIC(4,Y,1)),"^",3)
  1. I X=9000003.1 S ABMR("N4",20)=$P($G(^AUPN3PPH(Y,0)),"^",11)
  1. I X=9999999.06 S ABMR("N4",20)=$P($G(^AUTTLOC(Y,0)),"^",13)
  1. I X=9999999.18 S ABMR("N4",20)=$P($G(^AUTNINS(Y,1)),"^",3)
  1. I X=9002274.35 S ABMR("N4",20)=$P($G(^AUTTVNDR($P($G(^ABMRLABS(Y,0)),U),13)),U,2)
  1. I X=200 S ABMR("N4",20)=$P($G(^VA(200,Y,.11)),U,4)
  1. I X="AMB",(Y="PU") S ABMR("N4",20)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,4)
  1. I X="AMB",(Y="DO") D
  1. .S ABMR("F")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
  1. .S ABMR("IEN")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
  1. .;start old code abm*2.6*8 HEAT45242
  1. .;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,3)
  1. .;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,4)
  1. .;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,3)
  1. .;end old code start new code HEAT45242
  1. .;I ABMR("F")["AUTNINS" S ABMR("N4",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,3)
  1. .I ABMR("F")["AUPNPAT" S ABMR("N4",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,4)
  1. .I ABMR("F")["AUTTLOC" S ABMR("N4",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,3)
  1. .I ABMR("F")["AUTTVNDR" S ABMR("N4",20)=$P($G(^AUTTVNDR(ABMR("IEN"),13)),U,2)
  1. .;end new code HEAT45242
  1. Q
  1. 30 ;N402 - State or Province
  1. I X=2 S ABMR("N4",30)=$P($G(^DPT(Y,.11)),"^",5)
  1. I X=4 S ABMR("N4",30)=$P($G(^DIC(4,Y,0)),"^",2)
  1. I X=9000003.1 S ABMR("N4",30)=$P($G(^AUPN3PPH(Y,0)),"^",12)
  1. I X=9999999.06 S ABMR("N4",30)=$P($G(^AUTTLOC(Y,0)),"^",14)
  1. I X=9999999.18 S ABMR("N4",30)=$P($G(^AUTNINS(Y,1)),"^",4)
  1. I X=9002274.35 S ABMR("N4",30)=$P($G(^AUTTVNDR($P($G(^ABMRLABS(Y,0)),U),13)),U,3)
  1. I X=200 S ABMR("N4",30)=$P($G(^VA(200,Y,.11)),U,5)
  1. I X="AMB",(Y="PU") S ABMR("N4",30)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,5)
  1. I X="AMB",(Y="DO") D
  1. .S ABMR("F")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
  1. .S ABMR("IEN")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
  1. .;start old code abm*2.6*8 HEAT45242
  1. .;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,4)
  1. .;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,5)
  1. .;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),0)),U,2)
  1. .;end old code start new code HEAT45242
  1. .;I ABMR("F")["AUTNINS" S ABMR("N4",30)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,4)
  1. .I ABMR("F")["AUPNPAT" S ABMR("N4",30)=$P($G(^DPT(ABMR("IEN"),.11)),U,5)
  1. .I ABMR("F")["AUTTLOC" S ABMR("N4",30)=$P($G(^DIC(4,ABMR("IEN"),0)),U,2)
  1. .I ABMR("F")["AUTTVNDR" S ABMR("N4",30)=$P($G(^AUTTVNDR(ABMR("IEN"),13)),U,3)
  1. .;end new codes HEAT45242
  1. S ABMR("N4",30)=$P($G(^DIC(5,+ABMR("N4",30),0)),"^",2)
  1. Q
  1. 40 ;N403 - Postal Code
  1. I X=2 S ABMR("N4",40)=$P($G(^DPT(Y,.11)),"^",6)
  1. I X=4 S ABMR("N4",40)=$P($G(^DIC(4,Y,1)),"^",4)
  1. I X=9000003.1 S ABMR("N4",40)=$P($G(^AUPN3PPH(Y,0)),"^",13)
  1. I X=9999999.06 S ABMR("N4",40)=$P($G(^AUTTLOC(Y,0)),"^",15)
  1. I X=9999999.18 S ABMR("N4",40)=$P($G(^AUTNINS(Y,1)),"^",5)
  1. I X=9002274.35 S ABMR("N4",40)=$P($G(^AUTTVNDR($P($G(^ABMRLABS(Y,0)),U),13)),U,4)
  1. I X=200 S ABMR("N4",40)=$P($G(^VA(200,Y,.11)),U,6)
  1. ;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
  1. 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
  1. I X="AMB",(Y="DO") D
  1. .S ABMR("F")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";",2)
  1. .S ABMR("IEN")=$P($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,7),";")
  1. .;start old code abm*2.6*8 HEAT 45242
  1. .;I ABMR("F")["AUTNINS" S ABMR("N3",20)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,5)
  1. .;I ABMR("F")["AUPNPAT" S ABMR("N3",20)=$P($G(^DPT(ABMR("IEN"),.11)),U,6)
  1. .;I ABMR("F")["AUTTLOC" S ABMR("N3",20)=$P($G(^DIC(4,ABMR("IEN"),1)),U,4)
  1. .;end old code start new code HEAT45242
  1. .I ABMR("F")["AUTNINS" S ABMR("N4",40)=$P($G(^AUTNINS(ABMR("IEN"),0)),U,5)
  1. .I ABMR("F")["AUPNPAT" S ABMR("N4",40)=$P($G(^DPT(ABMR("IEN"),.11)),U,6)
  1. .I ABMR("F")["AUTTLOC" S ABMR("N4",40)=$P($G(^DIC(4,ABMR("IEN"),1)),U,4)
  1. .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
  1. .;end new code HEAT45242
  1. ;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
  1. 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
  1. Q
  1. 50 ;N404 - Country Code
  1. S ABMR("N4",50)=""
  1. Q
  1. 60 ;N405 - Location Qualifier
  1. S ABMR("N4",60)=""
  1. Q
  1. 70 ;N406 - Location Identifier
  1. S ABMR("N4",70)=""
  1. Q
  1. 80 ;N407 - Country Subdivision Code
  1. S ABMR("N4",80)=""
  1. Q