Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7MUPID

LA7MUPID.m

Go to the documentation of this file. 
  1. LA7MUPID ;ihs/cmi/maw - MU2 PID Segment ; 22-Oct-2013 09:22 ; MAW
  1.  ;;5.2;BLR IHS REFERENCE LAB;**1033**;NOV 01, 1997
  1.  ;
  1. PID3(CS,RS,SC,DFN,SSN)  ;identifiers
  1.  N PID3
  1.  S PID3=$$HRN^AUPNPAT(DFN,DUZ(2))_CS_CS_CS_"RPMS MPI"_SC_"2.16.840.1.113883.3.72.5.31.2"_SC_"ISO"_CS_"MR"_CS_FAC_SC_"2.16.840.1.113883.5.0"_SC_"ISO"
  1.  S PID3=PID3_RS_$G(SSN)_CS_CS_CS_"SSN"_SC_"2.16.840.1.113883.3.4.1"_SC_"ISO"_CS_"SS"_CS_"SSA"_SC_"2.16.840.1.113883.3.184"_SC_"ISO"
  1.  Q PID3
  1.  ;
  1. PID5(CS,RS,AL)  ;patients name
  1.  N PID5
  1.  ;S PID5=$P(VADM(1),",")_CS_$P($P(VADM(1),",",2)," ")_CS_$P($P(VADM(1),",",2)," ",2)_CS_$P($P(VADM(1),",",2)," ",3)_CS_$P($P(VADM(1),",",2)," ",4)_CS_CS_"L"_CS_$P($P(VADM(1),",",2)," ",5)  ;_CS_$P($P($P(VADM(1),",",2)," ",2)," ",5)_"L"
  1.  S $P(PID5,CS)=$P(VADM(1),",")
  1.  S $P(PID5,CS,2)=$P($P(VADM(1),",",2)," ")
  1.  S $P(PID5,CS,3)=$P($P(VADM(1),",",2)," ",2)
  1.  S $P(PID5,CS,4)=$P($P(VADM(1),",",2)," ",3)
  1.  S $P(PID5,CS,5)=$P($P(VADM(1),",",2)," ",4)
  1.  S $P(PID5,CS,7)="L"
  1.  S $P(PID5,CS,14)=$P($P(VADM(1),",",2)," ",5)
  1.  S PID5=PID5_RS_$P(AL,",")_CS_$P($P(AL,",",2)," ")_CS_$P($P(AL,",",2)," ",2)_CS_$P($P(AL,",",2)," ",3)_CS_$P($P(AL,",",2)," ",4)_CS_CS_"A"  ;$P($P($P(AL,",",2)," ",2)," ",5)_CS_"B"
  1.  Q PID5
  1.  ;
  1. PID6(CS,DF)  ;-mothers maiden name
  1.  N PID6,MMN,MLNM,M2,MFNM,MMI,MSFX,MPRX,MPSFX
  1.  S MMN=$$GET1^DIQ(2,DF,.2403)
  1.  S MLNM=$P(MMN,",")
  1.  S M2=$P(MMN,",",2)
  1.  S MFNM=$P(M2," ")
  1.  S MMI=$P($P(M2," ",2)," ")
  1.  S MSFX=$P($P(M2," ",3)," ")
  1.  S MPRX=$P($P(M2," ",4)," ")
  1.  S MPSFX=$P(M2," ",5)
  1.  S PID6=""
  1.  i $G(MMN)]"" S PID6=MLNM_CS_MFNM_CS_MMI_CS_MSFX_CS_MPRX_CS_CS_"M"_CS_CS_CS_CS_CS_CS_CS_MPSFX  ;mothers maiden name
  1.  Q PID6
  1.  ;
  1. PID7()  ;-- dob
  1.  N PID7
  1.  S PID7=$$FMTHL7^XLFDT($P(VADM(3),U))
  1.  Q PID7
  1.  ;
  1. PID8()  ;-- sex
  1.  N PID8
  1.  S PID8=$P(VADM(5),U)
  1.  Q PID8
  1.  ;
  1. PID10(CS)  ;--race
  1.  N PID10
  1.  S PID10=$P($G(^DIC(10,$P(VADM(8),U),0)),U,3)_CS_$P(VADM(8),U,2)_CS_"CDCREC"_CS_$P($G(^DIC(10,$P(VADM(8),U),0)),U,3)_CS_$P(VADM(8),U,2)_CS_"L"_CS_"1.1"_CS_"2.0"
  1.  Q PID10
  1.  ;
  1. PID11(CS,DF)  ;-- address
  1.  N PID11,ADD1,ADD2
  1.  S ADD1=$G(^DPT(DF,.11))
  1.  S ADD2=$G(^DPT(DF,.121))
  1.  S PID11=$P(ADD1,U)_CS_$P(ADD1,U,2)_CS_$P(ADD1,U,4)_CS_$$GET1^DIQ(5,$P(ADD1,U,5),1)_CS_$P(ADD1,U,6)_CS_"USA"_CS_"H"_CS_CS_$$LZERO($$GET1^DIQ(5,$P(ADD1,U,5),2)_$P(ADD1,U,7),5)
  1.  I $P(ADD2,U)]"" S PID11=PID11_RS_$P(ADD2,U)_CS_$P(ADD2,U,2)_CS_$P(ADD2,U,4)_CS_$$GET1^DIQ(5,$P(ADD2,U,5),1)_CS_$P(ADD2,U,6)_CS_"USA"_CS_"C"_CS_CS_$$LZERO($$GET1^DIQ(5,$P(ADD1,U,5),2)_$P(ADD2,U,11),5)
  1.  Q PID11
  1.  ;
  1. PID13(CS,DF)  ;-- home communications
  1.  N PID13,PH1
  1.  S PH1=$G(^DPT(DF,.13))
  1.  I PH1="" Q ""
  1.  I $P(PH1,U,1)]"" S PID13=CS_"PRN"_CS_"PH"_CS_CS_$E(PH1,1)_CS_$E(PH1,2,4)_CS_$E(PH1,5,11)_CS_$R(1000)_CS_$$GET1^DIQ(2,DF,.091)
  1.  I $P(PH1,U,1)="",$P(PH1,U,4)]"" S PID13=CS_"PRN"_CS_"CP"_CS_CS_$E($P(PH1,U,4),1)_CS_$E($P(PH1,U,4),2,4)_CS_$E($P(PH1,U,4),5,11)_CS_CS
  1.  I $P(PH1,U,3)]"" S PID13=PID13_RS_CS_"NET"_CS_"Internet"_CS_$P(PH1,U,3)_CS_CS_CS_CS_CS_"home"
  1.  I $$GET1^DIQ(9000001,DF,1801)]"" D
  1.  . S PID13=PID13_RS_CS_"ORN"_CS_"CP"_CS_CS_$E($$GET1^DIQ(9000001,DF,1801))_CS_$E($$GET1^DIQ(9000001,DF,1801),2,4)_CS_$E($$GET1^DIQ(9000001,DF,1801),5,11)_CS_CS_"other phone"
  1.  I $P(PH1,U,2)]"",PID13'[RS S PID13=PID13_RS_CS_"WPN"_CS_"PH"_CS_CS_$E($P(PH1,U,2),1)_CS_$E($P(PH1,U,2),2,4)_CS_$E($P(PH1,U,2),5,11)_CS_$R(1000)_CS_$$GET1^DIQ(2,DF,.091)
  1.  Q PID13
  1. PID14(CS,DF)  ;-- work communications
  1.  N PID14,PH1
  1.  S PH1=$G(^DPT(DF,.13))
  1.  S PID14=""
  1.  I $P(PH1,U,2)]"" S PID14=CS_"WPN"_CS_"PH"_CS_CS_$E($P(PH1,U,2),1)_CS_$E($P(PH1,U,2),2,4)_CS_$E($P(PH1,U,2),5,11)_CS_$R(1000)_CS_$$GET1^DIQ(2,DF,.091)
  1.  Q PID14
  1.  ;
  1. PID22(CS,DF,ETH,SITE)  ;-- ethnic group
  1.  N PID22
  1.  S PID22=$P($G(^DIC(10.2,ETH,0)),U,2)_CS_$P($G(^DIC(10.2,ETH,0)),U)_CS_"HL70189"_CS_$P($G(^DIC(10.2,ETH,0)),U,3)_CS_$P($G(^DIC(10.2,ETH,0)),U)_CS_"CDCREC"_CS_$P($G(^BLRRLMU(SITE,0)),U,2)_CS_$P($G(^BLRRLMU(SITE,0)),U,2)
  1.  Q PID22
  1.  ;
  1. PID29(DF)  ;-- patient death date/time
  1.  N PID29
  1.  S PID29=$$FMTHL7^XLFDT($P($G(^DPT(DF,.35)),U))
  1.  Q PID29
  1.  ;
  1. PID30(DF)  ;-- patient death indicator
  1.  N PID30
  1.  S PID30=$S($P($G(^DPT(DF,.35)),U)]"":"Y",1:"N")
  1.  Q PID30
  1.  ;
  1. PID33(DF)  ;-- last update
  1.  N PID33
  1.  S PID33=$$FMTHL7^XLFDT($P($G(^AUPNPAT(DF,0)),U,3))_"0000"
  1.  Q PID33
  1.  ;
  1. PID34(CS,FAC)  ;update facility
  1.  N PID34
  1.  S PID34=$G(FAC)_CS_"2.16.840.1.113883.5.0"_CS_"ISO"
  1.  Q PID34
  1.  ;
  1. PID35(CS,SITE)  ;species  MU2 hardcoded
  1.  N PID35
  1.  S PID35=337915000_CS_"Homo sapiens"_CS_"SCT"_CS_"HUMAN"_CS_"HUMAN"_CS_"L"_CS_$P($G(^BLRRLMU(SITE,0)),U,2)_CS_"2.0"
  1.  Q PID35
  1.  ;
  1. LZERO(VAL,NM) ;-- leading zero utility
  1.  N RET
  1.  I $L(VAL)=1 Q "0000"_VAL
  1.  I $L(VAL)=2 Q "000"_VAL
  1.  I $L(VAL)=3 Q "00"_VAL
  1.  I $L(VAL)=4 Q "0"_VAL
  1.  Q VAL
  1.  ;