113 lines
3.8 KiB
Mathematica
113 lines
3.8 KiB
Mathematica
PPPDSP2 ;ALB/DMB/DAD - PPP DISPLAY REOUTINES ;10-AUG-93
|
|
;;V1.0;PHARMACY PRESCRIPTION PRACTICE;**17**;APR 7,1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
DFL(PATDFN,TARRY,OPTIONS) ; Display Foreign Locations
|
|
;
|
|
N FFXIFN,PARMERR,LKUPERR,DATAV,DATAVAIL,LDOV
|
|
N PDXDATE,PDXNODE,PDXPTR,PDXSTAT,PDXNAME,POVNODE,POVNUM,STOP
|
|
N VERBOSE,RXDAV,DIC,DA,DR,TMP,POVNAME,PATINFO,TITLINFO,I
|
|
;
|
|
S PARMERR=-9001
|
|
S LKUPERR=-9003
|
|
S DATAVAIL=0
|
|
S VERBOSE=0
|
|
;
|
|
I $G(OPTIONS)["V" S VERBOSE=1
|
|
;
|
|
I '$D(^PPP(1020.2,"B",PATDFN)) Q PARMERR
|
|
;
|
|
S DIC="^DPT(",DA=PATDFN,DR=".01;.03;.09",DIQ="PPPTMP" D EN^DIQ1
|
|
S $P(PATINFO,"^",2)=PPPTMP(2,PATDFN,.01)
|
|
S $P(PATINFO,"^",3)=$$E2IDT^PPPCNV1(PPPTMP(2,PATDFN,.03))
|
|
S $P(PATINFO,"^",4)=PPPTMP(2,PATDFN,.09)
|
|
K PPPTMP,DIC,DA,DR
|
|
S TITLINFO="^Name^DOB^SSN"
|
|
;
|
|
I VERBOSE D
|
|
.W !!,"There are visits to other facilities indicated for:"
|
|
.W !,$P(PATINFO,"^",2)," (",$P(PATINFO,"^",4),") DOB: ",$$I2EDT^PPPCNV1($P(PATINFO,"^",3))
|
|
.W !!,"Station",?21,"Last PDX",?33,"PDX Status",?60,"Pharmacy Data"
|
|
;
|
|
F FFXIFN=0:0 D Q:FFXIFN=""
|
|
.S FFXIFN=$O(^PPP(1020.2,"B",PATDFN,FFXIFN)) Q:FFXIFN=""
|
|
.S DATAV=0
|
|
.S PDXNODE=$G(^PPP(1020.2,FFXIFN,1))
|
|
.S POVNODE=$G(^PPP(1020.2,FFXIFN,0))
|
|
.S PDXPTR=$P(PDXNODE,"^",1) Q:PDXPTR=""
|
|
.Q:$P(PDXNODE,"^",3)=""
|
|
.S PDXSTAT=$$GETPDXST^PPPGET7(+$P(PDXNODE,"^",3))
|
|
.S PDXDATE=$$SLASHDT^PPPCNV1($P(PDXNODE,"^",2))
|
|
.S POVNUM=$P(POVNODE,"^",2)
|
|
.S POVIEN=$$GETSTANO^PPPGET1(POVNUM),POVNAME=$$GETDOMNM^PPPGET3(POVIEN),POVNAME=$P($G(POVNAME),".")
|
|
.I '$D(POVNAME) S POVNAME=POVNUM_" (Unknown)"
|
|
.S RXDAV=$$PDXDAT(PDXPTR)
|
|
.S TMP=$P(PDXSTAT,"^",1)
|
|
.I (+PDXPTR) I ((TMP'="VAQ-RSLT")&(TMP'="VAQ-UNSOL")) I ((+RXDAV)'<0) D
|
|
..S DATAVAIL=1
|
|
..S DATAV=1
|
|
..S @TARRY@(PDXPTR)=POVNAME_"^"_POVNUM
|
|
.I VERBOSE W !,$E(POVNAME,1,20),?21,$S(PDXDATE=-1:"UNKNOWN",1:PDXDATE),?33,$E($P(PDXSTAT,"^",2),1,25),?60,$S(DATAV=1:"",1:"NOT "),"AVAILABLE"
|
|
.I VERBOSE D
|
|
..F I=2:1:4 I $P(PATINFO,"^",I)'=$P(RXDAV,"^",I) D
|
|
...W !," Warning... Local ",$P(TITLINFO,"^",I)," Does Not Equal PDX ",$P(TITLINFO,"^",I)," ==> ",$S(I=3:$$I2EDT^PPPCNV1($P(RXDAV,"^",I)),1:$P(RXDAV,"^",I))
|
|
Q DATAVAIL
|
|
;
|
|
PDXDAT(PDXIFN) ; Is PDX Pharmacy Data Available?
|
|
;
|
|
; This function extracts the patient's name, DOB and a flag indicating
|
|
; the presence of pharmacy data from the PDX Data file.
|
|
;
|
|
; The return format is:
|
|
; PHARMACY_FLAG^NAME^DOB
|
|
;
|
|
N RXAVAIL,PARMERR,FIELD,NODE,SEGPTR,NAME,DOB,DATAPTR,STOP,VALUE,SEQ
|
|
;
|
|
S PARMERR=-9001
|
|
S RXAVAIL=0
|
|
;CHECK INPUT
|
|
Q:((+$G(PDXIFN))<1) PARMERR
|
|
;DETERMINE IF 'PDX*MPL' IS IN THE TRANSACTION
|
|
S SEGPTR=+$O(^VAT(394.71,"C","PDX*MPL",""))
|
|
Q:('SEGPTR) PARMERR
|
|
Q:('$D(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR))) PARMERR
|
|
;DETERMINE IF AT LEAST ONE PRESCRIPTION IS IN 'PDX*MPL'
|
|
S DATAPTR=0
|
|
F S DATAPTR=+$O(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR,DATAPTR)) Q:('DATAPTR) D Q:(RXAVAIL)
|
|
.S NODE=$G(^VAT(394.62,DATAPTR,0))
|
|
.Q:(NODE="")
|
|
.Q:($P(NODE,"^",3)'=52)
|
|
.Q:($P(NODE,"^",4)'=.01)
|
|
.Q:($P($G(^VAT(394.62,DATAPTR,"VAL")),"^",1)="")
|
|
.;AT LEAST ONE RX PRESENT
|
|
.S RXAVAIL=1
|
|
;GET PATIENT'S NAME & DOB IF AT LEAST ONE RX PRESENT
|
|
S NAME=""
|
|
S DOB=""
|
|
S SEGPTR=+$O(^VAT(394.71,"C","PDX*MIN",""))
|
|
Q:('SEGPTR) PARMERR
|
|
Q:('$D(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR))) PARMERR
|
|
S STOP=0
|
|
S DATAPTR=0
|
|
F S DATAPTR=+$O(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR,DATAPTR)) Q:('DATAPTR) D Q:(STOP=3)
|
|
.S NODE=$G(^VAT(394.62,DATAPTR,0))
|
|
.Q:(NODE="")
|
|
.Q:($P(NODE,"^",3)'=2)
|
|
.S FIELD=$P(NODE,"^",4)
|
|
.Q:((FIELD'=.01)&(FIELD'=.03))
|
|
.S VALUE=$P($G(^VAT(394.62,DATAPTR,"VAL")),"^",1)
|
|
.;ONLY TAKE FIRST OCCURENCE OF NAME/DOB (SEQUENCE NUMBER EQUALS 0)
|
|
.S SEQ=$P($G(^VAT(394.62,DATAPTR,"SQNCE")),"^",1)
|
|
.Q:(SEQ'=0)
|
|
.;SET APPROPRIATE VALUE
|
|
.I (FIELD=.01) D
|
|
..S NAME=VALUE
|
|
..S STOP=STOP+1
|
|
.I (FIELD=.03) D Q
|
|
..;CONVERT DOB TO FILEMAN FORMAT
|
|
..S DOB=$$E2IDT^PPPCNV1(VALUE)
|
|
..S:(DOB="-1") DOB=""
|
|
..S STOP=STOP+2
|
|
;RETURN VALUES
|
|
Q (RXAVAIL_"^"_NAME_"^"_DOB)
|