- AGMPIPID ;IHS/SD/TPF - Patient Registration MPI HLO Interface
- ;;7.2;IHS PATIENT REGISTRATION;**1,5**;JAN 07, 2011;Build 20
- ;BLDPID^VAFCQRY WAS USED AS A TEMPLATE
- Q
- BLDPID(DFN,CNT,SEQ,PID,HL,ERR) ;build PID from File #2
- N VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,PDOD,HIST,HISTDT,VAFCHMN,LVL,LVL1,NXT,LNGTH,NXTC,COMP,REP,SUBCOMP,LVL2,X,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,X,STATEIEN
- S HLECH=HL("ECH"),HLFS=HL("FS"),HLQ=HL("Q")
- S COMP=$E(HL("ECH"),1)
- S SUBCOMP=$E(HL("ECH"),4)
- S REP=$E(HL("ECH"),2)
- ;get Patient File MPI node
- S VAFCMN=$$MPINODE(DFN)
- I +VAFCMN<0 S VAFCMN=""
- S VAFCZN=^DPT(DFN,0)
- S SSN=$P(^DPT(DFN,0),"^",9)
- S SITE=$$SITE^VASITE
- S APID(2)=CNT
- ;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) AND DFN (PI)
- S APID(4)=""
- ;National Identifier (ICN)
- ;I VAFCMN'="" I +VAFCMN>0 S APID(4)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" D
- ;. ;Assumption that if this is a local ICN at this point send the message with an expiration date of today, so that it will be treated as a deprecated ID and stored on the MPI as such
- ;. I $E($P(VAFCMN,"^"),1,3)=$P($$SITE^VASITE,"^",3) S APID(4)=APID(4)_COMP_COMP_$$HLDATE^HLFNC(DT)
- S APID(4)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" ;IHS/SD/TPF 7/22/2009 AG*7.1*MPI NEEDED FOR SUN MPI
- I $E($P(VAFCMN,"^"),1,3)=$P($$SITE^VASITE,"^",3) S APID(4)=APID(4)_COMP_COMP_$$HLDATE^HLFNC(DT) ;IHS/SD/TPF 7/22/2009 AG*7.1*MPI NEEED FOR SUN MPI
- ;IHS/SD/TPF 7/22/2009 AG*7.2*MPI NEEDED TO COMPLETE PID PROPERLY FOR SUN MPI
- S:'$D(SSN) SSN="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
- I $G(DFN)'="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_DFN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" D
- .;CLAIM#
- .;IHS WILL NOT HAVE AN ICN HISTORY
- ;patient name (last^first^middle^suffix^prefix^^"L" for legal)
- S APID(6)=$$HLNAME^XLFNAME($P(VAFCZN,"^"),"",$E(HL("ECH"),1)) I $P(APID(6),$E(HL("ECH"),1),7)'="L" S $P(APID(6),$E(HL("ECH"),1),7)="L"
- ;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name)
- S APID(7)=HL("Q")
- I $D(^DPT(DFN,.24)) S VAFCMMN=$P(^DPT(DFN,.24),"^",3) D
- . S APID(7)=$$HLNAME^XLFNAME(VAFCMMN,"",$E(HL("ECH"),1)) I APID(7)="" S APID(7)=HL("Q")
- . I $P(APID(7),$E(HL("ECH"),1),7)'="M" S $P(APID(7),$E(HL("ECH"),1),7)="M"
- S APID(8)=$$HLDATE^HLFNC($P(VAFCZN,"^",3)) ;date/time of birth
- S APID(9)=$P(VAFCZN,"^",2) ;sex
- ;place of birth city and state
- ADDR S APID(12)="" D
- . I $D(^DPT(DFN,0)) D
- .. ;address info
- .. S $P(APID(12),COMP)=$$GET1^DIQ(2,DFN_",",.111) I $P(APID(12),COMP)="" S $P(APID(12),COMP)=HL("Q")
- .. N LINE2 S LINE2=$$GET1^DIQ(2,DFN_",",.112) N LINE3 S LINE3=$$GET1^DIQ(2,DFN_",",.113)
- .. S $P(APID(12),COMP,2)=LINE2 I $P(APID(12),COMP,2)="" S $P(APID(12),COMP,2)=HL("Q")
- .. S $P(APID(12),COMP,8)=LINE3 I $P(APID(12),COMP,8)="" S $P(APID(12),COMP,8)=HL("Q")
- .. S $P(APID(12),COMP,3)=$$GET1^DIQ(2,DFN_",",.114) I $P(APID(12),COMP,3)="" S $P(APID(12),COMP,3)=HL("Q")
- .. S STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) S $P(APID(12),COMP,4)=$G(STATE) 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)=$$GET1^DIQ(2,DFN_",",.116) ; AG*7.2*4/CR 7689 - Use ZIP if ZIP+4 is blank
- .. I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q")
- .. S $P(APID(12),COMP,7)="P"
- .. ;place of birth information
- .. S CITY=$$GET1^DIQ(2,DFN_",",.092) D
- ... 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"
- ... S APID(12)=$G(APID(12))_REP_X
- S APID(13)=$$GET1^DIQ(2,DFN_",",.117) I APID(13)="" S APID(13)=HL("Q") ;county code
- N PHONEN,HNUM,WNUM S PHONEN=$G(^DPT(DFN,.13)) S HNUM=$P(PHONEN,"^",1),WNUM=$P(PHONEN,"^",2)
- S APID(14)=$$HLPHONE^HLFNC(HNUM)
- S APID(15)=$$HLPHONE^HLFNC(WNUM)
- S:APID(14)'="" APID(14)=APID(14)_"~PRN~PH"
- S:APID(15)'="" APID(15)=APID(15)_"~WPH~PH"
- D DEM^VADPT
- ;S APID(17)="" I +VADM(10)>0 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),APID(17)=$S(X="N":"S",X="U":"",X="":HLQ,1:X) ;marital status (DHCP N=HL7 S, U="") ;**477
- S APID(17)="" I +VADM(10)>0 S APID(17)=+VADM(10)
- S APID(18)="" I +VADM(9)>0 S APID(18)=$P($G(^DIC(13,+VADM(9),0)),"^",4) I APID(18)="" S APID(18)=29 ;religious pref (if blank send 29 (UNKNOWN))
- S APID(30)="" I $D(^DPT(DFN,.35)) S PDOD=$P(^DPT(DFN,.35),"^") ;date of death
- I $G(PDOD) S APID(30)=$$CONDT^AGMPHLU(PDOD)
- N X F X=6,7,8,9,13,14,15,17,18,30 I APID(X)="" S APID(X)=HL("Q")
- ;list of fields used for backwards compatibility with HDR
- S APID(3)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2) ;Patient ID
- S APID(20)=SSN ;ssn passed in PID-3
- S APID(24)=CITY_" "_STATE ;place of birth (not used) use PID-11 with an 'N' instead
- ;list of fields not currently used or supported (# is 1 more than seq)
- S APID(5)="" ;Alternate Patient Identifier
- S APID(10)="" ;patient alias
- S APID(11)="" I +$G(VADM(8)) S APID(11)=$P($G(^DIC(10,+VADM(8),0)),U,3) ;race
- S APID(16)="" ;primary language
- S APID(19)="" ;patient account #
- S APID(21)="" ;drivers lic #
- S APID(22)="" ;mother's id
- S APID(23)="" I +$G(VADM(11,1)) S APID(23)=$P($G(^DIC(10.2,+VADM(11,1),0)),U,2) ;ethnic group
- S APID(26)="" S APID(26)=$P($G(^AUPNPAT(DFN,18)),U) ;OTHER PHONE
- S APID(26)=$$HLPHONE^HLFNC(APID(26))
- S:APID(26)'="" APID(26)=APID(26)_"~ORN~CP"
- S APID(27)="" S APID(27)=$P($G(^AUPNPAT(DFN,18)),U,2) ;CURRENT EMAIL ADDRESS
- S:APID(27)'="" APID(27)=APID(27)_"~NET~INTERNET"
- S APID(28)=$$GET1^DIQ(2,DFN_",",1901,"I")
- S APID(29)=""
- S APID(31)=""
- S PID(1)="PID"_HL("FS")
- S LVL=1,X=1 F S X=$O(APID(X)) Q:'X D
- . S PID(LVL)=$G(PID(LVL))
- . S NXT=APID(X) D
- .. I '$O(APID(X,0)) S NXT=NXT_HL("FS")
- .. I $L($G(PID(LVL))_NXT)>245 S LNGTH=245-$L(PID(LVL)),PID(LVL)=PID(LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),LVL=LVL+1
- .. I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
- . S LVL2=0 F S LVL2=$O(APID(X,LVL2)) Q:'LVL2 D
- .. S NXT=APID(X,LVL2) D
- ... I $L($G(PID(LVL))_NXT)>245 S LNGTH=245-$L(PID(LVL)),PID(LVL)=PID(LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),LVL=LVL+1
- ... I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
- ... I '$O(APID(X,LVL2)) S PID(LVL)=PID(LVL)_HL("FS")
- D KVA^VADPT
- Q
- ;
- MPINODE(DFN) ; returns MPI node for given DFN
- ; DFN - patient file ien
- ; returns: -1^error message or MPI node from patient file
- N TMP
- I '$D(DFN) Q "-1^DFN not defined"
- I '$D(^DPT(DFN)) Q "-1^DFN doesn't exist"
- I '$D(^DPT(DFN,"MPI")) Q "-1^No MPI node for DFN "_DFN
- L +^DPT("MPI",DFN):10 ;**45 added lock check for getting ICN data back
- N NODE S NODE=$G(^DPT(DFN,"MPI"))
- I NODE=""!(NODE?."^") S NODE="-1^No MPI data for DFN "_DFN
- L -^DPT("MPI",DFN)
- Q NODE
- AGMPIPID ;IHS/SD/TPF - Patient Registration MPI HLO Interface
- +1 ;;7.2;IHS PATIENT REGISTRATION;**1,5**;JAN 07, 2011;Build 20
- +2 ;BLDPID^VAFCQRY WAS USED AS A TEMPLATE
- +3 QUIT
- BLDPID(DFN,CNT,SEQ,PID,HL,ERR) ;build PID from File #2
- +1 NEW VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,PDOD,HIST,HISTDT,VAFCHMN,LVL,LVL1,NXT,LNGTH,NXTC,COMP,REP,SUBCOMP,LVL2,X,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,X,STATEIEN
- +2 SET HLECH=HL("ECH")
- SET HLFS=HL("FS")
- SET HLQ=HL("Q")
- +3 SET COMP=$EXTRACT(HL("ECH"),1)
- +4 SET SUBCOMP=$EXTRACT(HL("ECH"),4)
- +5 SET REP=$EXTRACT(HL("ECH"),2)
- +6 ;get Patient File MPI node
- +7 SET VAFCMN=$$MPINODE(DFN)
- +8 IF +VAFCMN<0
- SET VAFCMN=""
- +9 SET VAFCZN=^DPT(DFN,0)
- +10 SET SSN=$PIECE(^DPT(DFN,0),"^",9)
- +11 SET SITE=$$SITE^VASITE
- +12 SET APID(2)=CNT
- +13 ;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) AND DFN (PI)
- +14 SET APID(4)=""
- +15 ;National Identifier (ICN)
- +16 ;I VAFCMN'="" I +VAFCMN>0 S APID(4)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" D
- +17 ;. ;Assumption that if this is a local ICN at this point send the message with an expiration date of today, so that it will be treated as a deprecated ID and stored on the MPI as such
- +18 ;. I $E($P(VAFCMN,"^"),1,3)=$P($$SITE^VASITE,"^",3) S APID(4)=APID(4)_COMP_COMP_$$HLDATE^HLFNC(DT)
- +19 ;IHS/SD/TPF 7/22/2009 AG*7.1*MPI NEEDED FOR SUN MPI
- SET APID(4)=$PIECE(VAFCMN,"^")_"V"_$PIECE(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
- +20 ;IHS/SD/TPF 7/22/2009 AG*7.1*MPI NEEED FOR SUN MPI
- IF $EXTRACT($PIECE(VAFCMN,"^"),1,3)=$PIECE($$SITE^VASITE,"^",3)
- SET APID(4)=APID(4)_COMP_COMP_$$HLDATE^HLFNC(DT)
- +21 ;IHS/SD/TPF 7/22/2009 AG*7.2*MPI NEEDED TO COMPLETE PID PROPERLY FOR SUN MPI
- +22 IF '$DATA(SSN)
- SET SSN=""
- SET APID(4)=APID(4)_$SELECT(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
- +23 IF $GET(DFN)'=""
- SET APID(4)=APID(4)_$SELECT(APID(4)'="":REP,1:"")_DFN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
- Begin DoDot:1
- +24 ;CLAIM#
- +25 ;IHS WILL NOT HAVE AN ICN HISTORY
- End DoDot:1
- +26 ;patient name (last^first^middle^suffix^prefix^^"L" for legal)
- +27 SET APID(6)=$$HLNAME^XLFNAME($PIECE(VAFCZN,"^"),"",$EXTRACT(HL("ECH"),1))
- IF $PIECE(APID(6),$EXTRACT(HL("ECH"),1),7)'="L"
- SET $PIECE(APID(6),$EXTRACT(HL("ECH"),1),7)="L"
- +28 ;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name)
- +29 SET APID(7)=HL("Q")
- +30 IF $DATA(^DPT(DFN,.24))
- SET VAFCMMN=$PIECE(^DPT(DFN,.24),"^",3)
- Begin DoDot:1
- +31 SET APID(7)=$$HLNAME^XLFNAME(VAFCMMN,"",$EXTRACT(HL("ECH"),1))
- IF APID(7)=""
- SET APID(7)=HL("Q")
- +32 IF $PIECE(APID(7),$EXTRACT(HL("ECH"),1),7)'="M"
- SET $PIECE(APID(7),$EXTRACT(HL("ECH"),1),7)="M"
- End DoDot:1
- +33 ;date/time of birth
- SET APID(8)=$$HLDATE^HLFNC($PIECE(VAFCZN,"^",3))
- +34 ;sex
- SET APID(9)=$PIECE(VAFCZN,"^",2)
- +35 ;place of birth city and state
- ADDR SET APID(12)=""
- Begin DoDot:1
- +1 IF $DATA(^DPT(DFN,0))
- Begin DoDot:2
- +2 ;address info
- +3 SET $PIECE(APID(12),COMP)=$$GET1^DIQ(2,DFN_",",.111)
- IF $PIECE(APID(12),COMP)=""
- SET $PIECE(APID(12),COMP)=HL("Q")
- +4 NEW LINE2
- SET LINE2=$$GET1^DIQ(2,DFN_",",.112)
- NEW LINE3
- SET LINE3=$$GET1^DIQ(2,DFN_",",.113)
- +5 SET $PIECE(APID(12),COMP,2)=LINE2
- IF $PIECE(APID(12),COMP,2)=""
- SET $PIECE(APID(12),COMP,2)=HL("Q")
- +6 SET $PIECE(APID(12),COMP,8)=LINE3
- IF $PIECE(APID(12),COMP,8)=""
- SET $PIECE(APID(12),COMP,8)=HL("Q")
- +7 SET $PIECE(APID(12),COMP,3)=$$GET1^DIQ(2,DFN_",",.114)
- IF $PIECE(APID(12),COMP,3)=""
- SET $PIECE(APID(12),COMP,3)=HL("Q")
- +8 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I")
- SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
- SET $PIECE(APID(12),COMP,4)=$GET(STATE)
- IF $PIECE(APID(12),COMP,4)=""
- SET $PIECE(APID(12),COMP,4)=HL("Q")
- +9 SET $PIECE(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112)
- +10 ; AG*7.2*4/CR 7689 - Use ZIP if ZIP+4 is blank
- IF $PIECE(APID(12),COMP,5)=""
- SET $PIECE(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.116)
- +11 IF $PIECE(APID(12),COMP,5)=""
- SET $PIECE(APID(12),COMP,5)=HL("Q")
- +12 SET $PIECE(APID(12),COMP,7)="P"
- +13 ;place of birth information
- +14 SET CITY=$$GET1^DIQ(2,DFN_",",.092)
- Begin DoDot:3
- +15 IF $GET(CITY)'=""
- SET $PIECE(X,COMP,3)=CITY
- +16 IF $GET(CITY)=""
- SET $PIECE(X,COMP,3)=HL("Q")
- +17 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I")
- SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
- Begin DoDot:4
- +18 IF $GET(STATE)'=""
- SET $PIECE(X,COMP,4)=STATE
- +19 IF $GET(STATE)=""
- SET $PIECE(X,COMP,4)=HL("Q")
- End DoDot:4
- +20 SET $PIECE(X,COMP,7)="N"
- +21 SET APID(12)=$GET(APID(12))_REP_X
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +22 ;county code
- SET APID(13)=$$GET1^DIQ(2,DFN_",",.117)
- IF APID(13)=""
- SET APID(13)=HL("Q")
- +23 NEW PHONEN,HNUM,WNUM
- SET PHONEN=$GET(^DPT(DFN,.13))
- SET HNUM=$PIECE(PHONEN,"^",1)
- SET WNUM=$PIECE(PHONEN,"^",2)
- +24 SET APID(14)=$$HLPHONE^HLFNC(HNUM)
- +25 SET APID(15)=$$HLPHONE^HLFNC(WNUM)
- +26 IF APID(14)'=""
- SET APID(14)=APID(14)_"~PRN~PH"
- +27 IF APID(15)'=""
- SET APID(15)=APID(15)_"~WPH~PH"
- +28 DO DEM^VADPT
- +29 ;S APID(17)="" I +VADM(10)>0 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),APID(17)=$S(X="N":"S",X="U":"",X="":HLQ,1:X) ;marital status (DHCP N=HL7 S, U="") ;**477
- +30 SET APID(17)=""
- IF +VADM(10)>0
- SET APID(17)=+VADM(10)
- +31 ;religious pref (if blank send 29 (UNKNOWN))
- SET APID(18)=""
- IF +VADM(9)>0
- SET APID(18)=$PIECE($GET(^DIC(13,+VADM(9),0)),"^",4)
- IF APID(18)=""
- SET APID(18)=29
- +32 ;date of death
- SET APID(30)=""
- IF $DATA(^DPT(DFN,.35))
- SET PDOD=$PIECE(^DPT(DFN,.35),"^")
- +33 IF $GET(PDOD)
- SET APID(30)=$$CONDT^AGMPHLU(PDOD)
- +34 NEW X
- FOR X=6,7,8,9,13,14,15,17,18,30
- IF APID(X)=""
- SET APID(X)=HL("Q")
- +35 ;list of fields used for backwards compatibility with HDR
- +36 ;Patient ID
- SET APID(3)=$PIECE(VAFCMN,"^")_"V"_$PIECE(VAFCMN,"^",2)
- +37 ;ssn passed in PID-3
- SET APID(20)=SSN
- +38 ;place of birth (not used) use PID-11 with an 'N' instead
- SET APID(24)=CITY_" "_STATE
- +39 ;list of fields not currently used or supported (# is 1 more than seq)
- +40 ;Alternate Patient Identifier
- SET APID(5)=""
- +41 ;patient alias
- SET APID(10)=""
- +42 ;race
- SET APID(11)=""
- IF +$GET(VADM(8))
- SET APID(11)=$PIECE($GET(^DIC(10,+VADM(8),0)),U,3)
- +43 ;primary language
- SET APID(16)=""
- +44 ;patient account #
- SET APID(19)=""
- +45 ;drivers lic #
- SET APID(21)=""
- +46 ;mother's id
- SET APID(22)=""
- +47 ;ethnic group
- SET APID(23)=""
- IF +$GET(VADM(11,1))
- SET APID(23)=$PIECE($GET(^DIC(10.2,+VADM(11,1),0)),U,2)
- +48 ;OTHER PHONE
- SET APID(26)=""
- SET APID(26)=$PIECE($GET(^AUPNPAT(DFN,18)),U)
- +49 SET APID(26)=$$HLPHONE^HLFNC(APID(26))
- +50 IF APID(26)'=""
- SET APID(26)=APID(26)_"~ORN~CP"
- +51 ;CURRENT EMAIL ADDRESS
- SET APID(27)=""
- SET APID(27)=$PIECE($GET(^AUPNPAT(DFN,18)),U,2)
- +52 IF APID(27)'=""
- SET APID(27)=APID(27)_"~NET~INTERNET"
- +53 SET APID(28)=$$GET1^DIQ(2,DFN_",",1901,"I")
- +54 SET APID(29)=""
- +55 SET APID(31)=""
- +56 SET PID(1)="PID"_HL("FS")
- +57 SET LVL=1
- SET X=1
- FOR
- SET X=$ORDER(APID(X))
- IF 'X
- QUIT
- Begin DoDot:1
- +58 SET PID(LVL)=$GET(PID(LVL))
- +59 SET NXT=APID(X)
- Begin DoDot:2
- +60 IF '$ORDER(APID(X,0))
- SET NXT=NXT_HL("FS")
- +61 IF $LENGTH($GET(PID(LVL))_NXT)>245
- SET LNGTH=245-$LENGTH(PID(LVL))
- SET PID(LVL)=PID(LVL)_$EXTRACT(NXT,1,LNGTH)
- SET LNGTH=LNGTH+1
- SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
- SET LVL=LVL+1
- +62 IF $LENGTH($GET(PID(LVL))_NXT)'>245
- SET PID(LVL)=$GET(PID(LVL))_NXT
- End DoDot:2
- +63 SET LVL2=0
- FOR
- SET LVL2=$ORDER(APID(X,LVL2))
- IF 'LVL2
- QUIT
- Begin DoDot:2
- +64 SET NXT=APID(X,LVL2)
- Begin DoDot:3
- +65 IF $LENGTH($GET(PID(LVL))_NXT)>245
- SET LNGTH=245-$LENGTH(PID(LVL))
- SET PID(LVL)=PID(LVL)_$EXTRACT(NXT,1,LNGTH)
- SET LNGTH=LNGTH+1
- SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
- SET LVL=LVL+1
- +66 IF $LENGTH($GET(PID(LVL))_NXT)'>245
- SET PID(LVL)=$GET(PID(LVL))_NXT
- +67 IF '$ORDER(APID(X,LVL2))
- SET PID(LVL)=PID(LVL)_HL("FS")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +68 DO KVA^VADPT
- +69 QUIT
- +70 ;
- MPINODE(DFN) ; returns MPI node for given DFN
- +1 ; DFN - patient file ien
- +2 ; returns: -1^error message or MPI node from patient file
- +3 NEW TMP
- +4 IF '$DATA(DFN)
- QUIT "-1^DFN not defined"
- +5 IF '$DATA(^DPT(DFN))
- QUIT "-1^DFN doesn't exist"
- +6 IF '$DATA(^DPT(DFN,"MPI"))
- QUIT "-1^No MPI node for DFN "_DFN
- +7 ;**45 added lock check for getting ICN data back
- LOCK +^DPT("MPI",DFN):10
- +8 NEW NODE
- SET NODE=$GET(^DPT(DFN,"MPI"))
- +9 IF NODE=""!(NODE?."^")
- SET NODE="-1^No MPI data for DFN "_DFN
- +10 LOCK -^DPT("MPI",DFN)
- +11 QUIT NODE
