| 1 | PPPFMX2 ;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.
|
|---|
| 4 | PDXTRIG(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
|
|---|
| 51 | SETKILL ; -- 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'
|
|---|
| 56 | SET 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'
|
|---|
| 66 | KILL 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
|
|---|
