source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP1.m@ 1420

Last change on this file since 1420 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1RGADTP1 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;6/2/02
2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**26,27,42,45,44,47,48**;30 Apr 99;Build 3
3PIDP(MSG,ARRAY,HL) ;process PID segment
4 N ID,IDS,PIDAA,PIDNTC
5 ;Since PID can be over 245 characters loop through setting a PID ARRAY
6 ;sequenced PID(1)="PID"... PID(4 or 5) can be over 245 characters so
7 ;it will also loop and place it in PID(4,1...
8 ;
9 ; Input variables
10 ; assumes that MSG or MSG(I) will contain the PID segment
11 ; Output ARRAY ARRAY will contain the following subscripts
12 ; SSN - patient SSN
13 ; ICN - patient ICN
14 ; DFN - sites local identifier
15 ; MPISSITE - authoritative source (station# of sending site)
16 ; SEX - patient's SEX
17 ; MPIDOB - Date of Birth
18 ; NAME,SURNAME,FIRST,MIDDLE,PREFIX,and SUFFIX - Patient Name
19 ; MMN - Mother's maiden name
20 ; POBCITY, POBSTATE - Place of birth city and state
21 ;
22 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
23 S HLFS=HL("FS"),HLECH=HL("ECH")
24 S ARRAY("DFN")="",ARRAY("ICN")="",ARRAY("CLAIMN")="",ARRAY("SSN")="",ARRAY("ALIAS")=""
25 S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4),REP=$E(HL("ECH"),2)
26 S LNGTH=$L(MSG,HL("FS")) F SEQ=1:1:LNGTH S PID(SEQ)=$P(MSG,HL("FS"),SEQ)
27 S SEQ1=1,X=0 F S X=$O(MSG(X)) Q:'X S LNGTH=$L(MSG(X),HL("FS")) D
28 . F Y=1:1:LNGTH S:Y'=1 SEQ=SEQ+1 D
29 .. S NXT=$P(MSG(X),HL("FS"),Y) D
30 ... I $L($G(PID(SEQ)))=245 D Q
31 .... 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
32 .... I $L(NXT_$G(PID(SEQ,SEQ1)))'>245 S PID(SEQ,SEQ1)=$G(PID(SEQ,SEQ1))_NXT
33 ... 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
34 ... I $L(NXT_$G(PID(SEQ)))'>245 S PID(SEQ)=$G(PID(SEQ))_NXT Q
35 ;get PID-3 Patient Identifier List (three ids should be returned ICN, SSN, and DFN)
36 N LASTID,IDCNT,CNT,ACNT
37 S IDS=PID(4)
38 S LASTID=$L(IDS,REP),IDCNT=1,IDS=PID(4),CNT=1,ACNT=1
39 F X=1:1:LASTID S ID=$P(IDS,REP,X) D
40 .;if this is the last entry check for an extension of the message and reset the key variables
41 .I X=LASTID I $D(PID(4,IDCNT)) S ID=ID_$P(PID(4,IDCNT),REP),IDS=$P(PID(4,IDCNT),REP,2,99),IDCNT=IDCNT+1,X=0,LASTID=$L(IDS,REP)
42 . ;get id, assigning authority, and name type code
43 . 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)
44 . S ID=$P(ID,COMP)
45 . ;Q:ID="" **48
46 . ;check assigning authority(0363) AND name type code(0203)
47 . I PIDAA="USVHA" D
48 .. I PIDNTC="NI" D
49 ... I $G(PIDXDT)="" S ARRAY("ICN")=ID,ARRAY("MPISSITE")=PIDSITE,ARRAY(991.02)=$P(ID,"V",2) ;National unique individual identifier
50 ... I $G(PIDXDT)'="" S ARRAY("OID",CNT)=ID_"^"_PIDAA_"^"_PIDSITE_"^"_PIDXDT,CNT=CNT+1 ;Deprecated National unique individual identifier
51 .. I PIDNTC="PI" S ARRAY("DFN")=ID,ARRAY("DFNLOC")=PIDSITE ;Patient internal identifier
52 . I PIDAA="USSSA" D
53 .. 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
54 .. I PIDNTC="SS",PIDXDT'="" S $P(ARRAY("ALIAS",ACNT),"^",2)=ID,ACNT=ACNT+1 ;**48 store alias ssn
55 .. ;**47 includes HL("Q") check
56 . I PIDAA="USVBA" D
57 .. I PIDNTC="PN" S ARRAY("CLAIMN")=ID ;VBA CLAIM#
58 ;get PID-4 alternate ID (ICN History)
59 I $G(PID(5))'="" D
60 . S CNT=1
61 . F X=1:1:$L(PID(5),REP) S ARRAY("OID",CNT)=$P(PID(5),REP,X),CNT=CNT+1
62 . S Y=0 F S Y=$O(PID(5,Y)) Q:'Y D
63 .. S ARRAY("OID",CNT-1)=ARRAY("OID",CNT-1)_$P(PID(5,Y),REP)
64 .. F X=2:1:$L(PID(5,Y),REP) S ARRAY("OID",CNT)=$P(PID(5,Y),REP,X),CNT=CNT+1
65 . S X=0 F S X=$O(ARRAY("OID",X)) Q:'X D
66 .. 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)
67 .. S ARRAY("OID",X)=ID_"^"_AA_"^"_AL
68 ;get PID-5 Patient Name
69 N KK,JJ,TMPJ,IDCNT2 S IDCNT=1
70 I $G(PID(6))'="" F IDCNT2=1:1:$L(PID(6),REP) S NAME=$P(PID(6),REP,IDCNT2) D
71 .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
72 .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?
73 .;**48 alias could send PID(6) to second subscript level
74 .S KK=$O(PID(6,"")) I KK'="" S PID(6,KK)=$P(PID(6),REP,IDCNT2)_PID(6,KK)
75 .S JJ=0 F S JJ=$O(PID(6,JJ)) Q:'JJ D
76 ..I JJ'=KK S PID(6,JJ)=$P(PID(6,$O(PID(6,JJ),-1)),REP,TMPJ)_PID(6,JJ)
77 ..F TMPJ=1:1:$L(PID(6,JJ),REP) S NAME=$P(PID(6,JJ),REP,TMPJ) D
78 ...I $P(NAME,COMP,7)="A" S $P(ARRAY("ALIAS",IDCNT),"^")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)),IDCNT=IDCNT+1
79 ;get PID-6 Mother's maiden name
80 S ARRAY("MMN")=$P($G(PID(7)),COMP,1,5) D
81 . I $P(ARRAY("MMN"),COMP)'=HL("Q") S HLECH=HL("ECH") S ARRAY("MMN")=$$FREE^RGRSPARS($$FMNAME^HLFNC(ARRAY("MMN"))) Q
82 . I $P(ARRAY("MMN"),COMP)=HL("Q") S ARRAY("MMN")=$$FREE^RGRSPARS($P(ARRAY("MMN"),COMP))
83 ;get PID-7 Date of Birth
84 ;**47 taking HL("Q") into account
85 I $G(PID(8))=HL("Q") S PID(8)="@",ARRAY("MPIDOB")="@"
86 I $G(PID(8))'="@" S ARRAY("MPIDOB")=$$FMDATE^HLFNC($G(PID(8)))
87 ;get PID-8 Sex
88 ;**47 taking HL("Q") into account
89 I $G(PID(9))=HL("Q") S PID(9)="@"
90 S ARRAY("SEX")=$G(PID(9))
91 ;get PID-11-3 ADDRESS BOTH "P"rimary and "N" Place of
92 S CNT=1
93 N ADRTYPE,ADDR
94 F X=1:1:$L(PID(12),REP) D
95 . S ADDR=$P(PID(12),REP,X),ADRTYPE=$P(ADDR,COMP,7)
96 . I ADRTYPE="P" D
97 .. S ADDR=$$FREE^RGRSPARS(ADDR)
98 .. S ARRAY(.111)=$$FREE^RGRSPARS($P(ADDR,COMP,1)) ;addr [1]
99 .. S ARRAY(.112)=$$FREE^RGRSPARS($P(ADDR,COMP,2)) ;addr [2]
100 .. S ARRAY(.113)=$$FREE^RGRSPARS($P(ADDR,COMP,8)) ;addr [3]
101 .. S ARRAY(.114)=$$FREE^RGRSPARS($P(ADDR,COMP,3)) ;city
102 .. S ARRAY(.115)=$$STATE^RGRSPARS($P(ADDR,COMP,4)) ;state
103 .. S ARRAY(.1112)=$$FREE^RGRSPARS($P(ADDR,COMP,5)) ;zip+4
104 .. N CNTYCODE S CNTYCODE=PID(13) ;county code
105 .. S ARRAY(.117)=$$COUNTY^RGRSPARS(ARRAY(.115),CNTYCODE)
106 .. S ARRAY(.131)=$$FREE^RGRSPARS(PID(14))
107 .. S ARRAY(.132)=$$FREE^RGRSPARS(PID(15))
108 . I ADRTYPE="N" D
109 .. S ARRAY("POBCITY")=$$FREE^RGRSPARS($P(ADDR,COMP,3)) ;POB city
110 .. S ARRAY("POBSTATE")=$$STATE^RGRSPARS($P(ADDR,COMP,4)) ;POB state
111 ;marital status
112 S ARRAY(.05)=$$MARITAL^RGRSPARS(PID(17))
113 ;multiple birth indicator **47
114 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")
115 ;;REMOVED FROM PATCH 45 DUE TO NEEDING DG707
116 ;religious preference
117 S ARRAY(.08)=$$RELIG^RGRSPARS(PID(18))
118 ;address
119 ;get PID-29 Date of Death
120 S ARRAY("MPIDOD")=$$FREE^RGRSPARS($$FMDATE^HLFNC($G(PID(30)))),ARRAY(.351)=ARRAY("MPIDOD")
121 Q
Note: See TracBrowser for help on using the repository browser.