source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOQMCAL.m@ 969

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PSOQMCAL ; SEA/HAM3 PMI - PHARMACY MEDICATION INSTRUCTION ; 30 Nov 2007 7:55 AM
2 ;;7.0;OUTPATIENT PHARMACY;**294**;DEC 1997;Build 13
3 ;
4 ;Reference to CKP^GMTSUP supported by DBIA 4231
5 ;Reference to COVER^ORWPS supported by DBIA 4954
6 ;Credit to Herb Morriss and Al Hernandez for the original design
7 ;Puget Sound Health Care System, Seattle WA
8EN N PSOQPEND,DAYSEP,DRUGHDR1,DRUGHDR2,DRUGSEP,INSTSEP1,INSTSEP2,INSTSEP3
9 N EMPTYLN,PRETYPE,SUPTYPE,ADDR,AL,ALFLAG,ARLDASH
10 N ARLDATE,ARLDFN,ARLDOB,ARLNAME,ARLSITE,ARLSN
11 N BLANKLN,BLNKLN,DRUG1,FOOD,GMRAL,IDRUG,ISIG,ITYPE
12 N NVA,NONE,PAGE,PGWIDTH,PGLENGTH,PHONE
13 N RXIEN,SIGCNT,SIGPOS,XPOS1,XPOS2,XPOS3,XPOS4
14 N FN,HP,IA,RPTDATE,TYPE,WP,ST,SUPCNT,SUPDRUG,X,X1,X2,ADDRFL
15 N DIWF,DIWL,DIWR,INSTSEP1,INSTSEP2,INSTSEP3,DRUGHDR1,DRUGHDR2,DRUGSEP
16 S PGWIDTH=IOM-5,PGLENGTH=IOSL-9
17 Q:PGWIDTH<48 ;ensure that the IOM variable is wide enough
18 S RPTDATE=$$FMTE^XLFDT($$NOW^XLFDT,"1D")
19 S XPOS1=(PGWIDTH-26)\2 ;title
20 S XPOS2=PGWIDTH-6 ;page number
21 S XPOS3=(PGWIDTH-29)\2 ;site
22 S XPOS4=(PGWIDTH-53)\2 ;refill info
23 S BLANKLN="",$P(BLNKLN," ",PGWIDTH)=" "
24 S EMPTYLN="!,""|"_$E(BLNKLN,1,PGWIDTH-2)_"|"""
25 S DAYSEP="| | | | |"
26 S DRUGHDR1="| |MORNING| NOON |EVENING|BEDTIME| COMMENTS"
27 S DRUGHDR1=DRUGHDR1_$E(BLNKLN,$L(DRUGHDR1),PGWIDTH-2)_"|"
28 S DRUGHDR2="| "_DAYSEP
29 S DRUGHDR2=DRUGHDR2_$E(BLNKLN,$L(DRUGHDR2),PGWIDTH-2)_"|"
30 S $P(DRUGSEP,"~",PGWIDTH-2)="~"
31 S DRUGSEP="|"_DRUGSEP_"|"
32 S $P(INSTSEP1,"-",PGWIDTH-2)="-"
33 S INSTSEP1="|"_INSTSEP1_"|"
34 S INSTSEP2="| UNITS PER DOSE: "_DAYSEP
35 S INSTSEP2=INSTSEP2_$E(BLNKLN,$L(INSTSEP2),PGWIDTH-2)_"|"
36 S INSTSEP3="| "_DAYSEP
37 S INSTSEP3=INSTSEP3_$E(BLNKLN,$L(INSTSEP3),PGWIDTH-2)_"|"
38 S X1=DT,X2=-45 D C^%DTC S ARLDATE=X
391 ;Patient
40 S ARLDFN=""
41 F IA=1:1 S ARLDFN=$P(ARLPAT,";",IA) Q:ARLDFN="" D
42 . S PAGE=1
43 . D HD,SHOW(ARLDFN)
44 Q
45SHOW(PTIEN) ;
46 N LIST,NVA
47 D COVER^ORWPS(.LIST,PTIEN)
48 D GETOPORD(.LIST)
49 D GETRXDAT(.LIST)
50 S SUPTYPE=0,PRETYPE="D"
51 S ITYPE="@"
52 F S ITYPE=$O(LIST(ITYPE)) Q:ITYPE]"ZZZ" Q:ITYPE="" D
53 . I PRETYPE'=ITYPE D
54 . . W !,DRUGSEP
55 . . W @EMPTYLN
56 . . W !,"|","SUPPLY ITEMS:"_$E(BLNKLN,14,PGWIDTH-2)_"|"
57 . . S PRETYPE=ITYPE
58 . . I (ITYPE="S")&(SUPTYPE=0) D
59 . . . S SUPTYPE=1,SUPCNT=0,SUPDRUG=""
60 . . . F S SUPDRUG=$O(LIST(ITYPE,SUPDRUG)) Q:SUPDRUG="" D
61 . . . . S SUPCNT=SUPCNT+1
62 . . . I $Y>(PGLENGTH-SUPCNT) W !,DRUGSEP,@IOF D HD3
63 . S IDRUG=""
64 . F S IDRUG=$O(LIST(ITYPE,IDRUG)) Q:IDRUG="" D
65 . . I 'SUPTYPE D
66 . . S SIGCNT=0,SIGPOS=""
67 . . F S SIGPOS=$O(LIST(ITYPE,IDRUG,SIGPOS)) Q:SIGPOS="" D
68 . . . S SIGCNT=SIGCNT+1
69 . . I $Y>(PGLENGTH-SIGCNT) W !,DRUGSEP,@IOF D HD3
70 . . W:'SUPTYPE !,DRUGSEP,@EMPTYLN
71 . . W !,"|",IDRUG_$E(BLNKLN,$L(IDRUG),PGWIDTH-3)_"|"
72 . . Q:SUPTYPE
73 . . S ISIG=0
74 . . F S ISIG=$O(LIST(ITYPE,IDRUG,ISIG)) Q:ISIG<1 D
75 . . . W !,"| ",LIST(ITYPE,IDRUG,ISIG),$E(BLNKLN,$L(LIST(ITYPE,IDRUG,ISIG)),PGWIDTH-8),"|"
76 . . W !,INSTSEP1,!,INSTSEP2 W:'$G(PSOQHS) !,INSTSEP3
77NVA ;NVA MEDS ADDED 5/6/05
78 I $D(NVA) D
79 . N NVACNT,NVADRUG
80 . W !,DRUGSEP
81 . W @EMPTYLN
82 . W !,"|","NON-VA Medications:"_$E(BLNKLN,20,PGWIDTH-2)_"|"
83 . W @EMPTYLN
84 . S NVACNT=0
85 . S NVADRUG=""
86 . F S NVADRUG=$O(NVA(NVADRUG)) Q:NVADRUG="" D
87 . . S NVACNT=NVACNT+1
88 . . I $Y>(PGLENGTH-NVACNT) W !,DRUGSEP,@IOF D HD3
89 . . W !,"|",NVADRUG_$E(BLNKLN,$L(NVADRUG),PGWIDTH-3)_"|"
90 K NVACNT,NVADRUG
91 W !,INSTSEP1
92 D
93 . Q:'$G(PSOQPEND)
94 . W !!,"Any medication items listed as ""pending"" are those that have just been" D PGE Q:$D(GMTSQIT)
95 . W !,"written by your provider(s). These medication orders will be reviewed" D PGE Q:$D(GMTSQIT)
96 . W !,"by your pharmacist, prior to the prescription(s) being dispensed. When" D PGE Q:$D(GMTSQIT)
97 . W !,"you receive your new prescription(s), by mail or from the pharmacy window," D PGE Q:$D(GMTSQIT)
98 . W !,"be sure to follow the instructions on the prescription label. If you" D PGE Q:$D(GMTSQIT)
99 . W !,"have any question about your medication, please call your provider or " D PGE Q:$D(GMTSQIT)
100 . W !,"your pharmacist." D PGE Q:$D(GMTSQIT)
101 Q
102PGE D:$G(PSOQHS) CKP^GMTSUP
103 Q
104GETOPORD(ORDLIST) ;
105 N LISTIEN,KILLORD
106 S LISTIEN=0
107 F S LISTIEN=$O(ORDLIST(LISTIEN)) Q:LISTIEN<1 D
108 . S KILLORD=$$IPORD(ORDLIST(LISTIEN))
109 . I 'KILLORD S KILLORD=$$CKSTATUS(ORDLIST(LISTIEN)) D
110 . K:KILLORD ORDLIST(LISTIEN)
111 Q
112IPORD(LISTNODE) ;
113 N RETURN,PKG
114 S RETURN=0
115 S PKG=$P($P(LISTNODE,"^",1),";",2)
116 I "UI"[PKG S RETURN=1
117 I $P(LISTNODE,"^",1)["N;" D
118 . S:$P(LISTNODE,"^",4)="ACTIVE" NVA($P(LISTNODE,"^",2),+LISTNODE)=LISTNODE
119 . S RETURN=1
120 Q RETURN
121CKSTATUS(LISTNODE) ;
122 N RETURN,RXIEN
123 S RETURN=0 ; ASSUME ACTIVE AND NOT PASS MED
124 S:$P(LISTNODE,"^",4)["DISCONTINUED" RETURN=1
125 S:$P(LISTNODE,"^",4)["EXPIRED" RETURN=1
126 Q RETURN
127GETRXDAT(RXS) ;
128 N RXSIEN,DRUGNAME,FSIG,RXTYPE
129 S RXSIEN=0
130 F S RXSIEN=$O(RXS(RXSIEN)) Q:RXSIEN<1 D
131 . I $P(RXS(RXSIEN),";")["P" D GETPEND(RXSIEN) S PSOQPEND=1 Q ;->
132 . S RXIEN=+RXS(RXSIEN)
133 . S DRUGNAME=$$ZZ^PSOSUTL(RXIEN)
134 . D FSIG^PSOUTLA("R",RXIEN,PGWIDTH-8)
135 . S RXTYPE=$$GETTYPE(RXIEN)
136 . M RXS(RXTYPE,DRUGNAME)=FSIG
137 . N PSOQSUB
138 . S PSOQSUB=$O(RXS(RXTYPE,DRUGNAME,":"),-1)+1
139 . S RXS(RXTYPE,DRUGNAME,PSOQSUB)=$$REFILLS^PSOQ0076(RXIEN)_" refill(s) remaining prior to "_$$FMTE^XLFDT($$EXPDATE^PSOQ0076(RXIEN))
140 Q
141GETPEND(RXSIEN) ;RMS/HINES 8-16-07 ADD PENDING RX'S
142 N PSOQPDN,PSOQDIND,PSOQOIND,PSOQ100,PSOQSIND,PSOQSCT,PSOQRAW,SUB
143 S PSOQ100=$P(RXS(RXSIEN),U,3) Q:'+PSOQ100
144 S PSOQOIND=$O(^OR(100,PSOQ100,4.5,"ID","ORDERABLE",0)) Q:'+PSOQOIND
145 S PSOQPDN=$P($G(^ORD(101.43,+$G(^OR(100,PSOQ100,4.5,PSOQOIND,1)),0)),U)
146 S PSOQDIND=$O(^OR(100,PSOQ100,4.5,"ID","DRUG",0)) D
147 . Q:'+PSOQDIND
148 . S PSOQPDN=$P($G(^PSDRUG(+$G(^OR(100,PSOQ100,4.5,PSOQDIND,1)),0)),U)
149 S PSOQSIND=$O(^OR(100,PSOQ100,8,":"),-1) Q:'+PSOQSIND
150 F PSOQSCT=2:1:$O(^OR(100,PSOQ100,8,PSOQSIND,.1,":"),-1) D
151 . S PSOQRAW=$G(^OR(100,PSOQ100,8,PSOQSIND,.1,PSOQSCT,0))
152 . N WORDS,COUNT,LINE,NEXTWORD
153 . S WORDS=$L(PSOQRAW," "),SUB=$G(SUB,0)+1
154 . F COUNT=1:1:WORDS D
155 .. S NEXTWORD=$P(PSOQRAW," ",COUNT)
156 .. Q:NEXTWORD=""
157 .. S LINE=$G(LINE)_NEXTWORD_" "
158 .. I $L($G(LINE))>65&(COUNT'=WORDS) K LINE S SUB=SUB+1
159 .. S RXS("D","**PENDING**"_PSOQPDN,SUB)=$G(RXS("D","**PENDING**"_PSOQPDN,SUB))_NEXTWORD_" "
160 Q
161GETTYPE(IEN52) ;
162 N RETURN,CLASS
163 S RETURN="D"
164 S CLASS=$$GETCLASS(IEN52)
165 S:$E(CLASS,1,1)="X" RETURN="S"
166 S:$E(CLASS,1,2)="DX" RETURN="S"
167 Q RETURN
168GETCLASS(IENRX) ;
169 N RETURN,NODE0RX,IENDRUG,NODE0DRG,NODEND50,IENCLASS,NODE0CLS,VACLASS
170 S RETURN=""
171 S NODE0RX=$G(^PSRX(IENRX,0))
172 S IENDRUG=$P(NODE0RX,"^",6)
173 Q:+IENDRUG=0 RETURN
174 S NODE0DRG=$G(^PSDRUG(IENDRUG,0))
175 S NODEND50=$G(^PSDRUG(IENDRUG,"ND"))
176 S IENCLASS=$P(NODEND50,"^",6)
177 Q:+IENCLASS=0 RETURN
178 S NODE0CLS=$G(^PS(50.605,IENCLASS,0))
179 S VACLASS=$P(NODE0CLS,"^",1)
180 S RETURN=VACLASS
181 Q RETURN
182HD ;
183 S FN=ARLDFN
184 S ARLNAME=$E($P(^DPT(ARLDFN,0),"^",1),1,28)
185 S ARLSN=$P(^(0),"^",9),ARLDOB=$P(^(0),"^",3)
186 S PHONE=$S($D(^DPT(ARLDFN,.13)):^(.13),1:"")
187 S HP=$P(PHONE,"^",1),WP=$P(PHONE,"^",2)
188 S ADDR=$S($D(^DPT(ARLDFN,.11)):^(.11),1:"")
189 I $D(^DPT(ARLDFN,.121)),$P(^(.121),"^",9)="Y" D
190 . S X=$S($P(^(.121),"^",8):$P(^(.121),"^",8),1:9999999)
191 . I DT'<$P(^(.121),"^",7),DT'>X D
192 . . S ADDR=^(.121)
193 . . S ADDRFL="(temporary)"
194 . . S HP=$P(ADDR,"^",10)
195 S ST=$S($D(^DIC(5,+$P(ADDR,"^",5),0)):$P(^(0),"^",2),1:"UNKNOWN")
196 S ADDR(4)=$P(ADDR,"^",4)_", "_ST_" "_$P(ADDR,"^",6)
197 S ADDR(3)=$P(ADDR,"^",3),ADDR(2)=$P(ADDR,"^",2),ADDR(1)=$P(ADDR,"^",1)
198 I ADDR(2)']"" D
199 . S ADDR(2)=ADDR(3)
200 . S ADDR(3)=""
201HD1 ; Header for 1st page
202 S ARLSITE=^PS(59,PSOSITE,0)
203 D PGE Q:$D(GMTSQIT)
204 W !,"Date: ",RPTDATE,?XPOS1,"PATIENT MEDICATION INFORMATION"
205 I $D(PAGE) D
206 . W ?XPOS2,"Page: ",PAGE
207 . S PAGE=PAGE+1
208 W !,?XPOS4,"PRINTED BY THE VA MEDICAL CENTER AT: "_$P($G(^DIC(4,+$G(^PS(59,PSOSITE,"INI")),0)),U,1)
209 W !,?XPOS4,"FOR PRESCRIPTION REFILLS CALL ("_$P(ARLSITE,U,3)_") "_$P(ARLSITE,U,4)
210HD2 W !!,"Name: ",$E(ARLNAME,1,40)," - ",$E(ARLSN,6,9)
211 W ?30," PHARMACY - ",$P(ARLSITE,"^",7)," DIVISION (",$P(ARLSITE,"^",3),"-",$P(ARLSITE,"^",4),")",!
212 W !,INSTSEP1,!,DRUGHDR1 ;!,DRUGHDR2
213 Q
214HD3 ;Header for subsequent pages
215 W !,"Date: ",RPTDATE,?XPOS1,"PATIENT MEDICATION INFORMATION"
216 I $D(PAGE) W ?XPOS2,"Page: ",PAGE S PAGE=PAGE+1
217 W !,?XPOS4,"PRINTED BY THE VA MEDICAL CENTER AT: "_$P($G(^DIC(4,+$G(^PS(59,PSOSITE,"INI")),0)),U,1)
218 W !,?XPOS4,"FOR PRESCRIPTION REFILLS CALL ("_$P(ARLSITE,U,3)_") "_$P(ARLSITE,U,4),!
219 W !?1,"Name: ",$E(ARLNAME,1,40)," - ",$E(ARLSN,6,9)
220 W ?30," PHARMACY - ",$P(ARLSITE,"^",7)," DIVISION (",$P(ARLSITE,"^",3),"-",$P(ARLSITE,"^",4),")",!
221 W !,INSTSEP1
222 W:$G(SUPCNT)&'$G(NVACNT) !,"|","SUPPLY ITEMS:"_$E(BLNKLN,14,PGWIDTH-2)_"|",@EMPTYLN
223 W:$G(NVACNT) @EMPTYLN,!,"|","NON-VA Medications:"_$E(BLNKLN,20,PGWIDTH-2)_"|",@EMPTYLN
224 W:'$G(NVACNT)&'$G(SUPCNT) !,DRUGHDR1
225 Q
226RE ;Allergies
227 S ARLDASH="",$P(ARLDASH,"=",$E(BLNKLN,1,PGWIDTH-10))=ARLDASH W !,ARLDASH,!!
228 S NONE="NO INFORMATION (COMPLETE SECTION BELOW)",ALFLAG=0 D ALL
229 W "REACTIONS/ALLERGIES currently on file : ",$S($D(GMRAL):"",1:NONE) Q:'$D(GMRAL)
230 S X=DRUG1_FOOD,DIWL=5,DIWR=PGWIDTH-5,DIWF="W" D ^DIWP,^DIWW
231 Q
232ALL ;Gets allergy info
233 K GMRA,GMRAL
234 N IFN,DATA,VER,ARLEND
235 S ARLEND=0,DFN=ARLDFN,GMRA="0^0^011" D ^GMRADPT S (DRUG1,FOOD)=""
236 I $D(GMRAL),GMRAL=0 S DRUG1="NO KNOWN ALLERGIES"
237 I $D(GMRAL),GMRAL=1 S IFN="" F S IFN=$O(GMRAL(IFN)) Q:IFN=""!(ARLEND) S DATA=GMRAL(IFN),AL=$P(DATA,U,2),TYPE=$P(DATA,U,3),VER=$S($P(DATA,U,4)=1:"V",1:"NV") D
238 .I $L(DRUG1)>300 S DRUG1="TOO MANY TO LIST",ARLEND=1
239 .S:TYPE="D" DRUG1=AL_" ("_VER_"),"_DRUG1
240 .S:TYPE="F" FOOD="Food Allergies on File"
241 Q
Note: See TracBrowser for help on using the repository browser.