source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPD1.m@ 1520

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

initial load of WorldVistAEHR

File size: 1.7 KB
RevLine 
[613]1VAFHLPD1 ;ALB/RKS,PHH-HL7 PD1 SEGMENT; 26 July 01 ; 3/9/2004 2:09PM
2 ;;5.3;Registration;**91,160,229,149,409,389,568**;Jun 06, 1996
3 ;
4 ;
5EN(DFN,VAFSTR) ;Main enty point for building of PD1 Segment
6 ;
7 ;Input : DFN - Pointer to entry in PATIENT fiel (#2)
8 ; VAFSTR - String of fields requested separated by commas
9 ; All variables defined by call to INIT^HLFNC2()
10 ;Output : PD1 segment
11 ;
12 N FS,CS,SS,VAFPD1
13 S FS=HL("FS"),CS=$E(HL("ECH")),SS=$E(HL("ECH"),4)
14 I $G(DFN)="" Q "PD1"_FS
15 I $G(^DPT(DFN,0))="" Q "PD1"_FS
16 S:($G(VAFSTR)="") VAFSTR="3,4"
17 S VAFSTR=","_VAFSTR_","
18 S VAFPD1="PD1"_FS
19 ;Patient CMOR (as defined by CIRN)
20 I VAFSTR[",3,",('$D(^PPP(1020.128,"AC",$P($$SITE^VASITE,"^",3)))) D
21 . ;CIRN check
22 . I $T(CHANGE^MPIF001)']"" S $P(VAFPD1,FS,4)=HL("Q")_CS_CS_HL("Q") Q
23 . N DIC,DR,DA,DIQ,PTR4,SITENAME,SITENUM,PT,INST
24 . S (SITENAME,SITENUM)=""
25 . S DIC=2,DR="991.03",DA=DFN,DIQ="PT",DIQ(0)="IE"
26 . D EN^DIQ1
27 . S PTR4=$G(PT(2,DFN,991.03,"I"))
28 . ;IF CMOR DEFINED
29 . I PTR4]"" D
30 . . S DIC=4,DR="99",DA=PTR4,DIQ="INST",DIQ(0)="IE"
31 . . D EN^DIQ1
32 . . S SITENAME=$G(PT(2,DFN,991.03,"E"))
33 . . S SITENUM=$G(INST(4,PTR4,99,"E"))
34 . . Q
35 . S $P(VAFPD1,FS,4)=$$HLQ^VAFHUTL(SITENAME)_CS_CS_$$HLQ^VAFHUTL(SITENUM)
36 . Q
37 ;Primary Care Provider (as defined by PCMM)
38 I VAFSTR[",4," D
39 . N PTR200,VAFHLTMP,PCPRV,X
40 . ;Get provider (pointer to NEW PERSON file)
41 . S PTR200=+$$PCPRACT^DGSDUTL(DFN)
42 . I PTR200<1 S $P(VAFPD1,FS,5)=HL("Q") Q
43 . ;Get External Provider ID
44 . D PERSON^VAFHLRO3(PTR200,"VAFHLTMP",HL("Q"))
45 . I ('$D(VAFHLTMP)) S $P(VAFPD1,FS,5)=HL("Q") Q
46 . S PCPRV=VAFHLTMP(1,1,1)_SS_VAFHLTMP(1,1,2)
47 . F X=2:1:7 S $P(PCPRV,CS,X)=HL("Q")
48 . S $P(PCPRV,CS,8)=VAFHLTMP(1,8)
49 . S $P(VAFPD1,FS,5)=PCPRV
50 . Q
51 ;Done
52 Q VAFPD1
Note: See TracBrowser for help on using the repository browser.