76 lines
2.5 KiB
Mathematica
76 lines
2.5 KiB
Mathematica
PPPFMX2 ;ALB/JP - FILEMAN UTILITIES FOR PPP;10-AUG-93
|
|
;;V1.0;PHARMACY PRESCRIPTION PRACTICE;**1**;APR 7,1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
PDXTRIG(TRANPTR,MODE) ;SET/KILL 'LOGIC' FOR PDX TRIGGER
|
|
;Input : TRANPTR - Pointer to VAQ - TRANSACTION file
|
|
; MODE - Which 'logic' to use (SET or KILL)
|
|
; 1 = SET (default)
|
|
; 0 = KILL
|
|
N SSN,FACILNO,DOMAIN,DATE,STATUS,FFPTR,TMP,STATPTR,NODE,SEGPTR,HASMPL
|
|
; -- CHECK INPUT
|
|
Q:('$G(TRANPTR))
|
|
Q:('$D(^VAT(394.61,TRANPTR)))
|
|
S MODE=$G(MODE)
|
|
S MODE=$S((MODE=""):1,(MODE=0):0,1:1)
|
|
; -- GET CURRENT STATUS OF TRANSACTION (POINTER AND VALUE)
|
|
S TMP=$G(^VAT(394.61,TRANPTR,0))
|
|
S STATPTR=+$P(TMP,"^",2)
|
|
Q:('STATPTR)
|
|
S STATUS=$P($$GETPDXST^PPPGET7(STATPTR),"^",1)
|
|
; -- ONLY ACT ON RESULTS TO A REQUEST AND UNSOLICITED PDXs
|
|
S TMP="^VAQ-AMBIG^VAQ-NTFND^VAQ-REJ^VAQ-RSLT^VAQ-UNSOL^"
|
|
Q:(TMP'[("^"_STATUS_"^"))
|
|
; -- DETERMINE IF TRANSACTION HAS SEGMENT 'PDX*MPL' (MED PROFILE LONG)
|
|
S SEGPTR=+$O(^VAT(394.71,"C","PDX*MPL",""))
|
|
Q:('SEGPTR)
|
|
S HASMPL=+$O(^VAT(394.61,TRANPTR,"SEG","B",SEGPTR,""))
|
|
; -- GET DATE
|
|
S TMP=$G(^VAT(394.61,TRANPTR,"ATHR1"))
|
|
S DATE=+$P(TMP,"^",1)
|
|
Q:(('DATE)&(MODE))
|
|
; -- GET REMOTE FACILITY NUMBER
|
|
S TMP=$G(^VAT(394.61,TRANPTR,"ATHR2"))
|
|
S DOMAIN=$P(TMP,"^",2)
|
|
Q:(DOMAIN="")
|
|
S FACILNO=+$O(^PPP(1020.8,"C",DOMAIN,""))
|
|
Q:('FACILNO)
|
|
; -- GET PATIENT'S SSN
|
|
S SSN=$P($G(^VAT(394.61,TRANPTR,"QRY")),"^",2)
|
|
Q:(SSN="")
|
|
; -- GET POINTER TO PATIENT FILE
|
|
S PATPTR=+$O(^DPT("SSN",SSN,""))
|
|
Q:('PATPTR)
|
|
; -- Check for FFX entry or creates new one, on set logic
|
|
I ($D(^PPP(1020.2,"AC",PATPTR,DOMAIN))=0)&(MODE=1) D QUIT
|
|
.S FFPTR=$$PDXFFX^PPPPDX3(SSN,DOMAIN)
|
|
.D SETKILL
|
|
; -- GET POINTER TO FOREIGN FACILITY FILE
|
|
S FFPTR=""
|
|
F S FFPTR=$O(^PPP(1020.2,"AC",PATPTR,DOMAIN,FFPTR)) Q:FFPTR="" D SETKILL
|
|
Q
|
|
SETKILL ; -- UPDATES PPP ENTRY WITH PDX POINTER or deletes it
|
|
; - Get node from FOREIGN FACILITY XREF File
|
|
Q:(FFPTR<0)
|
|
S NODE=$G(^PPP(1020.2,FFPTR,1))
|
|
; -- SET 'LOGIC'
|
|
SET I (MODE) D
|
|
.; - Don't store if transaction does NOT contain segment 'PDX*MPL'
|
|
.Q:('HASMPL)
|
|
.; - STORE POINTER TO PDX TRANSACTION FILE
|
|
.S $P(NODE,"^",1)=TRANPTR
|
|
.; - STORE DATE OF TRANSACTION
|
|
.S $P(NODE,"^",2)=DATE
|
|
.; - STORE STATUS OF TRANSACTION
|
|
.S $P(NODE,"^",3)=STATPTR
|
|
; -- KILL 'LOGIC'
|
|
KILL I ('MODE) D
|
|
.; - ONLY DELETE IF SAME TRANSACTION
|
|
.Q:((+$P(NODE,"^",1))'=TRANPTR)
|
|
.; - DELETE POINTER TO PDX TRANSACTION FILE
|
|
.S $P(NODE,"^",1)=""
|
|
.S $P(NODE,"^",2)=""
|
|
.S $P(NODE,"^",3)=""
|
|
; -- SAVE NODE FROM FOREIGN FACILITY XREF FILE
|
|
S ^PPP(1020.2,FFPTR,1)=NODE
|
|
Q
|