source: FOIAVistA/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPPRT2.m@ 1274

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

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1PPPPRT2 ;ALB/DMB/DAD - CLINIC MEDICATION PROFILE PRINT ROUTINE ; 3/12/92
2 ;;V1.0;PHARMACY PRESCRIPTION PRACTICE;**17**;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5START ;
6 N PPPARRY,PPPDOB,PPPNAME,PPPSSN,PPPTMP,BNR1,BNR2,BNR3,RSLTPTR,UNSPTR
7 N CLNPTEND,CLNPTST,CSCNEND,CSCNSTRT,DFNARRY,DIR,FFXIFN,I,IDX
8 N LKUPERR,NAMEARRY,ND,NODE,NODELEN,NOPRTFLG,OUT,PAGE,PAP,PATDFN
9 N PATDOB,PATNAME,PATNODE,PATSSN,PCP,PCPD,PDXNODE,PDXPTR,PDXSTAT
10 N PHRMARRY,POVNAME,POVNODE,PRMNODE0,SCANDT,TMP,TPATS,X,X1,X2,Y
11 N ZTQUEUED,ZTREQ
12 ;
13 S PPPMRT="START_PPPPRT2"
14 S LKUPERR=-9003
15 S CSCNSTRT=1006
16 S CSCNEND=1007
17 S CLNPTST=1014
18 S CLNPTEND=1015
19 S NOPRTFLG=1016
20 S PHRMARRY="^TMP(""PPP"","_$J_",""PHRM"")"
21 S DFNARRY="^TMP(""PPP"","_$J_",""DFN"")"
22 S NAMEARRY="^TMP(""PPP"","_$J_",""NAME"")"
23 S BNR1="PPP - Medication Profiles from other VAMC(s)"
24 S BNR2="Patient Medication Profiles For Clinics On "
25 S BNR3="Date Printed: "_$$DTE^PPPUTL1(DT,0)
26 S PAGE=0
27 S OUT=""
28 S RSLTPTR=$$GETSTPTR^PPPGET7("VAQ-RSLT")
29 S UNSPTR=$$GETSTPTR^PPPGET7("VAQ-UNSOL")
30 S TMP=$$LOGEVNT^PPPMSC1(CLNPTST,PPPMRT)
31 S PRMNODE0=$G(^PPP(1020.1,1,0))
32 I PRMNODE0="" D Q
33 .S TMP=$$LOGEVNT^PPPMSC1(LKUPERR,PPPMRT,"Parameter File Not Found")
34 S PCP=$P(PRMNODE0,"^",7)
35 S PAP=$P(PRMNODE0,"^",8)
36 S PCPD=$P(PRMNODE0,"^",10)
37 I 'PCP D Q
38 .S TMP=$$LOGEVNT^PPPMSC1(NOPRTFLG,PPPMRT)
39 ; Determine clinic scan date.
40 I +PCPD>0 D
41 .S X1=DT
42 .S X2=+PCPD
43 .D C^%DTC
44 .S SCANDT=X
45 E D
46 .S SCANDT=DT
47 S BNR2=BNR2_$$I2EDT^PPPCNV1(SCANDT)
48 ; Scan the clinics for patients scheduled on SCANDT
49 S TMP=$$LOGEVNT^PPPMSC1(CSCNSTRT,PPPMRT)
50 S TPATS=$$CLINSCAN^PPPSCN2(SCANDT,DFNARRY)
51 S TMP=$$LOGEVNT^PPPMSC1(CSCNEND,PPPMRT,"TOTAL PATIENTS = "_TPATS)
52 ; Now sort the clinic list by name
53 S TMP=$$NAMESRT^PPPPRT4(DFNARRY,NAMEARRY)
54 K @DFNARRY
55 ; Now order through the NAME's and get the data to print.
56 K @PHRMARRY
57 S PATNAME=""
58 F IDX=0:0 D Q:(PATNAME="")!(OUT["^")
59 .S PATNAME=$O(@NAMEARRY@(PATNAME)) Q:PATNAME=""
60 .F PATDFN=0:0 D Q:PATDFN=""
61 ..S PATDFN=$O(@NAMEARRY@(PATNAME,PATDFN)) Q:PATDFN=""
62 ..S PATNODE=$G(@NAMEARRY@(PATNAME,PATDFN))
63 ..S PATDOB=$P(PATNODE,"^",1)
64 ..S PATSSN=$P(PATNODE,"^",2)
65 ..F FFXIFN=0:0 D Q:FFXIFN=""
66 ...S FFXIFN=$O(^PPP(1020.2,"B",PATDFN,FFXIFN)) Q:FFXIFN=""
67 ...S PDXNODE=$G(^PPP(1020.2,FFXIFN,1)) Q:PDXNODE=""
68 ...S POVNODE=$G(^PPP(1020.2,FFXIFN,0)) Q:POVNODE=""
69 ...S PDXPTR=$P(PDXNODE,"^",1)
70 ...S PDXSTAT=$P(PDXNODE,"^",3)
71 ...S POVNUM=$P(POVNODE,"^",2)
72 ...I $D(^DIC(4,"D",POVNUM)) S POVIEN=$O(^DIC(4,"D",POVNUM,0)),POVNAME=$P($G(^DIC(4,POVIEN,0)),"^") K POVIEN
73 ...I '$D(POVNAME),$D(^PPP(1020.8,"B",POVNUM)) S POVIEN=$O(^PPP(1020.8,"B",POVNUM,0)),POVNAME=$P($P($G(^PPP(1020.8,POVIEN,0))<"^",2),".",1) K POVIEN
74 ...I '$D(POVNAME) S POVNAME=POVNUM_" (Unknown)"
75 ...I (PDXPTR) I ((PDXSTAT=RSLTPTR)!(PDXSTAT=UNSPTR)) I $$PDXDAT^PPPDSP2(PDXPTR) D
76 ....S PPPTMP(POVNAME,0)="1^"_PDXPTR_"^"_POVNUM
77 ..I PAP,($D(PPPTMP)) D
78 ...S TMP=$$GLPHRM^PPPGET8(PATDFN,PHRMARRY)
79 ..I $D(PPPTMP) D
80 ...S TMP=$$GETPDX^PPPGET2("PPPTMP",PHRMARRY)
81 ..; If there is anything to print... print it.
82 ..I $D(@PHRMARRY) D
83 ...S PPPNAME=PATNAME
84 ...S PPPDOB=PATDOB
85 ...S PPPSSN=PATSSN
86 ...S PAGE=PAGE+1 D HEADING1 Q:OUT["^" D NARRATIV
87 ...K @PHRMARRY,PPPTMP
88 I $E(IOST,1,2)="C-"&(OUT'["^") D
89 .W !!,"Listing Complete."
90 ; Log end of print utility
91 S TMP=$$LOGEVNT^PPPMSC1(CLNPTEND,PPPMRT)
92 K @PHRMARRY,@NAMEARRY
93 Q
94 ;
95HEADING1 ; Write the page heading, Pause if a crt.
96 ;
97 I PAGE>1,$E(IOST,1,2)="C-" D Q:OUT["^"
98 .S DIR(0)="E" D ^DIR
99 .I +Y=0 S OUT="^"
100 W @IOF,!
101 W ?((IOM-$L(BNR1))\2),BNR1,?(IOM-15),"Page ",PAGE,!
102 W ?((IOM-$L(BNR3))\2),BNR3,!!
103 W !,"Patient: ",PPPNAME_" ("_PPPSSN_")",?60,"DOB: ",PPPDOB
104 W ! F I=1:1:IOM W "="
105 Q
106 ;
107HEADING2 ; Write the page heading, Pause if a crt.
108 ;
109 I PAGE>1,($E(IOST,1,2)="C-"),($D(NARRATIV)) D Q:OUT["^"
110 .S DIR(0)="E" D ^DIR
111 .I +Y=0 S OUT="^"
112 W !,"RX #",?9,"DRUG",?41,"ST",?45,"QTY",?51,"ISSUED",?65,"LAST FILLED"
113 W ! F I=1:1:IOM W "="
114 Q
115 ;
116NARRATIV ; Print the narratives
117 ;
118 S NARRATIV=1
119 S STANAME=""
120 I $D(@PHRMARRY@(0)) D
121 .F S STANAME=$O(@PHRMARRY@(0,STANAME)) Q:STANAME=""!(OUT["^") D
122 ..I $Y+5>IOSL S PAGE=PAGE+1 D HEADING1 Q:OUT["^"
123 ..W !!,"NARRATIVE FROM ",STANAME
124 ..W !," => ",@PHRMARRY@(0,STANAME)
125 .W !
126 K NARRATIV
127 ;
128DRUGS I $Y+8<IOSL D HEADING2
129 S RVRSDT=0
130 F S RVRSDT=$O(@PHRMARRY@(RVRSDT)) Q:RVRSDT'>0!(OUT["^") D
131 .S STAPTR=""
132 .F S STAPTR=$O(@PHRMARRY@(RVRSDT,STAPTR)) Q:STAPTR=""!(OUT["^") D
133 ..S RXIDX=-1
134 ..F S RXIDX=$O(@PHRMARRY@(RVRSDT,STAPTR,RXIDX)) Q:RXIDX=""!(RXIDX="PID")!(OUT["^") D
135 ...I $Y+6>IOSL S PAGE=PAGE+1 D HEADING1 Q:OUT["^" D HEADING2
136 ...S ND=$G(@PHRMARRY@(RVRSDT,STAPTR,RXIDX)) Q:ND=""
137 ...W !!,$P(ND,"^"),?9,$E($P(ND,"^",2),1,30),?41,$E($P(ND,"^",3),1),?45,$P(ND,"^",4),?51,$$SLASHDT^PPPCNV1($P(ND,"^",5)),?65,$$SLASHDT^PPPCNV1($P(ND,"^",6))
138 ...W !,?9,"SIG: ",$E($P(ND,"^",7),1,25),?40,"ISSUED AT ",$P(ND,"^",8)," (",$P(ND,"^",9),")"
139 ...W !,?9,"PROVIDER: ",$P(ND,"^",10)
140 K @PHRMARRY
141 Q
Note: See TracBrowser for help on using the repository browser.