source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPPDX3.m@ 1006

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

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1PPPPDX3 ;ALB/DMB/DAD - ppp pdx routines ; 6/30/92
2 ;;1.0;PHARMACY PRESCRIPTION PRACTICE;**1,2,21,32,39**;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PDXFFX(SSN,DOMAIN) ; Get the FFX IFN or create a new entry for PDX
6 ;
7 ; This function is called by the PDX trigger to lookup or create
8 ; an entry in the foreign facility cross-reference.
9 ;
10 ; Parameters:
11 ; SSN - The Patient SSN
12 ; DOMAIN - The Domain name the patient visited
13 ;
14 ; Returns:
15 ; Normal Termination - The Internal File Number of the entry.
16 ; Error - -9002 = could not find SSN in patient file or Domain
17 ; name.
18 ; -9003 = An error occurred while creating the new entry.
19 ;
20 N LKUPERR,FMERR,ERR,PATDFN,SNIFN,FFXIFN,X,DIC,Y,DA,HDRNODE
21 N TRECS,U,NEWREC
22 ;
23 S LOCKERR=-9004
24 S LKUPERR=-9003
25 S FMERR=-9002
26 S ERR=0
27 S U="^"
28 ;
29 ; -- Check Input
30 Q:'$D(DOMAIN) FMERR
31 Q:DOMAIN="" FMERR
32 Q:'$D(^PPP(1020.8,"C",DOMAIN)) FMERR
33 ;
34 ; Look up the patient IFN
35 ;
36 S PATDFN=$O(^DPT("SSN",SSN,""))
37 S:PATDFN<1 ERR=LKUPERR
38 ;PPP*1*32 (Dave B - Check B & C xref for domain name)
39 S SNIFN=$$FIND1^DIC(4.2,"","MX",DOMAIN,"B^C","","EMSG")
40 S SNIFN=+$P(^DIC(4.2,SNIFN,0),"^",13)
41 ;VMP OIFO BAY PINES;VGF;PPP*1.0*39
42 S SNIFN=$O(^DIC(4,"D",SNIFN,0))
43 S:SNIFN<1 ERR=LKUPERR
44DAVE ;
45 ; If the INPUTS are good then see if there is an entry in the FFX file.
46 I 'ERR D
47 .S FFXIFN=$O(^PPP(1020.2,"AC",PATDFN,DOMAIN,""))
48 .;
49 .; If the entry isn't there then create a new one
50 .;
51 .I FFXIFN'>0 D
52 ..S X=PATDFN
53 ..S DIC="^PPP(1020.2,"
54 ..S DLAYGO="1020.2"
55 ..S DIC(0)="L"
56 ..S DIC("DR")="1////"_SNIFN_";7////0;8////"_$G(DT)
57 ..K DD,DO D FILE^DICN K DIC,DLAYGO,DO,DD
58 ..;(PPP*1*32 Fix Quit without return value on next line - Dave B)
59 ..I $P(Y,U,3)'=1 S ERR=LKUPERR
60 Q:ERR ERR
61 Q $P(Y,U,1)
Note: See TracBrowser for help on using the repository browser.