source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPDSP2.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PPPDSP2 ;ALB/DMB/DAD - PPP DISPLAY REOUTINES ;10-AUG-93
2 ;;V1.0;PHARMACY PRESCRIPTION PRACTICE;**17**;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DFL(PATDFN,TARRY,OPTIONS) ; Display Foreign Locations
6 ;
7 N FFXIFN,PARMERR,LKUPERR,DATAV,DATAVAIL,LDOV
8 N PDXDATE,PDXNODE,PDXPTR,PDXSTAT,PDXNAME,POVNODE,POVNUM,STOP
9 N VERBOSE,RXDAV,DIC,DA,DR,TMP,POVNAME,PATINFO,TITLINFO,I
10 ;
11 S PARMERR=-9001
12 S LKUPERR=-9003
13 S DATAVAIL=0
14 S VERBOSE=0
15 ;
16 I $G(OPTIONS)["V" S VERBOSE=1
17 ;
18 I '$D(^PPP(1020.2,"B",PATDFN)) Q PARMERR
19 ;
20 S DIC="^DPT(",DA=PATDFN,DR=".01;.03;.09",DIQ="PPPTMP" D EN^DIQ1
21 S $P(PATINFO,"^",2)=PPPTMP(2,PATDFN,.01)
22 S $P(PATINFO,"^",3)=$$E2IDT^PPPCNV1(PPPTMP(2,PATDFN,.03))
23 S $P(PATINFO,"^",4)=PPPTMP(2,PATDFN,.09)
24 K PPPTMP,DIC,DA,DR
25 S TITLINFO="^Name^DOB^SSN"
26 ;
27 I VERBOSE D
28 .W !!,"There are visits to other facilities indicated for:"
29 .W !,$P(PATINFO,"^",2)," (",$P(PATINFO,"^",4),") DOB: ",$$I2EDT^PPPCNV1($P(PATINFO,"^",3))
30 .W !!,"Station",?21,"Last PDX",?33,"PDX Status",?60,"Pharmacy Data"
31 ;
32 F FFXIFN=0:0 D Q:FFXIFN=""
33 .S FFXIFN=$O(^PPP(1020.2,"B",PATDFN,FFXIFN)) Q:FFXIFN=""
34 .S DATAV=0
35 .S PDXNODE=$G(^PPP(1020.2,FFXIFN,1))
36 .S POVNODE=$G(^PPP(1020.2,FFXIFN,0))
37 .S PDXPTR=$P(PDXNODE,"^",1) Q:PDXPTR=""
38 .Q:$P(PDXNODE,"^",3)=""
39 .S PDXSTAT=$$GETPDXST^PPPGET7(+$P(PDXNODE,"^",3))
40 .S PDXDATE=$$SLASHDT^PPPCNV1($P(PDXNODE,"^",2))
41 .S POVNUM=$P(POVNODE,"^",2)
42 .S POVIEN=$$GETSTANO^PPPGET1(POVNUM),POVNAME=$$GETDOMNM^PPPGET3(POVIEN),POVNAME=$P($G(POVNAME),".")
43 .I '$D(POVNAME) S POVNAME=POVNUM_" (Unknown)"
44 .S RXDAV=$$PDXDAT(PDXPTR)
45 .S TMP=$P(PDXSTAT,"^",1)
46 .I (+PDXPTR) I ((TMP'="VAQ-RSLT")&(TMP'="VAQ-UNSOL")) I ((+RXDAV)'<0) D
47 ..S DATAVAIL=1
48 ..S DATAV=1
49 ..S @TARRY@(PDXPTR)=POVNAME_"^"_POVNUM
50 .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"
51 .I VERBOSE D
52 ..F I=2:1:4 I $P(PATINFO,"^",I)'=$P(RXDAV,"^",I) D
53 ...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))
54 Q DATAVAIL
55 ;
56PDXDAT(PDXIFN) ; Is PDX Pharmacy Data Available?
57 ;
58 ; This function extracts the patient's name, DOB and a flag indicating
59 ; the presence of pharmacy data from the PDX Data file.
60 ;
61 ; The return format is:
62 ; PHARMACY_FLAG^NAME^DOB
63 ;
64 N RXAVAIL,PARMERR,FIELD,NODE,SEGPTR,NAME,DOB,DATAPTR,STOP,VALUE,SEQ
65 ;
66 S PARMERR=-9001
67 S RXAVAIL=0
68 ;CHECK INPUT
69 Q:((+$G(PDXIFN))<1) PARMERR
70 ;DETERMINE IF 'PDX*MPL' IS IN THE TRANSACTION
71 S SEGPTR=+$O(^VAT(394.71,"C","PDX*MPL",""))
72 Q:('SEGPTR) PARMERR
73 Q:('$D(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR))) PARMERR
74 ;DETERMINE IF AT LEAST ONE PRESCRIPTION IS IN 'PDX*MPL'
75 S DATAPTR=0
76 F S DATAPTR=+$O(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR,DATAPTR)) Q:('DATAPTR) D Q:(RXAVAIL)
77 .S NODE=$G(^VAT(394.62,DATAPTR,0))
78 .Q:(NODE="")
79 .Q:($P(NODE,"^",3)'=52)
80 .Q:($P(NODE,"^",4)'=.01)
81 .Q:($P($G(^VAT(394.62,DATAPTR,"VAL")),"^",1)="")
82 .;AT LEAST ONE RX PRESENT
83 .S RXAVAIL=1
84 ;GET PATIENT'S NAME & DOB IF AT LEAST ONE RX PRESENT
85 S NAME=""
86 S DOB=""
87 S SEGPTR=+$O(^VAT(394.71,"C","PDX*MIN",""))
88 Q:('SEGPTR) PARMERR
89 Q:('$D(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR))) PARMERR
90 S STOP=0
91 S DATAPTR=0
92 F S DATAPTR=+$O(^VAT(394.62,"A-SEGMENT",PDXIFN,SEGPTR,DATAPTR)) Q:('DATAPTR) D Q:(STOP=3)
93 .S NODE=$G(^VAT(394.62,DATAPTR,0))
94 .Q:(NODE="")
95 .Q:($P(NODE,"^",3)'=2)
96 .S FIELD=$P(NODE,"^",4)
97 .Q:((FIELD'=.01)&(FIELD'=.03))
98 .S VALUE=$P($G(^VAT(394.62,DATAPTR,"VAL")),"^",1)
99 .;ONLY TAKE FIRST OCCURENCE OF NAME/DOB (SEQUENCE NUMBER EQUALS 0)
100 .S SEQ=$P($G(^VAT(394.62,DATAPTR,"SQNCE")),"^",1)
101 .Q:(SEQ'=0)
102 .;SET APPROPRIATE VALUE
103 .I (FIELD=.01) D
104 ..S NAME=VALUE
105 ..S STOP=STOP+1
106 .I (FIELD=.03) D Q
107 ..;CONVERT DOB TO FILEMAN FORMAT
108 ..S DOB=$$E2IDT^PPPCNV1(VALUE)
109 ..S:(DOB="-1") DOB=""
110 ..S STOP=STOP+2
111 ;RETURN VALUES
112 Q (RXAVAIL_"^"_NAME_"^"_DOB)
Note: See TracBrowser for help on using the repository browser.