LA7MUNK1 ;ihs/cmi/maw - MU2 NK1 Segment ; 22-Oct-2013 09:22 ; MAW
;;5.2;BLR IHS REFERENCE LAB;**1033**;NOV 01, 1997
;
NK12(CS,DATA) ;-- nok name
N MMN,MLNM,M2,MFNM,MMI,MSFX,MPRX,MPSFX,NK12
S NK12=""
S MMN=$P(DATA,U)
I $G(MMN)="" Q NK12
S MLNM=$P(MMN,",")
S M2=$P(MMN,",",2)
S MFNM=$P(M2," ")
S MMI=$P($P(M2," ",2)," ")
S MSFX=$P($P(M2," ",3)," ")
S MPRX=$P($P(M2," ",4)," ")
S MPSFX=$P(M2," ",5)
S NK12=MLNM_CS_MFNM_CS_MMI_CS_MSFX_CS_MPRX_CS_CS_"L"_CS_CS_CS_CS_CS_CS_CS_MPSFX
Q NK12
;
;
NK13(CS,DF,DATA) ;nok relationship
N NK13,REL,RELI,RLHL
S NK13=""
S RELI=$$GET1^DIQ(9000001,DF,2802,"I")
I '$G(RELI) Q NK13
S REL=$$GET1^DIQ(9000001,DF,2802)
S RLHL=$P($G(^AUTTRLSH(RELI,21)),U,4)
S NK13=RLHL_CS_REL_CS_"HL70063"_CS_$E(REL,1,1)_CS_REL_CS_"L"_CS_LA7VER_CS_"1.0"
Q NK13
;
NK14(CS,DF,DATA) ;
N NK14
S NK14=""
I $P(DATA,U,3)="" Q NK14
S NK14=$P(DATA,U,3)_CS_$P(DATA,U,4)_CS_$P(DATA,U,6)_CS_$$GET1^DIQ(5,$P(DATA,U,7),1)_CS_$P(DATA,U,8)_CS_"USA"_CS_"H"_CS_CS_$$LZERO^LA7MUPID($P($G(^DPT(DF,.11)),U,7),5)
Q NK14
;
NK15(CS,DF,DATA) ;nok communications
N NK15
S $P(DATA,U,9)=$TR($P(DATA,U,9),"-","")
S NK15=""
I $P(DATA,U,9)]"" S NK15=CS_"PRN"_CS_"PH"_CS_CS_$E($P(DATA,U,9),1)_CS_$E($P(DATA,U,9),2,4)_CS_$E($P(DATA,U,9),5,11)_CS_$R(1000)_CS_$P($G(^DPT(DF,0)),U,10)
I $P(DATA,U,11)]"" S NK15=NK15_RS_CS_"NET"_CS_"Internet"_CS_$P(DATA,U,11)_CS_CS_CS_CS_CS_"home"
Q NK15
;
NK113(CS,DF,CSS) ;-- next of kin organization
N NK113,DATA
S DATA=$G(^DPT(DF,.291))
S NK113=""
I $G(DATA)]"" D
. S $P(NK113,CS)=$P(DATA,U,3)
. S $P(NK113,CS,2)="L"
. S $P(NK113,CS,6)="RPMS_MPI"_CSS_"2.16.840.1.114222.4.10.3"_CSS_"ISO"
. S $P(NK113,CS,7)="XX"
. S $P(NK113,CS,10)=$P(DATA,U,5) ;in ZIP+4 field
Q NK113
;
NK130(CS,DF) ;-- next of kin contact person
N NK130,DATA,CP,LNM,REST,GN,MI,SF,PR,PSF
S DATA=$G(^DPT(DF,.291))
S NK130=""
I DATA]"" D
.S CP=$P(DATA,U,4)
.S LNM=$P(CP,",")
.S REST=$P(CP,",",2)
.S GN=$P(REST," ")
.S MI=$P($P(REST," ",2)," ")
.S SF=$P($P(REST," ",3)," ")
.S PR=$P($P(REST," ",4)," ")
.S PSF=$P(REST," ",5)
.S $P(NK130,CS)=LNM
.S $P(NK130,CS,2)=GN
.S $P(NK130,CS,3)=MI
.S $P(NK130,CS,4)=SF
.S $P(NK130,CS,5)=PR
.S $P(NK130,CS,7)="L"
.S $P(NK130,CS,14)=PSF
Q NK130
;
NK131(CS,DF) ;-- next of kin contact person telephone
N NK131,DATA,PH
S DATA=$G(^DPT(DF,.291))
S PH=$P(DATA,U,11)
S NK131=""
I PH]"" D
.S $P(NK131,CS,2)="WPN"
.S $P(NK131,CS,3)="PH"
.S $P(NK131,CS,5)=$E(PH,1)
.S $P(NK131,CS,6)=$E(PH,2,4)
.S $P(NK131,CS,7)=$E(PH,5,11)
.S $P(NK131,CS,8)=$E(PH,12,15)
.S $P(NK131,CS,9)=$P(DATA,U,5)
Q NK131
;
NK132(CS,DF) ;-- next of kin contact person address
N NK132,DATA
S NK132=""
S DATA=$G(^DPT(DF,.291))
I DATA]"" D
.S $P(NK132,CS)=$P(DATA,U,6)
.S $P(NK132,CS,2)=$P(DATA,U,7)
.S $P(NK132,CS,3)=$P(DATA,U,8)
.S $P(NK132,CS,4)=$$GET1^DIQ(5,$P(DATA,U,9),1)
.S $P(NK132,CS,5)=$P(DATA,U,10)
.S $P(NK132,CS,6)="USA"
.S $P(NK132,CS,7)="M"
.S $P(NK132,CS,9)=$$GET1^DIQ(2,DF,.2928)
Q NK132
;
LA7MUNK1 ;ihs/cmi/maw - MU2 NK1 Segment ; 22-Oct-2013 09:22 ; MAW
+1 ;;5.2;BLR IHS REFERENCE LAB;**1033**;NOV 01, 1997
+2 ;
NK12(CS,DATA) ;-- nok name
+1 NEW MMN,MLNM,M2,MFNM,MMI,MSFX,MPRX,MPSFX,NK12
+2 SET NK12=""
+3 SET MMN=$PIECE(DATA,U)
+4 IF $GET(MMN)=""
QUIT NK12
+5 SET MLNM=$PIECE(MMN,",")
+6 SET M2=$PIECE(MMN,",",2)
+7 SET MFNM=$PIECE(M2," ")
+8 SET MMI=$PIECE($PIECE(M2," ",2)," ")
+9 SET MSFX=$PIECE($PIECE(M2," ",3)," ")
+10 SET MPRX=$PIECE($PIECE(M2," ",4)," ")
+11 SET MPSFX=$PIECE(M2," ",5)
+12 SET NK12=MLNM_CS_MFNM_CS_MMI_CS_MSFX_CS_MPRX_CS_CS_"L"_CS_CS_CS_CS_CS_CS_CS_MPSFX
+13 QUIT NK12
+14 ;
+15 ;
NK13(CS,DF,DATA) ;nok relationship
+1 NEW NK13,REL,RELI,RLHL
+2 SET NK13=""
+3 SET RELI=$$GET1^DIQ(9000001,DF,2802,"I")
+4 IF '$GET(RELI)
QUIT NK13
+5 SET REL=$$GET1^DIQ(9000001,DF,2802)
+6 SET RLHL=$PIECE($GET(^AUTTRLSH(RELI,21)),U,4)
+7 SET NK13=RLHL_CS_REL_CS_"HL70063"_CS_$EXTRACT(REL,1,1)_CS_REL_CS_"L"_CS_LA7VER_CS_"1.0"
+8 QUIT NK13
+9 ;
NK14(CS,DF,DATA) ;
+1 NEW NK14
+2 SET NK14=""
+3 IF $PIECE(DATA,U,3)=""
QUIT NK14
+4 SET NK14=$PIECE(DATA,U,3)_CS_$PIECE(DATA,U,4)_CS_$PIECE(DATA,U,6)_CS_$$GET1^DIQ(5,$PIECE(DATA,U,7),1)_CS_$PIECE(DATA,U,8)_CS_"USA"_CS_"H"_CS_CS_$$LZERO^LA7MUPID($PIECE($GET(^DPT(DF,.11)),U,7),5)
+5 QUIT NK14
+6 ;
NK15(CS,DF,DATA) ;nok communications
+1 NEW NK15
+2 SET $PIECE(DATA,U,9)=$TRANSLATE($PIECE(DATA,U,9),"-","")
+3 SET NK15=""
+4 IF $PIECE(DATA,U,9)]""
SET NK15=CS_"PRN"_CS_"PH"_CS_CS_$EXTRACT($PIECE(DATA,U,9),1)_CS_$EXTRACT($PIECE(DATA,U,9),2,4)_CS_$EXTRACT($PIECE(DATA,U,9),5,11)_CS_$RANDOM(1000)_CS_$PIECE($GET(^DPT(DF,0)),U,10)
+5 IF $PIECE(DATA,U,11)]""
SET NK15=NK15_RS_CS_"NET"_CS_"Internet"_CS_$PIECE(DATA,U,11)_CS_CS_CS_CS_CS_"home"
+6 QUIT NK15
+7 ;
NK113(CS,DF,CSS) ;-- next of kin organization
+1 NEW NK113,DATA
+2 SET DATA=$GET(^DPT(DF,.291))
+3 SET NK113=""
+4 IF $GET(DATA)]""
Begin DoDot:1
+5 SET $PIECE(NK113,CS)=$PIECE(DATA,U,3)
+6 SET $PIECE(NK113,CS,2)="L"
+7 SET $PIECE(NK113,CS,6)="RPMS_MPI"_CSS_"2.16.840.1.114222.4.10.3"_CSS_"ISO"
+8 SET $PIECE(NK113,CS,7)="XX"
+9 ;in ZIP+4 field
SET $PIECE(NK113,CS,10)=$PIECE(DATA,U,5)
End DoDot:1
+10 QUIT NK113
+11 ;
NK130(CS,DF) ;-- next of kin contact person
+1 NEW NK130,DATA,CP,LNM,REST,GN,MI,SF,PR,PSF
+2 SET DATA=$GET(^DPT(DF,.291))
+3 SET NK130=""
+4 IF DATA]""
Begin DoDot:1
+5 SET CP=$PIECE(DATA,U,4)
+6 SET LNM=$PIECE(CP,",")
+7 SET REST=$PIECE(CP,",",2)
+8 SET GN=$PIECE(REST," ")
+9 SET MI=$PIECE($PIECE(REST," ",2)," ")
+10 SET SF=$PIECE($PIECE(REST," ",3)," ")
+11 SET PR=$PIECE($PIECE(REST," ",4)," ")
+12 SET PSF=$PIECE(REST," ",5)
+13 SET $PIECE(NK130,CS)=LNM
+14 SET $PIECE(NK130,CS,2)=GN
+15 SET $PIECE(NK130,CS,3)=MI
+16 SET $PIECE(NK130,CS,4)=SF
+17 SET $PIECE(NK130,CS,5)=PR
+18 SET $PIECE(NK130,CS,7)="L"
+19 SET $PIECE(NK130,CS,14)=PSF
End DoDot:1
+20 QUIT NK130
+21 ;
NK131(CS,DF) ;-- next of kin contact person telephone
+1 NEW NK131,DATA,PH
+2 SET DATA=$GET(^DPT(DF,.291))
+3 SET PH=$PIECE(DATA,U,11)
+4 SET NK131=""
+5 IF PH]""
Begin DoDot:1
+6 SET $PIECE(NK131,CS,2)="WPN"
+7 SET $PIECE(NK131,CS,3)="PH"
+8 SET $PIECE(NK131,CS,5)=$EXTRACT(PH,1)
+9 SET $PIECE(NK131,CS,6)=$EXTRACT(PH,2,4)
+10 SET $PIECE(NK131,CS,7)=$EXTRACT(PH,5,11)
+11 SET $PIECE(NK131,CS,8)=$EXTRACT(PH,12,15)
+12 SET $PIECE(NK131,CS,9)=$PIECE(DATA,U,5)
End DoDot:1
+13 QUIT NK131
+14 ;
NK132(CS,DF) ;-- next of kin contact person address
+1 NEW NK132,DATA
+2 SET NK132=""
+3 SET DATA=$GET(^DPT(DF,.291))
+4 IF DATA]""
Begin DoDot:1
+5 SET $PIECE(NK132,CS)=$PIECE(DATA,U,6)
+6 SET $PIECE(NK132,CS,2)=$PIECE(DATA,U,7)
+7 SET $PIECE(NK132,CS,3)=$PIECE(DATA,U,8)
+8 SET $PIECE(NK132,CS,4)=$$GET1^DIQ(5,$PIECE(DATA,U,9),1)
+9 SET $PIECE(NK132,CS,5)=$PIECE(DATA,U,10)
+10 SET $PIECE(NK132,CS,6)="USA"
+11 SET $PIECE(NK132,CS,7)="M"
+12 SET $PIECE(NK132,CS,9)=$$GET1^DIQ(2,DF,.2928)
End DoDot:1
+13 QUIT NK132
+14 ;
