source: FOIAVistA/tag/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPDSP2.m@ 628

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)