- 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 Jan 18, 2025@02:42:38 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 ;