source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPFMX2.m@ 1639

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1PPPFMX2 ;ALB/JP - FILEMAN UTILITIES FOR PPP;10-AUG-93
2 ;;V1.0;PHARMACY PRESCRIPTION PRACTICE;**1**;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4PDXTRIG(TRANPTR,MODE) ;SET/KILL 'LOGIC' FOR PDX TRIGGER
5 ;Input : TRANPTR - Pointer to VAQ - TRANSACTION file
6 ; MODE - Which 'logic' to use (SET or KILL)
7 ; 1 = SET (default)
8 ; 0 = KILL
9 N SSN,FACILNO,DOMAIN,DATE,STATUS,FFPTR,TMP,STATPTR,NODE,SEGPTR,HASMPL
10 ; -- CHECK INPUT
11 Q:('$G(TRANPTR))
12 Q:('$D(^VAT(394.61,TRANPTR)))
13 S MODE=$G(MODE)
14 S MODE=$S((MODE=""):1,(MODE=0):0,1:1)
15 ; -- GET CURRENT STATUS OF TRANSACTION (POINTER AND VALUE)
16 S TMP=$G(^VAT(394.61,TRANPTR,0))
17 S STATPTR=+$P(TMP,"^",2)
18 Q:('STATPTR)
19 S STATUS=$P($$GETPDXST^PPPGET7(STATPTR),"^",1)
20 ; -- ONLY ACT ON RESULTS TO A REQUEST AND UNSOLICITED PDXs
21 S TMP="^VAQ-AMBIG^VAQ-NTFND^VAQ-REJ^VAQ-RSLT^VAQ-UNSOL^"
22 Q:(TMP'[("^"_STATUS_"^"))
23 ; -- DETERMINE IF TRANSACTION HAS SEGMENT 'PDX*MPL' (MED PROFILE LONG)
24 S SEGPTR=+$O(^VAT(394.71,"C","PDX*MPL",""))
25 Q:('SEGPTR)
26 S HASMPL=+$O(^VAT(394.61,TRANPTR,"SEG","B",SEGPTR,""))
27 ; -- GET DATE
28 S TMP=$G(^VAT(394.61,TRANPTR,"ATHR1"))
29 S DATE=+$P(TMP,"^",1)
30 Q:(('DATE)&(MODE))
31 ; -- GET REMOTE FACILITY NUMBER
32 S TMP=$G(^VAT(394.61,TRANPTR,"ATHR2"))
33 S DOMAIN=$P(TMP,"^",2)
34 Q:(DOMAIN="")
35 S FACILNO=+$O(^PPP(1020.8,"C",DOMAIN,""))
36 Q:('FACILNO)
37 ; -- GET PATIENT'S SSN
38 S SSN=$P($G(^VAT(394.61,TRANPTR,"QRY")),"^",2)
39 Q:(SSN="")
40 ; -- GET POINTER TO PATIENT FILE
41 S PATPTR=+$O(^DPT("SSN",SSN,""))
42 Q:('PATPTR)
43 ; -- Check for FFX entry or creates new one, on set logic
44 I ($D(^PPP(1020.2,"AC",PATPTR,DOMAIN))=0)&(MODE=1) D QUIT
45 .S FFPTR=$$PDXFFX^PPPPDX3(SSN,DOMAIN)
46 .D SETKILL
47 ; -- GET POINTER TO FOREIGN FACILITY FILE
48 S FFPTR=""
49 F S FFPTR=$O(^PPP(1020.2,"AC",PATPTR,DOMAIN,FFPTR)) Q:FFPTR="" D SETKILL
50 Q
51SETKILL ; -- UPDATES PPP ENTRY WITH PDX POINTER or deletes it
52 ; - Get node from FOREIGN FACILITY XREF File
53 Q:(FFPTR<0)
54 S NODE=$G(^PPP(1020.2,FFPTR,1))
55 ; -- SET 'LOGIC'
56SET I (MODE) D
57 .; - Don't store if transaction does NOT contain segment 'PDX*MPL'
58 .Q:('HASMPL)
59 .; - STORE POINTER TO PDX TRANSACTION FILE
60 .S $P(NODE,"^",1)=TRANPTR
61 .; - STORE DATE OF TRANSACTION
62 .S $P(NODE,"^",2)=DATE
63 .; - STORE STATUS OF TRANSACTION
64 .S $P(NODE,"^",3)=STATPTR
65 ; -- KILL 'LOGIC'
66KILL I ('MODE) D
67 .; - ONLY DELETE IF SAME TRANSACTION
68 .Q:((+$P(NODE,"^",1))'=TRANPTR)
69 .; - DELETE POINTER TO PDX TRANSACTION FILE
70 .S $P(NODE,"^",1)=""
71 .S $P(NODE,"^",2)=""
72 .S $P(NODE,"^",3)=""
73 ; -- SAVE NODE FROM FOREIGN FACILITY XREF FILE
74 S ^PPP(1020.2,FFPTR,1)=NODE
75 Q
Note: See TracBrowser for help on using the repository browser.