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

VAFCQRY3.m

Go to the documentation of this file. 
  1. VAFCQRY3 ;ALB/CMC,CKN,KUM - CONT TO BLD PID 2.4 SEGMENT ;7/4/18 4:45PM
  1.  ;;5.3;Registration;**575,707,754,944,941,1121**;Aug 13, 1993;Build 14
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; *941* #858271 - Sending Residential Address Fields 
  1.  ;
  1. CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP,SSN,VAFCMN) ; continue to bld pid segment
  1. ADDR ;had to split routine
  1.  N LVL1,LNGTH1
  1.  S LVL1=0
  1.  S LNGTH1=0
  1.  I $D(SARY(11))!(SEQ="ALL") S APID(12)="" D
  1.  .I $D(^DPT(DFN,0)) D
  1.  ..;address info
  1.  ..N COUNTY K HL7STRG
  1.  ..S HL7STRG=$$GET1^DIQ(2,DFN_",",.111) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
  1.  ..S $P(APID(12),COMP)=HL7STRG I $P(APID(12),COMP)="" S $P(APID(12),COMP)=HL("Q") K HL7STRG
  1.  ..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.112) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
  1.  ..S $P(APID(12),COMP,2)=HL7STRG I $P(APID(12),COMP,2)="" S $P(APID(12),COMP,2)=HL("Q")
  1.  ..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.113) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
  1.  ..S $P(APID(12),COMP,8)=HL7STRG I $P(APID(12),COMP,8)="" S $P(APID(12),COMP,8)=HL("Q")
  1.  ..K HL7STRG
  1.  ..; **707 changes to include foreign address
  1.  ..N CNTRY S CNTRY=$$GET1^DIQ(2,DFN_",",.1173) ;RETURN EXTERNAL VALUE from country code file #779.004 field .01
  1.  ..I CNTRY="US" S CNTRY="USA"
  1.  ..S HL7STRG=$$GET1^DIQ(2,DFN_",",.114) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(APID(12),COMP,3)=HL7STRG  I $P(APID(12),COMP,3)="" S $P(APID(12),COMP,3)=HL("Q")
  1.  ..I CNTRY=""!(CNTRY="USA") D
  1.  ...;have USA address
  1.  ...S STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I") S $P(APID(12),COMP,4)=$$GET1^DIQ(5,+STATEIEN_",",1)
  1.  ...I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q")
  1.  ...S $P(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q")
  1.  ...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;country
  1.  ..I CNTRY'="",(CNTRY'="USA") D
  1.  ...;Check for foreign address fields
  1.  ...S $P(APID(12),COMP,4)=$P($G(^DPT(DFN,.11)),"^",8) I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q") ;province
  1.  ...S $P(APID(12),COMP,5)=$P($G(^DPT(DFN,.11)),"^",9) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q") ;postal code
  1.  ...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;COUNTRY
  1.  ...; ***707 end of code
  1.  ..S $P(APID(12),COMP,7)="P"
  1. BADADDR ..;BAD ADDRESS INDICATOR (if present overwrite the "P" ermanent type with the Bad Address type
  1.  ..I $D(^DPT(DFN,.11)) N BADADR S BADADR=$P(^DPT(DFN,.11),"^",16) I BADADR'="" S $P(APID(12),COMP,7)="VAB"_BADADR
  1.  ..S COUNTY=$$GET1^DIQ(2,DFN_",",.117) I COUNTY="" S COUNTY=HL("Q") ;**648 add COUNTY Code to PID-11, retained in PID-12 also
  1.  ..S $P(APID(12),COMP,9)=COUNTY ;county code
  1.  ..;place of birth information
  1.  ..S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG D
  1.  ...N X,POBPROV,POBCONT
  1.  ...I $G(CITY)'="" S $P(X,COMP,3)=CITY
  1.  ...I $G(CITY)="" S $P(X,COMP,3)=HL("Q")
  1.  ...; Story 513045 (elz) use pob provence if it's there vs state
  1.  ...S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I"),STATE=$$GET1^DIQ(5,+STATEIEN_",",1),POBPROV=$$GET1^DIQ(2,DFN_",",.0932,"E") D
  1.  ....I $L(POBPROV) S HL7STRG=POBPROV D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(X,COMP,4)=HL7STRG
  1.  ....I $G(STATE)'="",'$L(POBPROV) S $P(X,COMP,4)=STATE
  1.  ....I $G(STATE)="",'$L(POBPROV) S $P(X,COMP,4)=HL("Q")
  1.  ...; Story 513045 (elz) include pob country
  1.  ...S POBCONT=$$GET1^DIQ(2,DFN_",",.0931) D
  1.  ....I POBCONT="US" S POBCONT="USA"
  1.  ....I POBCONT'="" S $P(X,COMP,6)=POBCONT
  1.  ....I POBCONT="" S $P(X,COMP,6)=HL("Q")
  1.  ... S $P(X,COMP,7)="N",APID(12)=$G(APID(12))_REP_X
  1. CONF .;CONFIDENTIAL ADDRESS
  1.  .I $D(^DPT(DFN,.141)) N CNFADD S CNFADD=$$GET1^DIQ(2,DFN_",",.14105) D
  1.  ..N LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,CNFEND,CNFSTRT,SUBCOMP,CNTY,CITY
  1.  ..S SUBCOMP=$E(HL("ECH"),4)
  1.  ..S LINE1=$$GET1^DIQ(2,DFN_",",.1411) S HL7STRG=LINE1 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE1=HL7STRG
  1.  ..S LINE2=$$GET1^DIQ(2,DFN_",",.1412) S HL7STRG=LINE2 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE2=HL7STRG
  1.  ..S LINE3=$$GET1^DIQ(2,DFN_",",.1413) S HL7STRG=LINE3 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE3=HL7STRG
  1.  ..S CNFSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1417,"I")),CNFEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1418,"I"))
  1.  ..S CITY=$$GET1^DIQ(2,DFN_",",.1414) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
  1.  ..S CNTRY=$$GET1^DIQ(2,DFN_",",.14116)
  1.  ..;if foriegn address
  1.  ..I CNTRY=""!(CNTRY="USA")!(CNTRY="US") S:CNTRY="US" CNTRY="USA" S STATEIEN=$$GET1^DIQ(2,DFN_",",.1415,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1),CNTY=$$GET1^DIQ(2,DFN_",",.14111),ZIP=$$GET1^DIQ(2,DFN_",",.1416)
  1.  ..E  S STATE=$$GET1^DIQ(2,DFN_",",.14114),ZIP=$$GET1^DIQ(2,DFN_",",.14115)  ;if USA address or null assume USA address
  1.  ..S LVL=0,LNGTH=$L(APID(12))
  1.  ..I $D(^DPT(DFN,.14,0)) N CNFTYP S CNFTYP=0 F  S CNFTYP=$O(^DPT(DFN,.14,CNFTYP)) Q:'CNFTYP  N CNFTYPA S CNFTYPA=$P(^DPT(DFN,.14,CNFTYP,0),"^",2) I CNFTYPA="Y" S CNFTYPA=$P(^DPT(DFN,.14,CNFTYP,0),"^") D
  1.  ...S NXT=""
  1.  ...S $P(NXT,COMP)=$S(LINE1'="":LINE1,1:HL("Q"))
  1.  ...S $P(NXT,COMP,2)=$S(LINE2'="":LINE2,1:HL("Q"))
  1.  ...S $P(NXT,COMP,8)=$S(LINE3'="":LINE3,1:HL("Q"))
  1.  ...S $P(NXT,COMP,3)=$S(CITY'="":CITY,1:HL("Q"))
  1.  ...S $P(NXT,COMP,4)=$S($G(STATE)'="":STATE,1:HL("Q"))
  1.  ...S $P(NXT,COMP,5)=$S(ZIP'="":ZIP,1:HL("Q"))
  1.  ...S $P(NXT,COMP,6)=$S(CNTRY'="":CNTRY,1:HL("Q"))
  1.  ...S $P(NXT,COMP,7)=$S(CNFTYPA=1:"VACAE",CNFTYPA=2:"VACAA",CNFTYPA=3:"VACAC",CNFTYPA=4:"VACAM",CNFTYPA=5:"VACAO",1:HL("Q"))
  1.  ...S $P(NXT,COMP,9)=$S($G(CNTY)'="":CNTY,1:HL("Q"))
  1.  ...S $P(NXT,COMP,12)=CNFSTRT_SUBCOMP_CNFEND
  1.  ...S NXT=REP_NXT
  1.  ...I LVL=0 D
  1.  ....I $L(APID(12)_NXT)'>244 S APID(12)=APID(12)_NXT Q
  1.  ....I $L(APID(12)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(12)),APID(12)=APID(12)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT))
  1.  ...I LVL>0 D
  1.  ....I $L($G(APID(12,LVL))_NXT)'>245 S APID(12,LVL)=$G(APID(12,LVL))_NXT Q
  1.  ....I $L($G(APID(12,LVL))_NXT)>245 S LNGTH=244-$L(APID(12,LVL)),APID(12,LVL)=APID(12,LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(12,LVL)=NXT
  1.  ..S LVL1=LVL
  1.  ..S LNGTH1=LNGTH
  1. RESI .;KUM - 941 - TRANSMIT RESIDENTIAL ADDRESS
  1.  .;jam; patch 941 - get current option and include RES Address in PID if not ambulatory care transmit
  1.  .N XQOPT
  1.  .D OP^XQCHK
  1.  .I $D(^DPT(DFN,.115)),$P(XQOPT,"^",1)'["SCDX AMBCAR" D 
  1.  ..N RESADD,LVL,LNGTH,RESDTA
  1.  ..S RESDTA=0
  1.  ..N LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,NXT1,RESEND,RESSTRT,SUBCOMP,CNTY,CITY
  1.  ..S SUBCOMP=$E(HL("ECH"),4)
  1.  ..S LINE1=$$GET1^DIQ(2,DFN_",",.1151) S HL7STRG=LINE1 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE1=HL7STRG
  1.  ..S LINE2=$$GET1^DIQ(2,DFN_",",.1152) S HL7STRG=LINE2 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE2=HL7STRG
  1.  ..S LINE3=$$GET1^DIQ(2,DFN_",",.1153) S HL7STRG=LINE3 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE3=HL7STRG
  1.  ..;S RESSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1161,"I")),RESEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1162,"I"))
  1.  ..S CITY=$$GET1^DIQ(2,DFN_",",.1154) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
  1.  ..S CNTRY=$$GET1^DIQ(2,DFN_",",.11573)
  1.  ..;if foriegn address
  1.  ..I CNTRY=""!(CNTRY="USA")!(CNTRY="US") S:CNTRY="US" CNTRY="USA" S STATEIEN=$$GET1^DIQ(2,DFN_",",.1155,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1),CNTY=$$GET1^DIQ(2,DFN_",",.1157),ZIP=$$GET1^DIQ(2,DFN_",",.1156)
  1.  ..E  S STATE=$$GET1^DIQ(2,DFN_",",.11571),ZIP=$$GET1^DIQ(2,DFN_",",.11572)  ;if USA address or null assume USA address
  1.  ..I '$G(LNGTH1) S LNGTH1=0
  1.  ..S LNGTH=LNGTH1
  1.  ..S LVL=LVL1
  1.  ..S NXT=""
  1.  ..I ($G(LINE1)'="")!($G(LINE2)'="")!($G(LINE3)'="")!($G(CITY)'="")!($G(STATE)'="")!($G(ZIP)'="")!($G(CNTRY)'="")!($G(CNTY)'="") S RESDTA=1
  1.  ..S $P(NXT,COMP)=$S(LINE1'="":LINE1,1:HL("Q"))
  1.  ..S $P(NXT,COMP,2)=$S(LINE2'="":LINE2,1:HL("Q"))
  1.  ..S $P(NXT,COMP,8)=$S(LINE3'="":LINE3,1:HL("Q"))
  1.  ..S $P(NXT,COMP,3)=$S(CITY'="":CITY,1:HL("Q"))
  1.  ..S $P(NXT,COMP,4)=$S($G(STATE)'="":STATE,1:HL("Q"))
  1.  ..S $P(NXT,COMP,5)=$S(ZIP'="":ZIP,1:HL("Q"))
  1.  ..S $P(NXT,COMP,6)=$S(CNTRY'="":CNTRY,1:HL("Q"))
  1.  ..S $P(NXT,COMP,7)="R"
  1.  ..S $P(NXT,COMP,9)=$S($G(CNTY)'="":CNTY,1:HL("Q"))
  1.  ..;S $P(NXT,COMP,10)=HL("Q")
  1.  ..;S $P(NXT,COMP,12)=RESSTRT_SUBCOMP_RESEND
  1.  ..S NXT=REP_NXT
  1.  ..I RESDTA D
  1.  ...I LVL=0 D
  1.  ....I $L(APID(12)_NXT)'>244 S APID(12)=APID(12)_NXT Q
  1.  ....I $L(APID(12)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(12)),APID(12)=APID(12)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT))
  1.  ...I LVL>0 D
  1.  ....I $L($G(APID(12,LVL))_NXT)'>245 S APID(12,LVL)=$G(APID(12,LVL))_NXT Q
  1.  ....I $L($G(APID(12,LVL))_NXT)>245 S LNGTH=244-$L(APID(12,LVL)),APID(12,LVL)=APID(12,LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(12,LVL)=NXT
  1.  I $D(SARY(12))!(SEQ="ALL") S APID(13)=$$GET1^DIQ(2,DFN_",",.117) I APID(13)="" S APID(13)=HL("Q")  ;county code **648 backwards compatibility only
  1. PHONE I $D(SARY(13))!($D(SARY(14)))!(SEQ="ALL") D
  1.  .;**707 change PID-13 to have home and work phones, cell, pager and e-mail address with the components ; **754 add confidential phone number to PID-13
  1.  .N PHONEN,HNUM,WNUM,EMAIL,CELL,PAGER,CONFNUM,DGEXT,DGEXT2,DGCNTRY,DGAREA,DGPH ;**754
  1.  .S PHONEN=$G(^DPT(DFN,.13))
  1.  .; **707 change to ensure that null doesn't end up for any of these fields cmc 12/7/06
  1.  .; **DG*5.3*1121 accommodate country code, area code, phone number, extension in pieces 5 to 8 in each phone number component
  1.  .;S HNUM=$P(PHONEN,"^") I HNUM'="" S HNUM=$$HLPHONE^HLFNC(HNUM) I HNUM'="" S HL7STRG=HNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S HNUM=HL7STRG_COMP_"PRN"_COMP_"PH"
  1.  .S HNUM=$P(PHONEN,"^") I HNUM'="" D 
  1.  ..;S HL7STRG=HNUM
  1.  ..S HL7STRG=$TR(HNUM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ..D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S DGEXT="" S DGEXT2="" S DGCNTRY="" S DGAREA="" S DGPH=""
  1.  ..S DGEXT=$P(HL7STRG,"X",2)
  1.  ..S DGEXT=$$CONVPHAN(DGEXT)
  1.  ..S DGEXT2=$$GET1^DIQ(2,DFN_",",.13211)
  1.  ..S DGEXT2=$$CONVPHAN(DGEXT2)
  1.  ..I DGEXT2'="" S DGEXT=DGEXT2
  1.  ..S DGEXT=$E(DGEXT,1,6)
  1.  ..S DGCNTRY=$$GET1^DIQ(2,DFN_",",.1327,"I")
  1.  ..S DGCNTRY=$$CONVPHAN(DGCNTRY)
  1.  ..I $G(DGCNTRY)="" S DGCNTRY=1
  1.  ..S DGPH=$P(HL7STRG,"X",1)
  1.  ..S DGPH=$$CONVPHAN(DGPH)
  1.  ..S DGAREA=$E(DGPH,1,3)
  1.  ..S DGPH=$E(DGPH,4,10)
  1.  ..I DGPH="" S DGEXT="" S DGCNTRY="" S DGAREA=""
  1.  ..S HNUM=HL7STRG_COMP_"PRN"_COMP_"PH"_COMP_COMP_DGCNTRY_COMP_DGAREA_COMP_DGPH_COMP_DGEXT
  1.  .;S WNUM=$P(PHONEN,"^",2) I WNUM'="" S WNUM=$$HLPHONE^HLFNC(WNUM) I WNUM'="" S HL7STRG=WNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S WNUM=HL7STRG_COMP_"WPN"_COMP_"PH"
  1.  .S WNUM=$P(PHONEN,"^",2) I WNUM'="" D
  1.  ..;S HL7STRG=WNUM
  1.  ..S HL7STRG=$TR(WNUM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ..D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S DGEXT="" S DGEXT2="" S DGCNTRY="" S DGAREA="" S DGPH=""
  1.  ..S DGEXT=$P(HL7STRG,"X",2)
  1.  ..S DGEXT=$$CONVPHAN(DGEXT)
  1.  ..S DGEXT2=$$GET1^DIQ(2,DFN_",",.13213)
  1.  ..S DGEXT2=$$CONVPHAN(DGEXT2)
  1.  ..I DGEXT2'="" S DGEXT=DGEXT2
  1.  ..S DGEXT=$E(DGEXT,1,6)
  1.  ..S DGCNTRY=$$GET1^DIQ(2,DFN_",",.1329,"I")
  1.  ..S DGCNTRY=$$CONVPHAN(DGCNTRY)
  1.  ..I $G(DGCNTRY)="" S DGCNTRY=1
  1.  ..S DGPH=$P(HL7STRG,"X",1)
  1.  ..S DGPH=$$CONVPHAN(DGPH)
  1.  ..S DGAREA=$E(DGPH,1,3)
  1.  ..S DGPH=$E(DGPH,4,10)
  1.  ..I DGPH="" S DGEXT="" S DGCNTRY="" S DGAREA=""
  1.  ..S WNUM=HL7STRG_COMP_"WPN"_COMP_"PH"_COMP_COMP_DGCNTRY_COMP_DGAREA_COMP_DGPH_COMP_DGEXT
  1.  .;S CELL=$P(PHONEN,"^",4) I CELL'="" S CELL=$$HLPHONE^HLFNC(CELL) I CELL'="" S HL7STRG=CELL D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CELL=HL7STRG_COMP_"ORN"_COMP_"CP"
  1.  .S CELL=$P(PHONEN,"^",4) I CELL'="" D
  1.  ..;S HL7STRG=CELL
  1.  ..S HL7STRG=$TR(CELL,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ..D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S DGEXT="" S DGEXT2="" S DGCNTRY="" S DGAREA="" S DGPH=""
  1.  ..S DGEXT=$P(HL7STRG,"X",2)
  1.  ..S DGEXT=$$CONVPHAN(DGEXT)
  1.  ..S DGEXT2=$$GET1^DIQ(2,DFN_",",.13212)
  1.  ..S DGEXT2=$$CONVPHAN(DGEXT2)
  1.  ..I DGEXT2'="" S DGEXT=DGEXT2
  1.  ..S DGEXT=$E(DGEXT,1,6)
  1.  ..S DGCNTRY=$$GET1^DIQ(2,DFN_",",.1328,"I")
  1.  ..S DGCNTRY=$$CONVPHAN(DGCNTRY)
  1.  ..I $G(DGCNTRY)="" S DGCNTRY=1
  1.  ..S DGPH=$P(HL7STRG,"X",1)
  1.  ..S DGPH=$$CONVPHAN(DGPH)
  1.  ..S DGAREA=$E(DGPH,1,3)
  1.  ..S DGPH=$E(DGPH,4,10)
  1.  ..I DGPH="" S DGEXT="" S DGCNTRY="" S DGAREA=""
  1.  ..S CELL=HL7STRG_COMP_"ORN"_COMP_"CP"_COMP_COMP_DGCNTRY_COMP_DGAREA_COMP_DGPH_COMP_DGEXT
  1.  .S PAGER=$P(PHONEN,"^",5) I PAGER'="" S PAGER=$$HLPHONE^HLFNC(PAGER) I PAGER'="" S HL7STRG=PAGER D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S PAGER=HL7STRG_COMP_"BPN"_COMP_"BP"
  1.  .S EMAIL=$P(PHONEN,"^",3) I EMAIL'="" S HL7STRG=EMAIL D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S EMAIL=COMP_"NET"_COMP_"INTERNET"_COMP_HL7STRG
  1.  .;S CONFNUM=$P(PHONEN,"^",15) I CONFNUM'="" S CONFNUM=$$HLPHONE^HLFNC(CONFNUM) I CONFNUM'="" S HL7STRG=CONFNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CONFNUM=HL7STRG_COMP_"VACPN"_COMP_"PH" ;**574
  1.  .S CONFNUM=$P(PHONEN,"^",15) I CONFNUM'="" D
  1.  ..;S HL7STRG=CONFNUM
  1.  ..S HL7STRG=$TR(CONFNUM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ..D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S DGEXT="" S DGEXT2="" S DGCNTRY="" S DGAREA="" S DGPH=""
  1.  ..S DGEXT=$P(HL7STRG,"X",2)
  1.  ..S DGEXT=$$CONVPHAN(DGEXT)
  1.  ..S DGEXT2=$$GET1^DIQ(2,DFN_",",.13214)
  1.  ..S DGEXT2=$$CONVPHAN(DGEXT2)
  1.  ..I DGEXT2'="" S DGEXT=DGEXT2
  1.  ..S DGEXT=$E(DGEXT,1,6)
  1.  ..S DGCNTRY=$$GET1^DIQ(2,DFN_",",.13201,"I")
  1.  ..S DGCNTRY=$$CONVPHAN(DGCNTRY)
  1.  ..I $G(DGCNTRY)="" S DGCNTRY=1
  1.  ..S DGPH=$P(HL7STRG,"X",1)
  1.  ..S DGPH=$$CONVPHAN(DGPH)
  1.  ..S DGAREA=$E(DGPH,1,3)
  1.  ..S DGPH=$E(DGPH,4,10)
  1.  ..I DGPH="" S DGEXT="" S DGCNTRY="" S DGAREA=""
  1.  ..S CONFNUM=HL7STRG_COMP_"VACPN"_COMP_"PH"_COMP_COMP_DGCNTRY_COMP_DGAREA_COMP_DGPH_COMP_DGEXT
  1.  .; DG*5.3*1121 - End of changes
  1.  .I HNUM'="" S APID(14)=HNUM
  1.  .I WNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_WNUM
  1.  .I WNUM'="",APID(14)="" S APID(14)=WNUM
  1.  .I CELL'="",APID(14)'="" S APID(14)=APID(14)_REP_CELL
  1.  .I CELL'="",APID(14)="" S APID(14)=CELL
  1.  .I PAGER'="",APID(14)'="" S APID(14)=APID(14)_REP_PAGER
  1.  .I PAGER'="",APID(14)="" S APID(14)=PAGER
  1.  .I EMAIL'="",APID(14)'="" S APID(14)=APID(14)_REP_EMAIL
  1.  .I EMAIL'="",APID(14)="" S APID(14)=EMAIL
  1.  .I CONFNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_CONFNUM ;**754
  1.  .I CONFNUM'="",APID(14)="" S APID(14)=CONFNUM ;**754
  1.  .I APID(14)="" S APID(14)=HL("Q")
  1.  I $D(SARY(14))!(SEQ="ALL") N WNUM S WNUM=$P($G(^DPT(DFN,.13)),"^",2) S WNUM=$$HLPHONE^HLFNC(WNUM) S HL7STRG=WNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S APID(15)=HL7STRG I APID(15)="" S APID(15)=HL("Q")
  1.  ;**707 keep work# in PID-14 for backwards compatability but should use PID-13 to get work#
  1.  I $D(SARY(19))!(SEQ="ALL") S APID(20)=SSN  ;ssn passed in PID-3
  1.  I $D(SARY(23))!(SEQ="ALL") D
  1.  .S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
  1.  .S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
  1.  .I CITY'=""&(STATE'="") S APID(24)=CITY_" "_STATE  ;place of birth (not used) use PID-11 with an 'N' instead
  1.  .I CITY=""&(STATE="") S APID(24)=HL("Q")
  1.  D CONT^VAFCQRY4(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERROR,REP,COMP)
  1.  ;**707 had to break routine
  1.  Q
  1.  ;
  1. CONVPHAN(PH) ;Convert Alpha Phone number to Numeric
  1.  S PH=$TR(PH," )(/#\-~`!@#$%^&*'|<>?,.+=_abcdefghijklmnopqrstvuwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ","")
  1.  Q PH
  1.  ;