- VAFCQRY3 ;BIR/CMC,CKN-CONT TO BLD PID 2.4 SEGMENT ; 8/21/09 4:45pm
- ;;5.3;PIMS;**575,707,1015,1016**;JUN 30, 2012;Build 20
- ;
- CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP,SSN,VAFCMN) ; continue to bld pid segment
- ADDR ;had to split routine
- 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
- ...I $G(CITY)'="" S $P(X,COMP,3)=CITY
- ...I $G(CITY)="" S $P(X,COMP,3)=HL("Q")
- ...S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
- ....I $G(STATE)'="" S $P(X,COMP,4)=STATE
- ....I $G(STATE)="" S $P(X,COMP,4)=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
- 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
- VAFCQRY3 ;BIR/CMC,CKN-CONT TO BLD PID 2.4 SEGMENT ; 8/21/09 4:45pm
- +1 ;;5.3;PIMS;**575,707,1015,1016**;JUN 30, 2012;Build 20
- +2 ;
- CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP,SSN,VAFCMN) ; continue to bld pid segment
- ADDR ;had to split routine
- +1 IF $DATA(SARY(11))!(SEQ="ALL")
- SET APID(12)=""
- Begin DoDot:1
- +2 IF $DATA(^DPT(DFN,0))
- Begin DoDot:2
- +3 ;address info
- +4 NEW COUNTY
- KILL HL7STRG
- +5 SET HL7STRG=$$GET1^DIQ(2,DFN_",",.111)
- DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
- +6 SET $PIECE(APID(12),COMP)=HL7STRG
- IF $PIECE(APID(12),COMP)=""
- SET $PIECE(APID(12),COMP)=HL("Q")
- KILL HL7STRG
- +7 ;**707 add HL7TXT call
- KILL HL7STRG
- SET HL7STRG=$$GET1^DIQ(2,DFN_",",.112)
- DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
- +8 SET $PIECE(APID(12),COMP,2)=HL7STRG
- IF $PIECE(APID(12),COMP,2)=""
- SET $PIECE(APID(12),COMP,2)=HL("Q")
- +9 ;**707 add HL7TXT call
- KILL HL7STRG
- SET HL7STRG=$$GET1^DIQ(2,DFN_",",.113)
- DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
- +10 SET $PIECE(APID(12),COMP,8)=HL7STRG
- IF $PIECE(APID(12),COMP,8)=""
- SET $PIECE(APID(12),COMP,8)=HL("Q")
- +11 KILL HL7STRG
- +12 ; **707 changes to include foreign address
- +13 ;RETURN EXTERNAL VALUE from country code file #779.004 field .01
- NEW CNTRY
- SET CNTRY=$$GET1^DIQ(2,DFN_",",.1173)
- +14 IF CNTRY="US"
- SET CNTRY="USA"
- +15 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")
- +16 IF CNTRY=""!(CNTRY="USA")
- Begin DoDot:3
- +17 ;have USA address
- +18 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I")
- SET $PIECE(APID(12),COMP,4)=$$GET1^DIQ(5,+STATEIEN_",",1)
- +19 IF $PIECE(APID(12),COMP,4)=""
- SET $PIECE(APID(12),COMP,4)=HL("Q")
- +20 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")
- +21 ;country
- SET $PIECE(APID(12),COMP,6)=CNTRY
- IF CNTRY=""
- SET $PIECE(APID(12),COMP,6)=HL("Q")
- End DoDot:3
- +22 IF CNTRY'=""
- IF (CNTRY'="USA")
- Begin DoDot:3
- +23 ;Check for foreign address fields
- +24 ;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")
- +25 ;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")
- +26 ;COUNTRY
- SET $PIECE(APID(12),COMP,6)=CNTRY
- IF CNTRY=""
- SET $PIECE(APID(12),COMP,6)=HL("Q")
- +27 ; ***707 end of code
- End DoDot:3
- +28 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
- +7 IF $GET(CITY)'=""
- SET $PIECE(X,COMP,3)=CITY
- +8 IF $GET(CITY)=""
- SET $PIECE(X,COMP,3)=HL("Q")
- +9 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I")
- SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
- Begin DoDot:4
- +10 IF $GET(STATE)'=""
- SET $PIECE(X,COMP,4)=STATE
- +11 IF $GET(STATE)=""
- SET $PIECE(X,COMP,4)=HL("Q")
- End DoDot:4
- +12 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
- End DoDot:2
- End DoDot:1
- +33 ;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
