Routine: LA7MUNK1

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      ;

LA7MUNK1.m