source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPHL2.m@ 862

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

initial load of WorldVistAEHR
File size: 5.5 KB
RevLine 
[613]1PSOTPHL2 ;BPFO/EL-Query for patient demographics (ORIG: VAFCQRY1) ;09/10/2003 15:00
2 ;;7.0;OUTPATIENT PHARMACY;**146**;DEC 1997
3 ;
4 ;Reference to $$GETDFNS^MPIF002 supported by IA #3634.
5 ;
6BLDPID(DFN,CNT,PID,HL,ERR) ;build PID from File #2
7 N VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,PDOD,HIST,HISTDT,VAFCHMN,LVL,LVL1,NXT,LNGTH,NXTC,COMP,REP,SUBCOMP,LVL2,X,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,X,STATEIEN
8 S HLECH=HL("ECH"),HLFS=HL("FS"),HLQ=HL("Q")
9 S COMP=$E(HL("ECH"),1)
10 S SUBCOMP=$E(HL("ECH"),4)
11 S REP=$E(HL("ECH"),2)
12 ;get Patient File MPI node
13 S VAFCMN=$$MPINODE^MPIFAPI(DFN)
14 I +VAFCMN<0 S VAFCMN=""
15 S VAFCZN=^DPT(DFN,0)
16 S SSN=$P(^DPT(DFN,0),"^",9)
17 S SITE=$$SITE^VASITE
18 S APID(2)=CNT
19 ;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) AND DFN (PI)
20 S APID(4)=""
21 ;National Identifier (ICN)
22 I $G(VAFCMN)>0,($E($P(VAFCMN,"^"),1,3)'=$P($$SITE^VASITE,"^",3)) D
23 . S APID(4)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
24 I $G(SSN)'="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
25 I $G(DFN)'="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_DFN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" D
26 .;CLAIM#
27 .I $D(^DPT(DFN,.31)) S CLAIM=$P(^DPT(DFN,.31),"^",3) I +CLAIM>0 S APID(4)=APID(4)_REP_CLAIM_COMP_COMP_COMP_"USVBA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"PN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
28 ;
29 ;patient name (last^first^middle^suffix^prefix^^"L" for legal)
30 S APID(6)=$$HLNAME^XLFNAME($P(VAFCZN,"^"),"",$E(HL("ECH"),1)) I $P(APID(6),$E(HL("ECH"),1),7)'="L" S $P(APID(6),$E(HL("ECH"),1),7)="L"
31 ;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name)
32 S APID(7)=HL("Q")
33 I $D(^DPT(DFN,.24)) S VAFCMMN=$P(^DPT(DFN,.24),"^",3) D
34 . S APID(7)=$$HLNAME^XLFNAME(VAFCMMN,"",$E(HL("ECH"),1)) I APID(7)="" S APID(7)=HL("Q")
35 . I $P(APID(7),$E(HL("ECH"),1),7)'="M" S $P(APID(7),$E(HL("ECH"),1),7)="M"
36 S APID(8)=$$HLDATE^HLFNC($P(VAFCZN,"^",3)) ;date/time of birth
37 S APID(9)=$P(VAFCZN,"^",2) ;sex
38 ;place of birth city and state
39ADDR S APID(12)="" D
40 . I $D(^DPT(DFN,0)) D
41 .. ;address info
42 .. S $P(APID(12),COMP)=$$GET1^DIQ(2,DFN_",",.111) I $P(APID(12),COMP)="" S $P(APID(12),COMP)=HL("Q")
43 .. N LINE2 S LINE2=$$GET1^DIQ(2,DFN_",",.112) N LINE3 S LINE3=$$GET1^DIQ(2,DFN_",",.113)
44 .. S $P(APID(12),COMP,2)=LINE2 I $P(APID(12),COMP,2)="" S $P(APID(12),COMP,2)=HL("Q")
45 .. S $P(APID(12),COMP,8)=LINE3 I $P(APID(12),COMP,8)="" S $P(APID(12),COMP,8)=HL("Q")
46 .. S $P(APID(12),COMP,3)=$$GET1^DIQ(2,DFN_",",.114) I $P(APID(12),COMP,3)="" S $P(APID(12),COMP,3)=HL("Q")
47 .. S STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) S $P(APID(12),COMP,4)=$G(STATE) I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q")
48 .. S $P(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q")
49 .. S $P(APID(12),COMP,7)="P"
50 .. ;place of birth information
51 .. S CITY=$$GET1^DIQ(2,DFN_",",.092) D
52 ... I $G(CITY)'="" S $P(X,COMP,3)=CITY
53 ... I $G(CITY)="" S $P(X,COMP,3)=HL("Q")
54 ... S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
55 .... I $G(STATE)'="" S $P(X,COMP,4)=STATE
56 .... I $G(STATE)="" S $P(X,COMP,4)=HL("Q")
57 ... S $P(X,COMP,7)="N"
58 ... S APID(12)=$G(APID(12))_REP_X
59 S APID(13)=$$GET1^DIQ(2,DFN_",",.117) I APID(13)="" S APID(13)=HL("Q") ;county code
60 N PHONEN,HNUM,WNUM S PHONEN=$G(^DPT(DFN,.13)) S HNUM=$P(PHONEN,"^",1),WNUM=$P(PHONEN,"^",2)
61 S APID(14)=$$HLPHONE^HLFNC(HNUM)
62 S APID(15)=$$HLPHONE^HLFNC(WNUM)
63 D DEM^VADPT
64 S APID(17)="" I +VADM(10)>0 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),APID(17)=$S(X="N":"S",X="U":"",X="":HLQ,1:X) ;marital status (DHCP N=HL7 S, U="") ;**477
65 S APID(18)="" I +VADM(9)>0 S APID(18)=$P($G(^DIC(13,+VADM(9),0)),"^",4) I APID(18)="" S APID(18)=29 ;religious pref (if blank send 29 (UNKNOWN))
66 S APID(30)="" I $D(^DPT(DFN,.35)) S PDOD=$P(^DPT(DFN,.35),"^") S APID(30)=$$HLDATE^HLFNC(PDOD) ;date of death
67 N X F X=6,7,8,9,13,14,15,17,18,30 I APID(X)="" S APID(X)=HL("Q")
68 ;list of fields used for backwards compatibility with HDR
69 S APID(20)=SSN ;ssn passed in PID-3
70 S APID(24)=CITY_" "_STATE ;place of birth (not used) use PID-11 with an 'N' instead
71 ;list of fields not currently used or supported (# is 1 more than seq)
72 S APID(3)="" ;Patient ID
73 S APID(5)="" ;Alternate Patient Identifier
74 S APID(10)="" ;patient alias
75 S APID(11)="" ;race
76 S APID(16)="" ;primary language
77 S APID(19)="" ;patient account #
78 S APID(21)="" ;drivers lic #
79 S APID(22)="" ;mother's id
80 S APID(23)="" ;ethnic group
81 S APID(25)=""
82 S APID(26)=""
83 S APID(27)=""
84 S APID(28)=""
85 S APID(29)=""
86 S APID(31)=""
87 S PID(1)="PID"_HL("FS")
88 S LVL=1,X=1 F S X=$O(APID(X)) Q:'X D
89 . S PID(LVL)=$G(PID(LVL))
90 . S NXT=APID(X) D
91 .. I '$O(APID(X,0)) S NXT=NXT_HL("FS")
92 .. I $L($G(PID(LVL))_NXT)>245 S LNGTH=245-$L(PID(LVL)),PID(LVL)=PID(LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),LVL=LVL+1
93 .. I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
94 . S LVL2=0 F S LVL2=$O(APID(X,LVL2)) Q:'LVL2 D
95 .. S NXT=APID(X,LVL2) D
96 ... I $L($G(PID(LVL))_NXT)>245 S LNGTH=245-$L(PID(LVL)),PID(LVL)=PID(LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),LVL=LVL+1
97 ... I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
98 ... I '$O(APID(X,LVL2)) S PID(LVL)=PID(LVL)_HL("FS")
99 D KVA^VADPT
100 Q
Note: See TracBrowser for help on using the repository browser.