VAFCQRY3 ;ALB/CMC,CKN,KUM - CONT TO BLD PID 2.4 SEGMENT ; 5/4/18 4:45pm
;;5.3;Registration;**575,707,754,944,941**;Aug 13, 1993;Build 73
;Per VHA Directive 2004-038, this routine should not be modified.
;
; *941* #858271 - Sending Residential Address Fields
;
CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP,SSN,VAFCMN) ; continue to bld pid segment
ADDR ;had to split routine
N LVL1,LNGTH1
S LVL1=0
S LNGTH1=0
I $D(SARY(11))!(SEQ="ALL") S APID(12)="" D
.I $D(^DPT(DFN,0)) D
..;address info
..N COUNTY K HL7STRG
..S HL7STRG=$$GET1^DIQ(2,DFN_",",.111) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
..S $P(APID(12),COMP)=HL7STRG I $P(APID(12),COMP)="" S $P(APID(12),COMP)=HL("Q") K HL7STRG
..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.112) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
..S $P(APID(12),COMP,2)=HL7STRG I $P(APID(12),COMP,2)="" S $P(APID(12),COMP,2)=HL("Q")
..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.113) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
..S $P(APID(12),COMP,8)=HL7STRG I $P(APID(12),COMP,8)="" S $P(APID(12),COMP,8)=HL("Q")
..K HL7STRG
..; **707 changes to include foreign address
..N CNTRY S CNTRY=$$GET1^DIQ(2,DFN_",",.1173) ;RETURN EXTERNAL VALUE from country code file #779.004 field .01
..I CNTRY="US" S CNTRY="USA"
..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")
..I CNTRY=""!(CNTRY="USA") D
...;have USA address
...S STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I") S $P(APID(12),COMP,4)=$$GET1^DIQ(5,+STATEIEN_",",1)
...I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q")
...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")
...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;country
..I CNTRY'="",(CNTRY'="USA") D
...;Check for foreign address fields
...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
...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
...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;COUNTRY
...; ***707 end of code
..S $P(APID(12),COMP,7)="P"
BADADDR ..;BAD ADDRESS INDICATOR (if present overwrite the "P" ermanent type with the Bad Address type
..I $D(^DPT(DFN,.11)) N BADADR S BADADR=$P(^DPT(DFN,.11),"^",16) I BADADR'="" S $P(APID(12),COMP,7)="VAB"_BADADR
..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
..S $P(APID(12),COMP,9)=COUNTY ;county code
..;place of birth information
..S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG D
...N X,POBPROV,POBCONT
...I $G(CITY)'="" S $P(X,COMP,3)=CITY
...I $G(CITY)="" S $P(X,COMP,3)=HL("Q")
...; Story 513045 (elz) use pob provence if it's there vs state
...S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I"),STATE=$$GET1^DIQ(5,+STATEIEN_",",1),POBPROV=$$GET1^DIQ(2,DFN_",",.0932,"E") D
....I $L(POBPROV) S HL7STRG=POBPROV D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(X,COMP,4)=HL7STRG
....I $G(STATE)'="",'$L(POBPROV) S $P(X,COMP,4)=STATE
....I $G(STATE)="",'$L(POBPROV) S $P(X,COMP,4)=HL("Q")
...; Story 513045 (elz) include pob country
...S POBCONT=$$GET1^DIQ(2,DFN_",",.0931) D
....I POBCONT="US" S POBCONT="USA"
....I POBCONT'="" S $P(X,COMP,6)=POBCONT
....I POBCONT="" S $P(X,COMP,6)=HL("Q")
... S $P(X,COMP,7)="N",APID(12)=$G(APID(12))_REP_X
CONF .;CONFIDENTIAL ADDRESS
.I $D(^DPT(DFN,.141)) N CNFADD S CNFADD=$$GET1^DIQ(2,DFN_",",.14105) D
..N LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,CNFEND,CNFSTRT,SUBCOMP,CNTY,CITY
..S SUBCOMP=$E(HL("ECH"),4)
..S LINE1=$$GET1^DIQ(2,DFN_",",.1411) S HL7STRG=LINE1 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE1=HL7STRG
..S LINE2=$$GET1^DIQ(2,DFN_",",.1412) S HL7STRG=LINE2 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE2=HL7STRG
..S LINE3=$$GET1^DIQ(2,DFN_",",.1413) S HL7STRG=LINE3 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE3=HL7STRG
..S CNFSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1417,"I")),CNFEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1418,"I"))
..S CITY=$$GET1^DIQ(2,DFN_",",.1414) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
..S CNTRY=$$GET1^DIQ(2,DFN_",",.14116)
..;if foriegn address
..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)
..E S STATE=$$GET1^DIQ(2,DFN_",",.14114),ZIP=$$GET1^DIQ(2,DFN_",",.14115) ;if USA address or null assume USA address
..S LVL=0,LNGTH=$L(APID(12))
..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
...S NXT=""
...S $P(NXT,COMP)=$S(LINE1'="":LINE1,1:HL("Q"))
...S $P(NXT,COMP,2)=$S(LINE2'="":LINE2,1:HL("Q"))
...S $P(NXT,COMP,8)=$S(LINE3'="":LINE3,1:HL("Q"))
...S $P(NXT,COMP,3)=$S(CITY'="":CITY,1:HL("Q"))
...S $P(NXT,COMP,4)=$S($G(STATE)'="":STATE,1:HL("Q"))
...S $P(NXT,COMP,5)=$S(ZIP'="":ZIP,1:HL("Q"))
...S $P(NXT,COMP,6)=$S(CNTRY'="":CNTRY,1:HL("Q"))
...S $P(NXT,COMP,7)=$S(CNFTYPA=1:"VACAE",CNFTYPA=2:"VACAA",CNFTYPA=3:"VACAC",CNFTYPA=4:"VACAM",CNFTYPA=5:"VACAO",1:HL("Q"))
...S $P(NXT,COMP,9)=$S($G(CNTY)'="":CNTY,1:HL("Q"))
...S $P(NXT,COMP,12)=CNFSTRT_SUBCOMP_CNFEND
...S NXT=REP_NXT
...I LVL=0 D
....I $L(APID(12)_NXT)'>244 S APID(12)=APID(12)_NXT Q
....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))
...I LVL>0 D
....I $L($G(APID(12,LVL))_NXT)'>245 S APID(12,LVL)=$G(APID(12,LVL))_NXT Q
....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
..S LVL1=LVL
..S LNGTH1=LNGTH
RESI .;KUM - 941 - TRANSMIT RESIDENTIAL ADDRESS
.;jam; patch 941 - get current option and include RES Address in PID if not ambulatory care transmit
.N XQOPT
.D OP^XQCHK
.I $D(^DPT(DFN,.115)),$P(XQOPT,"^",1)'["SCDX AMBCAR" D
..N RESADD,LVL,LNGTH,RESDTA
..S RESDTA=0
..N LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,NXT1,RESEND,RESSTRT,SUBCOMP,CNTY,CITY
..S SUBCOMP=$E(HL("ECH"),4)
..S LINE1=$$GET1^DIQ(2,DFN_",",.1151) S HL7STRG=LINE1 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE1=HL7STRG
..S LINE2=$$GET1^DIQ(2,DFN_",",.1152) S HL7STRG=LINE2 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE2=HL7STRG
..S LINE3=$$GET1^DIQ(2,DFN_",",.1153) S HL7STRG=LINE3 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE3=HL7STRG
..;S RESSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1161,"I")),RESEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1162,"I"))
..S CITY=$$GET1^DIQ(2,DFN_",",.1154) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
..S CNTRY=$$GET1^DIQ(2,DFN_",",.11573)
..;if foriegn address
..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)
..E S STATE=$$GET1^DIQ(2,DFN_",",.11571),ZIP=$$GET1^DIQ(2,DFN_",",.11572) ;if USA address or null assume USA address
..I '$G(LNGTH1) S LNGTH1=0
..S LNGTH=LNGTH1
..S LVL=LVL1
..S NXT=""
..I ($G(LINE1)'="")!($G(LINE2)'="")!($G(LINE3)'="")!($G(CITY)'="")!($G(STATE)'="")!($G(ZIP)'="")!($G(CNTRY)'="")!($G(CNTY)'="") S RESDTA=1
..S $P(NXT,COMP)=$S(LINE1'="":LINE1,1:HL("Q"))
..S $P(NXT,COMP,2)=$S(LINE2'="":LINE2,1:HL("Q"))
..S $P(NXT,COMP,8)=$S(LINE3'="":LINE3,1:HL("Q"))
..S $P(NXT,COMP,3)=$S(CITY'="":CITY,1:HL("Q"))
..S $P(NXT,COMP,4)=$S($G(STATE)'="":STATE,1:HL("Q"))
..S $P(NXT,COMP,5)=$S(ZIP'="":ZIP,1:HL("Q"))
..S $P(NXT,COMP,6)=$S(CNTRY'="":CNTRY,1:HL("Q"))
..S $P(NXT,COMP,7)="R"
..S $P(NXT,COMP,9)=$S($G(CNTY)'="":CNTY,1:HL("Q"))
..;S $P(NXT,COMP,10)=HL("Q")
..;S $P(NXT,COMP,12)=RESSTRT_SUBCOMP_RESEND
..S NXT=REP_NXT
..I RESDTA D
...I LVL=0 D
....I $L(APID(12)_NXT)'>244 S APID(12)=APID(12)_NXT Q
....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))
...I LVL>0 D
....I $L($G(APID(12,LVL))_NXT)'>245 S APID(12,LVL)=$G(APID(12,LVL))_NXT Q
....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
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
PHONE I $D(SARY(13))!($D(SARY(14)))!(SEQ="ALL") D
.;**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
.N PHONEN,HNUM,WNUM,EMAIL,CELL,PAGER,CONFNUM ;**754
.S PHONEN=$G(^DPT(DFN,.13))
.; **707 change to ensure that null doesn't end up for any of these fields cmc 12/7/06
.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"
.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"
.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"
.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"
.S EMAIL=$P(PHONEN,"^",3) I EMAIL'="" S HL7STRG=EMAIL D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S EMAIL=COMP_"NET"_COMP_"INTERNET"_COMP_HL7STRG
.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
.I HNUM'="" S APID(14)=HNUM
.I WNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_WNUM
.I WNUM'="",APID(14)="" S APID(14)=WNUM
.I CELL'="",APID(14)'="" S APID(14)=APID(14)_REP_CELL
.I CELL'="",APID(14)="" S APID(14)=CELL
.I PAGER'="",APID(14)'="" S APID(14)=APID(14)_REP_PAGER
.I PAGER'="",APID(14)="" S APID(14)=PAGER
.I EMAIL'="",APID(14)'="" S APID(14)=APID(14)_REP_EMAIL
.I EMAIL'="",APID(14)="" S APID(14)=EMAIL
.I CONFNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_CONFNUM ;**754
.I CONFNUM'="",APID(14)="" S APID(14)=CONFNUM ;**754
.I APID(14)="" S APID(14)=HL("Q")
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")
;**707 keep work# in PID-14 for backwards compatability but should use PID-13 to get work#
I $D(SARY(19))!(SEQ="ALL") S APID(20)=SSN ;ssn passed in PID-3
I $D(SARY(23))!(SEQ="ALL") D
.S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
.S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
.I CITY'=""&(STATE'="") S APID(24)=CITY_" "_STATE ;place of birth (not used) use PID-11 with an 'N' instead
.I CITY=""&(STATE="") S APID(24)=HL("Q")
D CONT^VAFCQRY4(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERROR,REP,COMP)
;**707 had to break routine
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCQRY3 11758 printed Apr 09, 2024@22:02:36 Page 2
VAFCQRY3 ;ALB/CMC,CKN,KUM - CONT TO BLD PID 2.4 SEGMENT ; 5/4/18 4:45pm
+1 ;;5.3;Registration;**575,707,754,944,941**;Aug 13, 1993;Build 73
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; *941* #858271 - Sending Residential Address Fields
+5 ;
CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP,SSN,VAFCMN) ; continue to bld pid segment
ADDR ;had to split routine
+1 NEW LVL1,LNGTH1
+2 SET LVL1=0
+3 SET LNGTH1=0
+4 IF $DATA(SARY(11))!(SEQ="ALL")
SET APID(12)=""
Begin DoDot:1
+5 IF $DATA(^DPT(DFN,0))
Begin DoDot:2
+6 ;address info
+7 NEW COUNTY
KILL HL7STRG
+8 SET HL7STRG=$$GET1^DIQ(2,DFN_",",.111)
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
+9 SET $PIECE(APID(12),COMP)=HL7STRG
IF $PIECE(APID(12),COMP)=""
SET $PIECE(APID(12),COMP)=HL("Q")
KILL HL7STRG
+10 ;**707 add HL7TXT call
KILL HL7STRG
SET HL7STRG=$$GET1^DIQ(2,DFN_",",.112)
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
+11 SET $PIECE(APID(12),COMP,2)=HL7STRG
IF $PIECE(APID(12),COMP,2)=""
SET $PIECE(APID(12),COMP,2)=HL("Q")
+12 ;**707 add HL7TXT call
KILL HL7STRG
SET HL7STRG=$$GET1^DIQ(2,DFN_",",.113)
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
+13 SET $PIECE(APID(12),COMP,8)=HL7STRG
IF $PIECE(APID(12),COMP,8)=""
SET $PIECE(APID(12),COMP,8)=HL("Q")
+14 KILL HL7STRG
+15 ; **707 changes to include foreign address
+16 ;RETURN EXTERNAL VALUE from country code file #779.004 field .01
NEW CNTRY
SET CNTRY=$$GET1^DIQ(2,DFN_",",.1173)
+17 IF CNTRY="US"
SET CNTRY="USA"
+18 SET HL7STRG=$$GET1^DIQ(2,DFN_",",.114)
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET $PIECE(APID(12),COMP,3)=HL7STRG
IF $PIECE(APID(12),COMP,3)=""
SET $PIECE(APID(12),COMP,3)=HL("Q")
+19 IF CNTRY=""!(CNTRY="USA")
Begin DoDot:3
+20 ;have USA address
+21 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I")
SET $PIECE(APID(12),COMP,4)=$$GET1^DIQ(5,+STATEIEN_",",1)
+22 IF $PIECE(APID(12),COMP,4)=""
SET $PIECE(APID(12),COMP,4)=HL("Q")
+23 SET $PIECE(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112)
IF $PIECE(APID(12),COMP,5)=""
SET $PIECE(APID(12),COMP,5)=HL("Q")
+24 ;country
SET $PIECE(APID(12),COMP,6)=CNTRY
IF CNTRY=""
SET $PIECE(APID(12),COMP,6)=HL("Q")
End DoDot:3
+25 IF CNTRY'=""
IF (CNTRY'="USA")
Begin DoDot:3
+26 ;Check for foreign address fields
+27 ;province
SET $PIECE(APID(12),COMP,4)=$PIECE($GET(^DPT(DFN,.11)),"^",8)
IF $PIECE(APID(12),COMP,4)=""
SET $PIECE(APID(12),COMP,4)=HL("Q")
+28 ;postal code
SET $PIECE(APID(12),COMP,5)=$PIECE($GET(^DPT(DFN,.11)),"^",9)
IF $PIECE(APID(12),COMP,5)=""
SET $PIECE(APID(12),COMP,5)=HL("Q")
+29 ;COUNTRY
SET $PIECE(APID(12),COMP,6)=CNTRY
IF CNTRY=""
SET $PIECE(APID(12),COMP,6)=HL("Q")
+30 ; ***707 end of code
End DoDot:3
+31 SET $PIECE(APID(12),COMP,7)="P"
BADADDR ;BAD ADDRESS INDICATOR (if present overwrite the "P" ermanent type with the Bad Address type
+1 IF $DATA(^DPT(DFN,.11))
NEW BADADR
SET BADADR=$PIECE(^DPT(DFN,.11),"^",16)
IF BADADR'=""
SET $PIECE(APID(12),COMP,7)="VAB"_BADADR
+2 ;**648 add COUNTY Code to PID-11, retained in PID-12 also
SET COUNTY=$$GET1^DIQ(2,DFN_",",.117)
IF COUNTY=""
SET COUNTY=HL("Q")
+3 ;county code
SET $PIECE(APID(12),COMP,9)=COUNTY
+4 ;place of birth information
+5 SET CITY=$$GET1^DIQ(2,DFN_",",.092)
SET HL7STRG=CITY
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET CITY=HL7STRG
Begin DoDot:3
+6 NEW X,POBPROV,POBCONT
+7 IF $GET(CITY)'=""
SET $PIECE(X,COMP,3)=CITY
+8 IF $GET(CITY)=""
SET $PIECE(X,COMP,3)=HL("Q")
+9 ; Story 513045 (elz) use pob provence if it's there vs state
+10 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I")
SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
SET POBPROV=$$GET1^DIQ(2,DFN_",",.0932,"E")
Begin DoDot:4
+11 IF $LENGTH(POBPROV)
SET HL7STRG=POBPROV
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET $PIECE(X,COMP,4)=HL7STRG
+12 IF $GET(STATE)'=""
IF '$LENGTH(POBPROV)
SET $PIECE(X,COMP,4)=STATE
+13 IF $GET(STATE)=""
IF '$LENGTH(POBPROV)
SET $PIECE(X,COMP,4)=HL("Q")
End DoDot:4
+14 ; Story 513045 (elz) include pob country
+15 SET POBCONT=$$GET1^DIQ(2,DFN_",",.0931)
Begin DoDot:4
+16 IF POBCONT="US"
SET POBCONT="USA"
+17 IF POBCONT'=""
SET $PIECE(X,COMP,6)=POBCONT
+18 IF POBCONT=""
SET $PIECE(X,COMP,6)=HL("Q")
End DoDot:4
+19 SET $PIECE(X,COMP,7)="N"
SET APID(12)=$GET(APID(12))_REP_X
End DoDot:3
End DoDot:2
CONF ;CONFIDENTIAL ADDRESS
+1 IF $DATA(^DPT(DFN,.141))
NEW CNFADD
SET CNFADD=$$GET1^DIQ(2,DFN_",",.14105)
Begin DoDot:2
+2 NEW LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,CNFEND,CNFSTRT,SUBCOMP,CNTY,CITY
+3 SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+4 SET LINE1=$$GET1^DIQ(2,DFN_",",.1411)
SET HL7STRG=LINE1
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET LINE1=HL7STRG
+5 SET LINE2=$$GET1^DIQ(2,DFN_",",.1412)
SET HL7STRG=LINE2
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET LINE2=HL7STRG
+6 SET LINE3=$$GET1^DIQ(2,DFN_",",.1413)
SET HL7STRG=LINE3
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET LINE3=HL7STRG
+7 SET CNFSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1417,"I"))
SET CNFEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1418,"I"))
+8 SET CITY=$$GET1^DIQ(2,DFN_",",.1414)
SET HL7STRG=CITY
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET CITY=HL7STRG
+9 SET CNTRY=$$GET1^DIQ(2,DFN_",",.14116)
+10 ;if foriegn address
+11 IF CNTRY=""!(CNTRY="USA")!(CNTRY="US")
if CNTRY="US"
SET CNTRY="USA"
SET STATEIEN=$$GET1^DIQ(2,DFN_",",.1415,"I")
SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
SET CNTY=$$GET1^DIQ(2,DFN_",",.14111)
SET ZIP=$$GET1^DIQ(2,DFN_",",.1416)
+12 ;if USA address or null assume USA address
IF '$TEST
SET STATE=$$GET1^DIQ(2,DFN_",",.14114)
SET ZIP=$$GET1^DIQ(2,DFN_",",.14115)
+13 SET LVL=0
SET LNGTH=$LENGTH(APID(12))
+14 IF $DATA(^DPT(DFN,.14,0))
NEW CNFTYP
SET CNFTYP=0
FOR
SET CNFTYP=$ORDER(^DPT(DFN,.14,CNFTYP))
if 'CNFTYP
QUIT
NEW CNFTYPA
SET CNFTYPA=$PIECE(^DPT(DFN,.14,CNFTYP,0),"^",2)
IF CNFTYPA="Y"
SET CNFTYPA=$PIECE(^DPT(DFN,.14,CNFTYP,0),"^")
Begin DoDot:3
+15 SET NXT=""
+16 SET $PIECE(NXT,COMP)=$SELECT(LINE1'="":LINE1,1:HL("Q"))
+17 SET $PIECE(NXT,COMP,2)=$SELECT(LINE2'="":LINE2,1:HL("Q"))
+18 SET $PIECE(NXT,COMP,8)=$SELECT(LINE3'="":LINE3,1:HL("Q"))
+19 SET $PIECE(NXT,COMP,3)=$SELECT(CITY'="":CITY,1:HL("Q"))
+20 SET $PIECE(NXT,COMP,4)=$SELECT($GET(STATE)'="":STATE,1:HL("Q"))
+21 SET $PIECE(NXT,COMP,5)=$SELECT(ZIP'="":ZIP,1:HL("Q"))
+22 SET $PIECE(NXT,COMP,6)=$SELECT(CNTRY'="":CNTRY,1:HL("Q"))
+23 SET $PIECE(NXT,COMP,7)=$SELECT(CNFTYPA=1:"VACAE",CNFTYPA=2:"VACAA",CNFTYPA=3:"VACAC",CNFTYPA=4:"VACAM",CNFTYPA=5:"VACAO",1:HL("Q"))
+24 SET $PIECE(NXT,COMP,9)=$SELECT($GET(CNTY)'="":CNTY,1:HL("Q"))
+25 SET $PIECE(NXT,COMP,12)=CNFSTRT_SUBCOMP_CNFEND
+26 SET NXT=REP_NXT
+27 IF LVL=0
Begin DoDot:4
+28 IF $LENGTH(APID(12)_NXT)'>244
SET APID(12)=APID(12)_NXT
QUIT
+29 IF $LENGTH(APID(12)_NXT)>244
SET LVL=1
SET LNGTH=244-$LENGTH(APID(12))
SET APID(12)=APID(12)_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
End DoDot:4
+30 IF LVL>0
Begin DoDot:4
+31 IF $LENGTH($GET(APID(12,LVL))_NXT)'>245
SET APID(12,LVL)=$GET(APID(12,LVL))_NXT
QUIT
+32 IF $LENGTH($GET(APID(12,LVL))_NXT)>245
SET LNGTH=244-$LENGTH(APID(12,LVL))
SET APID(12,LVL)=APID(12,LVL)_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET LVL=LVL+1
SET APID(12,LVL)=NXT
End DoDot:4
End DoDot:3
+33 SET LVL1=LVL
+34 SET LNGTH1=LNGTH
End DoDot:2
RESI ;KUM - 941 - TRANSMIT RESIDENTIAL ADDRESS
+1 ;jam; patch 941 - get current option and include RES Address in PID if not ambulatory care transmit
+2 NEW XQOPT
+3 DO OP^XQCHK
+4 IF $DATA(^DPT(DFN,.115))
IF $PIECE(XQOPT,"^",1)'["SCDX AMBCAR"
Begin DoDot:2
+5 NEW RESADD,LVL,LNGTH,RESDTA
+6 SET RESDTA=0
+7 NEW LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,NXT1,RESEND,RESSTRT,SUBCOMP,CNTY,CITY
+8 SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+9 SET LINE1=$$GET1^DIQ(2,DFN_",",.1151)
SET HL7STRG=LINE1
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET LINE1=HL7STRG
+10 SET LINE2=$$GET1^DIQ(2,DFN_",",.1152)
SET HL7STRG=LINE2
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET LINE2=HL7STRG
+11 SET LINE3=$$GET1^DIQ(2,DFN_",",.1153)
SET HL7STRG=LINE3
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET LINE3=HL7STRG
+12 ;S RESSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1161,"I")),RESEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1162,"I"))
+13 SET CITY=$$GET1^DIQ(2,DFN_",",.1154)
SET HL7STRG=CITY
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET CITY=HL7STRG
+14 SET CNTRY=$$GET1^DIQ(2,DFN_",",.11573)
+15 ;if foriegn address
+16 IF CNTRY=""!(CNTRY="USA")!(CNTRY="US")
if CNTRY="US"
SET CNTRY="USA"
SET STATEIEN=$$GET1^DIQ(2,DFN_",",.1155,"I")
SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
SET CNTY=$$GET1^DIQ(2,DFN_",",.1157)
SET ZIP=$$GET1^DIQ(2,DFN_",",.1156)
+17 ;if USA address or null assume USA address
IF '$TEST
SET STATE=$$GET1^DIQ(2,DFN_",",.11571)
SET ZIP=$$GET1^DIQ(2,DFN_",",.11572)
+18 IF '$GET(LNGTH1)
SET LNGTH1=0
+19 SET LNGTH=LNGTH1
+20 SET LVL=LVL1
+21 SET NXT=""
+22 IF ($GET(LINE1)'="")!($GET(LINE2)'="")!($GET(LINE3)'="")!($GET(CITY)'="")!($GET(STATE)'="")!($GET(ZIP)'="")!($GET(CNTRY)'="")!($GET(CNTY)'="")
SET RESDTA=1
+23 SET $PIECE(NXT,COMP)=$SELECT(LINE1'="":LINE1,1:HL("Q"))
+24 SET $PIECE(NXT,COMP,2)=$SELECT(LINE2'="":LINE2,1:HL("Q"))
+25 SET $PIECE(NXT,COMP,8)=$SELECT(LINE3'="":LINE3,1:HL("Q"))
+26 SET $PIECE(NXT,COMP,3)=$SELECT(CITY'="":CITY,1:HL("Q"))
+27 SET $PIECE(NXT,COMP,4)=$SELECT($GET(STATE)'="":STATE,1:HL("Q"))
+28 SET $PIECE(NXT,COMP,5)=$SELECT(ZIP'="":ZIP,1:HL("Q"))
+29 SET $PIECE(NXT,COMP,6)=$SELECT(CNTRY'="":CNTRY,1:HL("Q"))
+30 SET $PIECE(NXT,COMP,7)="R"
+31 SET $PIECE(NXT,COMP,9)=$SELECT($GET(CNTY)'="":CNTY,1:HL("Q"))
+32 ;S $P(NXT,COMP,10)=HL("Q")
+33 ;S $P(NXT,COMP,12)=RESSTRT_SUBCOMP_RESEND
+34 SET NXT=REP_NXT
+35 IF RESDTA
Begin DoDot:3
+36 IF LVL=0
Begin DoDot:4
+37 IF $LENGTH(APID(12)_NXT)'>244
SET APID(12)=APID(12)_NXT
QUIT
+38 IF $LENGTH(APID(12)_NXT)>244
SET LVL=1
SET LNGTH=244-$LENGTH(APID(12))
SET APID(12)=APID(12)_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
End DoDot:4
+39 IF LVL>0
Begin DoDot:4
+40 IF $LENGTH($GET(APID(12,LVL))_NXT)'>245
SET APID(12,LVL)=$GET(APID(12,LVL))_NXT
QUIT
+41 IF $LENGTH($GET(APID(12,LVL))_NXT)>245
SET LNGTH=244-$LENGTH(APID(12,LVL))
SET APID(12,LVL)=APID(12,LVL)_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET LVL=LVL+1
SET APID(12,LVL)=NXT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;county code **648 backwards compatibility only
IF $DATA(SARY(12))!(SEQ="ALL")
SET APID(13)=$$GET1^DIQ(2,DFN_",",.117)
IF APID(13)=""
SET APID(13)=HL("Q")
PHONE IF $DATA(SARY(13))!($DATA(SARY(14)))!(SEQ="ALL")
Begin DoDot:1
+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
+2 ;**754
NEW PHONEN,HNUM,WNUM,EMAIL,CELL,PAGER,CONFNUM
+3 SET PHONEN=$GET(^DPT(DFN,.13))
+4 ; **707 change to ensure that null doesn't end up for any of these fields cmc 12/7/06
+5 SET HNUM=$PIECE(PHONEN,"^")
IF HNUM'=""
SET HNUM=$$HLPHONE^HLFNC(HNUM)
IF HNUM'=""
SET HL7STRG=HNUM
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET HNUM=HL7STRG_COMP_"PRN"_COMP_"PH"
+6 SET WNUM=$PIECE(PHONEN,"^",2)
IF WNUM'=""
SET WNUM=$$HLPHONE^HLFNC(WNUM)
IF WNUM'=""
SET HL7STRG=WNUM
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET WNUM=HL7STRG_COMP_"WPN"_COMP_"PH"
+7 SET CELL=$PIECE(PHONEN,"^",4)
IF CELL'=""
SET CELL=$$HLPHONE^HLFNC(CELL)
IF CELL'=""
SET HL7STRG=CELL
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET CELL=HL7STRG_COMP_"ORN"_COMP_"CP"
+8 SET PAGER=$PIECE(PHONEN,"^",5)
IF PAGER'=""
SET PAGER=$$HLPHONE^HLFNC(PAGER)
IF PAGER'=""
SET HL7STRG=PAGER
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET PAGER=HL7STRG_COMP_"BPN"_COMP_"BP"
+9 SET EMAIL=$PIECE(PHONEN,"^",3)
IF EMAIL'=""
SET HL7STRG=EMAIL
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET EMAIL=COMP_"NET"_COMP_"INTERNET"_COMP_HL7STRG
+10 ;**574
SET CONFNUM=$PIECE(PHONEN,"^",15)
IF CONFNUM'=""
SET CONFNUM=$$HLPHONE^HLFNC(CONFNUM)
IF CONFNUM'=""
SET HL7STRG=CONFNUM
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET CONFNUM=HL7STRG_COMP_"VACPN"_COMP_"PH"
+11 IF HNUM'=""
SET APID(14)=HNUM
+12 IF WNUM'=""
IF APID(14)'=""
SET APID(14)=APID(14)_REP_WNUM
+13 IF WNUM'=""
IF APID(14)=""
SET APID(14)=WNUM
+14 IF CELL'=""
IF APID(14)'=""
SET APID(14)=APID(14)_REP_CELL
+15 IF CELL'=""
IF APID(14)=""
SET APID(14)=CELL
+16 IF PAGER'=""
IF APID(14)'=""
SET APID(14)=APID(14)_REP_PAGER
+17 IF PAGER'=""
IF APID(14)=""
SET APID(14)=PAGER
+18 IF EMAIL'=""
IF APID(14)'=""
SET APID(14)=APID(14)_REP_EMAIL
+19 IF EMAIL'=""
IF APID(14)=""
SET APID(14)=EMAIL
+20 ;**754
IF CONFNUM'=""
IF APID(14)'=""
SET APID(14)=APID(14)_REP_CONFNUM
+21 ;**754
IF CONFNUM'=""
IF APID(14)=""
SET APID(14)=CONFNUM
+22 IF APID(14)=""
SET APID(14)=HL("Q")
End DoDot:1
+23 IF $DATA(SARY(14))!(SEQ="ALL")
NEW WNUM
SET WNUM=$PIECE($GET(^DPT(DFN,.13)),"^",2)
SET WNUM=$$HLPHONE^HLFNC(WNUM)
SET HL7STRG=WNUM
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET APID(15)=HL7STRG
IF APID(15)=""
SET APID(15)=HL("Q")
+24 ;**707 keep work# in PID-14 for backwards compatability but should use PID-13 to get work#
+25 ;ssn passed in PID-3
IF $DATA(SARY(19))!(SEQ="ALL")
SET APID(20)=SSN
+26 IF $DATA(SARY(23))!(SEQ="ALL")
Begin DoDot:1
+27 SET CITY=$$GET1^DIQ(2,DFN_",",.092)
SET HL7STRG=CITY
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET CITY=HL7STRG
+28 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I")
SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
Begin DoDot:2
End DoDot:2
+29 ;place of birth (not used) use PID-11 with an 'N' instead
IF CITY'=""&(STATE'="")
SET APID(24)=CITY_" "_STATE
+30 IF CITY=""&(STATE="")
SET APID(24)=HL("Q")
End DoDot:1
+31 DO CONT^VAFCQRY4(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERROR,REP,COMP)
+32 ;**707 had to break routine
+33 QUIT
