RGADTP1 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;7/19/21 12:43
;;1.0;CLINICAL INFO RESOURCE NETWORK;**26,27,42,45,44,47,48,59,61,64,67,71,76**;30 Apr 99;Build 1
;
PIDP(MSG,ARRAY,HL) ;process PID segment
N ID,IDS,PIDAA,PIDNTC
;Since PID can be over 245 characters loop through setting a PID ARRAY
;sequenced PID(1)="PID"... PID(4 or 5) can be over 245 characters so
;it will also loop and place it in PID(4,1...
;
; Input variables
; assumes that MSG or MSG(I) will contain the PID segment
; Output ARRAY ARRAY will contain the following subscripts
; SSN - patient SSN
; ICN - patient ICN
; DFN - sites local identifier
; MPISSITE - authoritative source (station# of sending site)
; SEX - patient's SEX
; MPIDOB - Date of Birth
; NAME,SURNAME,FIRST,MIDDLE,PREFIX,and SUFFIX - Patient Name
; MMN - Mother's maiden name
; POBCITY, POBSTATE - Place of birth city and state
;
N PID,MPIJ,LNGTH,LNGTH1,PID1,SEQ,SEQ1,COMP,SUBCOMP,REP,HLECH,X,Y,CNT,NXT,ID,IDS,PIDAA,PIDNTC,NAME,LNGTH2,PIDSITE,PIDXDT,HLECH,HLFS
S HLFS=HL("FS"),HLECH=HL("ECH")
S ARRAY("DFN")="",ARRAY("ICN")="",ARRAY("CLAIMN")="",ARRAY("SSN")=""
S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4),REP=$E(HL("ECH"),2)
S LNGTH=$L(MSG,HL("FS")) F SEQ=1:1:LNGTH S PID(SEQ)=$P(MSG,HL("FS"),SEQ)
S SEQ1=1,X=0 F S X=$O(MSG(X)) Q:'X S LNGTH=$L(MSG(X),HL("FS")) D
. F Y=1:1:LNGTH S:Y'=1 SEQ=SEQ+1,SEQ1=1 D ;**61 MVI_2970 (dri)
.. S NXT=$P(MSG(X),HL("FS"),Y) D
... I $L($G(PID(SEQ)))=245 D Q
.... I $L(NXT_$G(PID(SEQ,SEQ1)))>245 S LNGTH1=$L(PID(SEQ,SEQ1)) S LNGTH2=245-LNGTH1,PID(SEQ,SEQ1)=$G(PID(SEQ,SEQ1))_$E(NXT,1,LNGTH2),LNGTH2=LNGTH2+1,NXT=$E(NXT,LNGTH2,$L(NXT)),SEQ1=SEQ1+1
.... I $L(NXT_$G(PID(SEQ,SEQ1)))'>245 S PID(SEQ,SEQ1)=$G(PID(SEQ,SEQ1))_NXT
... I $L(NXT_$G(PID(SEQ)))>245 S LNGTH1=$L($G(PID(SEQ))) S LNGTH2=245-LNGTH1,PID(SEQ)=$G(PID(SEQ))_$E(NXT,1,LNGTH2),LNGTH2=LNGTH2+1,NXT=$E(NXT,LNGTH2,$L(NXT)) S PID(SEQ,SEQ1)=NXT
... I $L(NXT_$G(PID(SEQ)))'>245 S PID(SEQ)=$G(PID(SEQ))_NXT Q
;
;get PID-3 Patient Identifier List (three ids should be returned ICN, SSN, and DFN)
I $G(PID(4))'="" D ;**61 MVI_2970 (dri) problem processing volume of name ids
. N A,ACNT,CNT,ID,IDS,IDSWKD,LASTID,PIDAA,PIDNTC,PIDSITE,PIDXDT,X
. S A="",IDSWKD=0,CNT=1,ACNT=1
. S IDS=$G(PID(4)),LASTID=$L(IDS,REP) D IDSARR
. F S A=$O(PID(4,A)) Q:A="" S IDS=$G(PID(4,A)),LASTID=$L(IDS,REP) D IDSARR
;
;get PID-4 alternate ID (ICN History)
I $G(PID(5))'="" D
. S CNT=1
. F X=1:1:$L(PID(5),REP) S ARRAY("OID",CNT)=$P(PID(5),REP,X),CNT=CNT+1
. S Y=0 F S Y=$O(PID(5,Y)) Q:'Y D
.. S ARRAY("OID",CNT-1)=ARRAY("OID",CNT-1)_$P(PID(5,Y),REP)
.. F X=2:1:$L(PID(5,Y),REP) S ARRAY("OID",CNT)=$P(PID(5,Y),REP,X),CNT=CNT+1
. S X=0 F S X=$O(ARRAY("OID",X)) Q:'X D
.. N ID,AA,AL S ID=$P(ARRAY("OID",X),COMP),AA=$P($P(ARRAY("OID",X),COMP,4),SUBCOMP,1),AL=$P($P(ARRAY("OID",X),COMP,6),SUBCOMP,2) S AL=$$IEN^XUAF4(AL)
.. S ARRAY("OID",X)=ID_"^"_AA_"^"_AL
;
;get PID-5 Patient Name
I $G(PID(6))'="" D ;**61 MVI_2970 (dri) problem processing volume of aliases
. N A,ALISWKD,IDCNT,LASTNAM,NAME,NAMES,X
. S A="",ALISWKD=0,IDCNT=1
. S NAMES=$G(PID(6)),LASTNAM=$L(NAMES,REP) D NAMARR
. F S A=$O(PID(6,A)) Q:A="" S NAMES=$G(PID(6,A)),LASTNAM=$L(NAMES,REP) D NAMARR
;
;N KK,JJ,TMPJ,IDCNT2 S IDCNT=1
;I $G(PID(6))'="" F IDCNT2=1:1:$L(PID(6),REP) S NAME=$P(PID(6),REP,IDCNT2) D
;.I $P(NAME,COMP,7)="L" S ARRAY("SURNAME")=$P(NAME,COMP),ARRAY("FIRST")=$P(NAME,COMP,2),ARRAY("MIDDLE")=$P(NAME,COMP,3),ARRAY("PREFIX")=$P(NAME,COMP,4),ARRAY("SUFFIX")=$P(NAME,COMP,5),ARRAY("NAME")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)) Q
;.I $P(NAME,COMP,7)="A" S $P(ARRAY("ALIAS",IDCNT),"^")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)),IDCNT=IDCNT+1 Q ;**48 ALIAS NAMES?
;.;**48 alias could send PID(6) to second subscript level
;.S KK=$O(PID(6,"")) I KK'="" S PID(6,KK)=$P(PID(6),REP,IDCNT2)_PID(6,KK)
;.S JJ=0 F S JJ=$O(PID(6,JJ)) Q:'JJ D
;..I JJ'=KK S PID(6,JJ)=$P(PID(6,$O(PID(6,JJ),-1)),REP,TMPJ)_PID(6,JJ)
;..F TMPJ=1:1:$L(PID(6,JJ),REP) S NAME=$P(PID(6,JJ),REP,TMPJ) D
;...I $P(NAME,COMP,7)="A" S $P(ARRAY("ALIAS",IDCNT),"^")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)),IDCNT=IDCNT+1
;
;get PID-6 Mother's maiden name
S ARRAY("MMN")=$P($G(PID(7)),COMP,1,5) D
. I $P(ARRAY("MMN"),COMP)'=HL("Q") S HLECH=HL("ECH") S ARRAY("MMN")=$$FREE^RGRSPARS($$FMNAME^HLFNC(ARRAY("MMN"))) Q
. I $P(ARRAY("MMN"),COMP)=HL("Q") S ARRAY("MMN")=$$FREE^RGRSPARS($P(ARRAY("MMN"),COMP))
;
;get PID-7 Date of Birth
;**47 taking HL("Q") into account
I $G(PID(8))=HL("Q") S PID(8)="@",ARRAY("MPIDOB")="@"
I $G(PID(8))'="@" S ARRAY("MPIDOB")=$$FMDATE^HLFNC($G(PID(8)))
;
;get PID-8 Sex
;**47 taking HL("Q") into account
I $G(PID(9))=HL("Q") S PID(9)="@"
S ARRAY("SEX")=$G(PID(9))
;
;get PID-11-3 ADDRESS BOTH "P"rimary and "N" Place of
S CNT=1
N ADRTYPE,ADDR
F X=1:1:$L(PID(12),REP) D
. S ADDR=$P(PID(12),REP,X),ADRTYPE=$P(ADDR,COMP,7)
. I ADRTYPE="P" D
.. S ADDR=$$FREE^RGRSPARS(ADDR)
.. S ARRAY(.111)=$$FREE^RGRSPARS($P(ADDR,COMP,1)) ;addr [1]
.. S ARRAY(.112)=$$FREE^RGRSPARS($P(ADDR,COMP,2)) ;addr [2]
.. S ARRAY(.113)=$$FREE^RGRSPARS($P(ADDR,COMP,8)) ;addr [3]
.. S ARRAY(.114)=$$FREE^RGRSPARS($P(ADDR,COMP,3)) ;city
.. S ARRAY(.115)=$$STATE^RGRSPARS($P(ADDR,COMP,4)) ;state
.. S ARRAY(.1112)=$$FREE^RGRSPARS($P(ADDR,COMP,5)) ;zip+4
.. N CNTYCODE S CNTYCODE=PID(13) ;county code
.. S ARRAY(.117)=$$COUNTY^RGRSPARS(ARRAY(.115),CNTYCODE)
.. S ARRAY(.131)=$$FREE^RGRSPARS(PID(14))
.. S ARRAY(.132)=$$FREE^RGRSPARS(PID(15))
. I ADRTYPE="N" D
.. S ARRAY("POBCITY")=$$FREE^RGRSPARS($P(ADDR,COMP,3)) ;POB city
.. S ARRAY("POBSTATE")=$$STATE^RGRSPARS($P(ADDR,COMP,4)) ;POB state
;
;marital status
S ARRAY(.05)=$$MARITAL^RGRSPARS(PID(17))
;
;multiple birth indicator **47
S ARRAY("MBI")=$G(PID(25)) I ARRAY("MBI")=HL("Q") S ARRAY("MBI")="@" ;**47 to get MBI and setup as yes/no field change to @ if HL("Q")
;
;;REMOVED FROM PATCH 45 DUE TO NEEDING DG707
;religious preference
S ARRAY(.08)=$$RELIG^RGRSPARS(PID(18))
;
;address
;
;get PID-29 Date of Death
S ARRAY("MPIDOD")=$$FREE^RGRSPARS($$FMDATE^HLFNC($G(PID(30)))),ARRAY(.351)=ARRAY("MPIDOD")
Q
;
IDSARR ;parse ids ;**61 MVI_2970 (dri)
F X=1:1:LASTID S ID=$P(IDS,REP,X) D
. I IDSWKD=1 S IDSWKD=0 Q ;first repetition of continuation message already worked
. I X=LASTID,$D(PID(4,A+1)) S ID=ID_$P(PID(4,A+1),REP,1),IDSWKD=1 ;if last repetition check for an extension of message
. ;get id, assigning authority, and name type code
. S PIDAA=$P($P(ID,COMP,4),SUBCOMP),PIDNTC=$P(ID,COMP,5),PIDSITE=$P($P(ID,COMP,6),SUBCOMP,2),PIDXDT=$P(ID,COMP,8)
. S ID=$P(ID,COMP)
. ;Q:ID="" **48
. ;check assigning authority(0363) AND name type code(0203)
. I PIDAA="USVHA" D Q
.. I PIDNTC="NI" D
... I $G(PIDXDT)="" S ARRAY("ICN")=ID,ARRAY("MPISSITE")=PIDSITE,ARRAY(991.02)=$P(ID,"V",2) ;National unique individual identifier
... I $G(PIDXDT)'="" S ARRAY("OID",CNT)=ID_"^"_PIDAA_"^"_PIDSITE_"^"_PIDXDT,CNT=CNT+1 ;Deprecated National unique individual identifier
.. I PIDNTC="PI" S ARRAY("DFN")=ID,ARRAY("DFNLOC")=PIDSITE ;Patient internal identifier
. I PIDAA="USSSA" D Q
.. I PIDNTC="SS",PIDXDT="" S ARRAY("SSN")=ID I ID=HL("Q") S ARRAY("SSN")="@" ;Social Security number **44 (new) look out for alias ssns
.. I PIDNTC="SS",PIDXDT'="" S $P(ARRAY("ALIAS",ACNT),"^",2)=ID,ACNT=ACNT+1 ;**48 store alias ssn
.. ;**47 includes HL("Q") check
. I PIDAA="USVBA" D Q
.. I PIDNTC="PN" S ARRAY("CLAIMN")=ID ;VBA CLAIM#
. ;**59,MVI_880: Get TIN and FIN values
. I PIDAA="USDOD" D Q
.. I PIDNTC="TIN" S ARRAY("TIN")=$S(ID=HL("Q"):"@",1:ID)
.. I PIDNTC="FIN" S ARRAY("FIN")=$S(ID=HL("Q"):"@",1:ID)
. ;**76, VAMPI-11120 (dri) Get ITIN value
. I PIDAA="USIRS" D Q
.. I PIDNTC="NI" S ARRAY("ITIN")=$S(ID=HL("Q"):"@",1:ID)
Q
;
NAMARR ;parse legal and alias names ;**61 MVI_2970 (dri)
F X=1:1:LASTNAM S NAME=$P(NAMES,REP,X) D
. I ALISWKD=1 S ALISWKD=0 Q ;first repetition of continuation message already worked
. I X=LASTNAM,$D(PID(6,A+1)) S NAME=NAME_$P($G(PID(6,A+1)),REP,1),ALISWKD=1 ;if last repetition check for an extension of message
. I $P(NAME,COMP,7)="L" D Q ;legal
.. ;**71,Story 841921 (mko): Take into account two quotes -- convert to null
.. S ARRAY("SURNAME")=$$QTON($P(NAME,COMP))
.. S ARRAY("FIRST")=$$QTON($P(NAME,COMP,2))
.. S ARRAY("MIDDLE")=$$QTON($P(NAME,COMP,3))
.. S ARRAY("PREFIX")=$$QTON($P(NAME,COMP,5))
.. S ARRAY("SUFFIX")=$$QTON($P(NAME,COMP,4))
.. S ARRAY("NAME")=$$FMNAME^HLFNC($P(NAME,COMP,1,4))
.;**67 - Story 455458 (ckn) - Parse Preferred Name
. I $P(NAME,COMP,7)="N" D
..N PNAME
..S PNAME=$P(NAME,COMP) S ARRAY("PREFERREDNAME")=$S(PNAME=HL("Q"):"@",1:PNAME)
.;**71,Story 841921 (mko): Put the name components into ARRAY("ALIAS",n,"NC")
. I $P(NAME,COMP,7)="A" D
.. N ALIASNC,ALIASNM
.. S ALIASNC="" F I=1:1:4 S ALIASNC=ALIASNC_$$QTON($P(NAME,COMP,I))_COMP
.. S ALIASNC=$P(ALIASNC,COMP,1,4),ALIASNM=$$FMNAME^HLFNC(ALIASNC)
.. I $L(ALIASNM)>30,'$$GETFLAG^MPIFNAMC D
... N ALIAS
... S ALIAS("SURNAME")=$P(ALIASNC,COMP)
... S ALIAS("FIRST")=$P(ALIASNC,COMP,2)
... S ALIAS("MIDDLE")=$P(ALIASNC,COMP,3)
... S ALIAS("SUFFIX")=$P(ALIASNC,COMP,4)
... S ALIASNM=$$FMTNAME^RGADTP3(.ALIAS,30)
.. S $P(ARRAY("ALIAS",IDCNT),"^")=ALIASNM
.. S ARRAY("ALIAS",IDCNT,"NC")=$TR(ALIASNC,COMP,"^")
.. S IDCNT=IDCNT+1 ;**48 alias
Q
;
QTON(X) ;**71,Story 841921 (mko): Convert two quotes to null
Q $S(X="""""":"",1:X)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGADTP1 9683 printed Oct 16, 2024@17:42:15 Page 2
RGADTP1 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;7/19/21 12:43
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**26,27,42,45,44,47,48,59,61,64,67,71,76**;30 Apr 99;Build 1
+2 ;
PIDP(MSG,ARRAY,HL) ;process PID segment
+1 NEW ID,IDS,PIDAA,PIDNTC
+2 ;Since PID can be over 245 characters loop through setting a PID ARRAY
+3 ;sequenced PID(1)="PID"... PID(4 or 5) can be over 245 characters so
+4 ;it will also loop and place it in PID(4,1...
+5 ;
+6 ; Input variables
+7 ; assumes that MSG or MSG(I) will contain the PID segment
+8 ; Output ARRAY ARRAY will contain the following subscripts
+9 ; SSN - patient SSN
+10 ; ICN - patient ICN
+11 ; DFN - sites local identifier
+12 ; MPISSITE - authoritative source (station# of sending site)
+13 ; SEX - patient's SEX
+14 ; MPIDOB - Date of Birth
+15 ; NAME,SURNAME,FIRST,MIDDLE,PREFIX,and SUFFIX - Patient Name
+16 ; MMN - Mother's maiden name
+17 ; POBCITY, POBSTATE - Place of birth city and state
+18 ;
+19 NEW PID,MPIJ,LNGTH,LNGTH1,PID1,SEQ,SEQ1,COMP,SUBCOMP,REP,HLECH,X,Y,CNT,NXT,ID,IDS,PIDAA,PIDNTC,NAME,LNGTH2,PIDSITE,PIDXDT,HLECH,HLFS
+20 SET HLFS=HL("FS")
SET HLECH=HL("ECH")
+21 SET ARRAY("DFN")=""
SET ARRAY("ICN")=""
SET ARRAY("CLAIMN")=""
SET ARRAY("SSN")=""
+22 SET COMP=$EXTRACT(HL("ECH"),1)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
SET REP=$EXTRACT(HL("ECH"),2)
+23 SET LNGTH=$LENGTH(MSG,HL("FS"))
FOR SEQ=1:1:LNGTH
SET PID(SEQ)=$PIECE(MSG,HL("FS"),SEQ)
+24 SET SEQ1=1
SET X=0
FOR
SET X=$ORDER(MSG(X))
if 'X
QUIT
SET LNGTH=$LENGTH(MSG(X),HL("FS"))
Begin DoDot:1
+25 ;**61 MVI_2970 (dri)
FOR Y=1:1:LNGTH
if Y'=1
SET SEQ=SEQ+1
SET SEQ1=1
Begin DoDot:2
+26 SET NXT=$PIECE(MSG(X),HL("FS"),Y)
Begin DoDot:3
+27 IF $LENGTH($GET(PID(SEQ)))=245
Begin DoDot:4
+28 IF $LENGTH(NXT_$GET(PID(SEQ,SEQ1)))>245
SET LNGTH1=$LENGTH(PID(SEQ,SEQ1))
SET LNGTH2=245-LNGTH1
SET PID(SEQ,SEQ1)=$GET(PID(SEQ,SEQ1))_$EXTRACT(NXT,1,LNGTH2)
SET LNGTH2=LNGTH2+1
SET NXT=$EXTRACT(NXT,LNGTH2,$LENGTH(NXT))
SET SEQ1=SEQ1+1
+29 IF $LENGTH(NXT_$GET(PID(SEQ,SEQ1)))'>245
SET PID(SEQ,SEQ1)=$GET(PID(SEQ,SEQ1))_NXT
End DoDot:4
QUIT
+30 IF $LENGTH(NXT_$GET(PID(SEQ)))>245
SET LNGTH1=$LENGTH($GET(PID(SEQ)))
SET LNGTH2=245-LNGTH1
SET PID(SEQ)=$GET(PID(SEQ))_$EXTRACT(NXT,1,LNGTH2)
SET LNGTH2=LNGTH2+1
SET NXT=$EXTRACT(NXT,LNGTH2,$LENGTH(NXT))
SET PID(SEQ,SEQ1)=NXT
+31 IF $LENGTH(NXT_$GET(PID(SEQ)))'>245
SET PID(SEQ)=$GET(PID(SEQ))_NXT
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ;get PID-3 Patient Identifier List (three ids should be returned ICN, SSN, and DFN)
+34 ;**61 MVI_2970 (dri) problem processing volume of name ids
IF $GET(PID(4))'=""
Begin DoDot:1
+35 NEW A,ACNT,CNT,ID,IDS,IDSWKD,LASTID,PIDAA,PIDNTC,PIDSITE,PIDXDT,X
+36 SET A=""
SET IDSWKD=0
SET CNT=1
SET ACNT=1
+37 SET IDS=$GET(PID(4))
SET LASTID=$LENGTH(IDS,REP)
DO IDSARR
+38 FOR
SET A=$ORDER(PID(4,A))
if A=""
QUIT
SET IDS=$GET(PID(4,A))
SET LASTID=$LENGTH(IDS,REP)
DO IDSARR
End DoDot:1
+39 ;
+40 ;get PID-4 alternate ID (ICN History)
+41 IF $GET(PID(5))'=""
Begin DoDot:1
+42 SET CNT=1
+43 FOR X=1:1:$LENGTH(PID(5),REP)
SET ARRAY("OID",CNT)=$PIECE(PID(5),REP,X)
SET CNT=CNT+1
+44 SET Y=0
FOR
SET Y=$ORDER(PID(5,Y))
if 'Y
QUIT
Begin DoDot:2
+45 SET ARRAY("OID",CNT-1)=ARRAY("OID",CNT-1)_$PIECE(PID(5,Y),REP)
+46 FOR X=2:1:$LENGTH(PID(5,Y),REP)
SET ARRAY("OID",CNT)=$PIECE(PID(5,Y),REP,X)
SET CNT=CNT+1
End DoDot:2
+47 SET X=0
FOR
SET X=$ORDER(ARRAY("OID",X))
if 'X
QUIT
Begin DoDot:2
+48 NEW ID,AA,AL
SET ID=$PIECE(ARRAY("OID",X),COMP)
SET AA=$PIECE($PIECE(ARRAY("OID",X),COMP,4),SUBCOMP,1)
SET AL=$PIECE($PIECE(ARRAY("OID",X),COMP,6),SUBCOMP,2)
SET AL=$$IEN^XUAF4(AL)
+49 SET ARRAY("OID",X)=ID_"^"_AA_"^"_AL
End DoDot:2
End DoDot:1
+50 ;
+51 ;get PID-5 Patient Name
+52 ;**61 MVI_2970 (dri) problem processing volume of aliases
IF $GET(PID(6))'=""
Begin DoDot:1
+53 NEW A,ALISWKD,IDCNT,LASTNAM,NAME,NAMES,X
+54 SET A=""
SET ALISWKD=0
SET IDCNT=1
+55 SET NAMES=$GET(PID(6))
SET LASTNAM=$LENGTH(NAMES,REP)
DO NAMARR
+56 FOR
SET A=$ORDER(PID(6,A))
if A=""
QUIT
SET NAMES=$GET(PID(6,A))
SET LASTNAM=$LENGTH(NAMES,REP)
DO NAMARR
End DoDot:1
+57 ;
+58 ;N KK,JJ,TMPJ,IDCNT2 S IDCNT=1
+59 ;I $G(PID(6))'="" F IDCNT2=1:1:$L(PID(6),REP) S NAME=$P(PID(6),REP,IDCNT2) D
+60 ;.I $P(NAME,COMP,7)="L" S ARRAY("SURNAME")=$P(NAME,COMP),ARRAY("FIRST")=$P(NAME,COMP,2),ARRAY("MIDDLE")=$P(NAME,COMP,3),ARRAY("PREFIX")=$P(NAME,COMP,4),ARRAY("SUFFIX")=$P(NAME,COMP,5),ARRAY("NAME")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)) Q
+61 ;.I $P(NAME,COMP,7)="A" S $P(ARRAY("ALIAS",IDCNT),"^")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)),IDCNT=IDCNT+1 Q ;**48 ALIAS NAMES?
+62 ;.;**48 alias could send PID(6) to second subscript level
+63 ;.S KK=$O(PID(6,"")) I KK'="" S PID(6,KK)=$P(PID(6),REP,IDCNT2)_PID(6,KK)
+64 ;.S JJ=0 F S JJ=$O(PID(6,JJ)) Q:'JJ D
+65 ;..I JJ'=KK S PID(6,JJ)=$P(PID(6,$O(PID(6,JJ),-1)),REP,TMPJ)_PID(6,JJ)
+66 ;..F TMPJ=1:1:$L(PID(6,JJ),REP) S NAME=$P(PID(6,JJ),REP,TMPJ) D
+67 ;...I $P(NAME,COMP,7)="A" S $P(ARRAY("ALIAS",IDCNT),"^")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)),IDCNT=IDCNT+1
+68 ;
+69 ;get PID-6 Mother's maiden name
+70 SET ARRAY("MMN")=$PIECE($GET(PID(7)),COMP,1,5)
Begin DoDot:1
+71 IF $PIECE(ARRAY("MMN"),COMP)'=HL("Q")
SET HLECH=HL("ECH")
SET ARRAY("MMN")=$$FREE^RGRSPARS($$FMNAME^HLFNC(ARRAY("MMN")))
QUIT
+72 IF $PIECE(ARRAY("MMN"),COMP)=HL("Q")
SET ARRAY("MMN")=$$FREE^RGRSPARS($PIECE(ARRAY("MMN"),COMP))
End DoDot:1
+73 ;
+74 ;get PID-7 Date of Birth
+75 ;**47 taking HL("Q") into account
+76 IF $GET(PID(8))=HL("Q")
SET PID(8)="@"
SET ARRAY("MPIDOB")="@"
+77 IF $GET(PID(8))'="@"
SET ARRAY("MPIDOB")=$$FMDATE^HLFNC($GET(PID(8)))
+78 ;
+79 ;get PID-8 Sex
+80 ;**47 taking HL("Q") into account
+81 IF $GET(PID(9))=HL("Q")
SET PID(9)="@"
+82 SET ARRAY("SEX")=$GET(PID(9))
+83 ;
+84 ;get PID-11-3 ADDRESS BOTH "P"rimary and "N" Place of
+85 SET CNT=1
+86 NEW ADRTYPE,ADDR
+87 FOR X=1:1:$LENGTH(PID(12),REP)
Begin DoDot:1
+88 SET ADDR=$PIECE(PID(12),REP,X)
SET ADRTYPE=$PIECE(ADDR,COMP,7)
+89 IF ADRTYPE="P"
Begin DoDot:2
+90 SET ADDR=$$FREE^RGRSPARS(ADDR)
+91 ;addr [1]
SET ARRAY(.111)=$$FREE^RGRSPARS($PIECE(ADDR,COMP,1))
+92 ;addr [2]
SET ARRAY(.112)=$$FREE^RGRSPARS($PIECE(ADDR,COMP,2))
+93 ;addr [3]
SET ARRAY(.113)=$$FREE^RGRSPARS($PIECE(ADDR,COMP,8))
+94 ;city
SET ARRAY(.114)=$$FREE^RGRSPARS($PIECE(ADDR,COMP,3))
+95 ;state
SET ARRAY(.115)=$$STATE^RGRSPARS($PIECE(ADDR,COMP,4))
+96 ;zip+4
SET ARRAY(.1112)=$$FREE^RGRSPARS($PIECE(ADDR,COMP,5))
+97 ;county code
NEW CNTYCODE
SET CNTYCODE=PID(13)
+98 SET ARRAY(.117)=$$COUNTY^RGRSPARS(ARRAY(.115),CNTYCODE)
+99 SET ARRAY(.131)=$$FREE^RGRSPARS(PID(14))
+100 SET ARRAY(.132)=$$FREE^RGRSPARS(PID(15))
End DoDot:2
+101 IF ADRTYPE="N"
Begin DoDot:2
+102 ;POB city
SET ARRAY("POBCITY")=$$FREE^RGRSPARS($PIECE(ADDR,COMP,3))
+103 ;POB state
SET ARRAY("POBSTATE")=$$STATE^RGRSPARS($PIECE(ADDR,COMP,4))
End DoDot:2
End DoDot:1
+104 ;
+105 ;marital status
+106 SET ARRAY(.05)=$$MARITAL^RGRSPARS(PID(17))
+107 ;
+108 ;multiple birth indicator **47
+109 ;**47 to get MBI and setup as yes/no field change to @ if HL("Q")
SET ARRAY("MBI")=$GET(PID(25))
IF ARRAY("MBI")=HL("Q")
SET ARRAY("MBI")="@"
+110 ;
+111 ;;REMOVED FROM PATCH 45 DUE TO NEEDING DG707
+112 ;religious preference
+113 SET ARRAY(.08)=$$RELIG^RGRSPARS(PID(18))
+114 ;
+115 ;address
+116 ;
+117 ;get PID-29 Date of Death
+118 SET ARRAY("MPIDOD")=$$FREE^RGRSPARS($$FMDATE^HLFNC($GET(PID(30))))
SET ARRAY(.351)=ARRAY("MPIDOD")
+119 QUIT
+120 ;
IDSARR ;parse ids ;**61 MVI_2970 (dri)
+1 FOR X=1:1:LASTID
SET ID=$PIECE(IDS,REP,X)
Begin DoDot:1
+2 ;first repetition of continuation message already worked
IF IDSWKD=1
SET IDSWKD=0
QUIT
+3 ;if last repetition check for an extension of message
IF X=LASTID
IF $DATA(PID(4,A+1))
SET ID=ID_$PIECE(PID(4,A+1),REP,1)
SET IDSWKD=1
+4 ;get id, assigning authority, and name type code
+5 SET PIDAA=$PIECE($PIECE(ID,COMP,4),SUBCOMP)
SET PIDNTC=$PIECE(ID,COMP,5)
SET PIDSITE=$PIECE($PIECE(ID,COMP,6),SUBCOMP,2)
SET PIDXDT=$PIECE(ID,COMP,8)
+6 SET ID=$PIECE(ID,COMP)
+7 ;Q:ID="" **48
+8 ;check assigning authority(0363) AND name type code(0203)
+9 IF PIDAA="USVHA"
Begin DoDot:2
+10 IF PIDNTC="NI"
Begin DoDot:3
+11 ;National unique individual identifier
IF $GET(PIDXDT)=""
SET ARRAY("ICN")=ID
SET ARRAY("MPISSITE")=PIDSITE
SET ARRAY(991.02)=$PIECE(ID,"V",2)
+12 ;Deprecated National unique individual identifier
IF $GET(PIDXDT)'=""
SET ARRAY("OID",CNT)=ID_"^"_PIDAA_"^"_PIDSITE_"^"_PIDXDT
SET CNT=CNT+1
End DoDot:3
+13 ;Patient internal identifier
IF PIDNTC="PI"
SET ARRAY("DFN")=ID
SET ARRAY("DFNLOC")=PIDSITE
End DoDot:2
QUIT
+14 IF PIDAA="USSSA"
Begin DoDot:2
+15 ;Social Security number **44 (new) look out for alias ssns
IF PIDNTC="SS"
IF PIDXDT=""
SET ARRAY("SSN")=ID
IF ID=HL("Q")
SET ARRAY("SSN")="@"
+16 ;**48 store alias ssn
IF PIDNTC="SS"
IF PIDXDT'=""
SET $PIECE(ARRAY("ALIAS",ACNT),"^",2)=ID
SET ACNT=ACNT+1
+17 ;**47 includes HL("Q") check
End DoDot:2
QUIT
+18 IF PIDAA="USVBA"
Begin DoDot:2
+19 ;VBA CLAIM#
IF PIDNTC="PN"
SET ARRAY("CLAIMN")=ID
End DoDot:2
QUIT
+20 ;**59,MVI_880: Get TIN and FIN values
+21 IF PIDAA="USDOD"
Begin DoDot:2
+22 IF PIDNTC="TIN"
SET ARRAY("TIN")=$SELECT(ID=HL("Q"):"@",1:ID)
+23 IF PIDNTC="FIN"
SET ARRAY("FIN")=$SELECT(ID=HL("Q"):"@",1:ID)
End DoDot:2
QUIT
+24 ;**76, VAMPI-11120 (dri) Get ITIN value
+25 IF PIDAA="USIRS"
Begin DoDot:2
+26 IF PIDNTC="NI"
SET ARRAY("ITIN")=$SELECT(ID=HL("Q"):"@",1:ID)
End DoDot:2
QUIT
End DoDot:1
+27 QUIT
+28 ;
NAMARR ;parse legal and alias names ;**61 MVI_2970 (dri)
+1 FOR X=1:1:LASTNAM
SET NAME=$PIECE(NAMES,REP,X)
Begin DoDot:1
+2 ;first repetition of continuation message already worked
IF ALISWKD=1
SET ALISWKD=0
QUIT
+3 ;if last repetition check for an extension of message
IF X=LASTNAM
IF $DATA(PID(6,A+1))
SET NAME=NAME_$PIECE($GET(PID(6,A+1)),REP,1)
SET ALISWKD=1
+4 ;legal
IF $PIECE(NAME,COMP,7)="L"
Begin DoDot:2
+5 ;**71,Story 841921 (mko): Take into account two quotes -- convert to null
+6 SET ARRAY("SURNAME")=$$QTON($PIECE(NAME,COMP))
+7 SET ARRAY("FIRST")=$$QTON($PIECE(NAME,COMP,2))
+8 SET ARRAY("MIDDLE")=$$QTON($PIECE(NAME,COMP,3))
+9 SET ARRAY("PREFIX")=$$QTON($PIECE(NAME,COMP,5))
+10 SET ARRAY("SUFFIX")=$$QTON($PIECE(NAME,COMP,4))
+11 SET ARRAY("NAME")=$$FMNAME^HLFNC($PIECE(NAME,COMP,1,4))
End DoDot:2
QUIT
+12 ;**67 - Story 455458 (ckn) - Parse Preferred Name
+13 IF $PIECE(NAME,COMP,7)="N"
Begin DoDot:2
+14 NEW PNAME
+15 SET PNAME=$PIECE(NAME,COMP)
SET ARRAY("PREFERREDNAME")=$SELECT(PNAME=HL("Q"):"@",1:PNAME)
End DoDot:2
+16 ;**71,Story 841921 (mko): Put the name components into ARRAY("ALIAS",n,"NC")
+17 IF $PIECE(NAME,COMP,7)="A"
Begin DoDot:2
+18 NEW ALIASNC,ALIASNM
+19 SET ALIASNC=""
FOR I=1:1:4
SET ALIASNC=ALIASNC_$$QTON($PIECE(NAME,COMP,I))_COMP
+20 SET ALIASNC=$PIECE(ALIASNC,COMP,1,4)
SET ALIASNM=$$FMNAME^HLFNC(ALIASNC)
+21 IF $LENGTH(ALIASNM)>30
IF '$$GETFLAG^MPIFNAMC
Begin DoDot:3
+22 NEW ALIAS
+23 SET ALIAS("SURNAME")=$PIECE(ALIASNC,COMP)
+24 SET ALIAS("FIRST")=$PIECE(ALIASNC,COMP,2)
+25 SET ALIAS("MIDDLE")=$PIECE(ALIASNC,COMP,3)
+26 SET ALIAS("SUFFIX")=$PIECE(ALIASNC,COMP,4)
+27 SET ALIASNM=$$FMTNAME^RGADTP3(.ALIAS,30)
End DoDot:3
+28 SET $PIECE(ARRAY("ALIAS",IDCNT),"^")=ALIASNM
+29 SET ARRAY("ALIAS",IDCNT,"NC")=$TRANSLATE(ALIASNC,COMP,"^")
+30 ;**48 alias
SET IDCNT=IDCNT+1
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
QTON(X) ;**71,Story 841921 (mko): Convert two quotes to null
+1 QUIT $SELECT(X="""""":"",1:X)
+2 ;
