source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m@ 1071

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1TIULMED ; SLC/JM,JH,AJB - Active/Recent Med Objects Routine ; 12/18/07
2 ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213,238**;Jun 20, 1997;Build 6
3 Q
4LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ;
5 ; This is the TIU Medication objects API. Optional parameters not
6 ; provided default to 0 (with the exception of SUPPLIES).
7 ;Required Parameters:
8 ; DFN Patient identifier
9 ; TARGET Where the medication data will be stored
10 ;Optional Parameters:
11 ; ACTVONLY 0 - Active and recently expired meds
12 ; 1 - Active meds only
13 ; 2 - Recently expired meds only
14 ; DETAILED 0 - One line per med only
15 ; 1 - Detailed information on each med
16 ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an
17 ; Inpatient, or Outpatient Meds if patient
18 ; is an Outpatient
19 ; 1 - Specifies both Inpatient and Outpatient
20 ; 2 or "I" - Specifies Inpatient only
21 ; 3 or "O" - Specifies Outpatient only
22 ; ONELIST 0 - Separates Active, Pending and Inactive
23 ; medications into separate lists
24 ; 1 - Combines Active, Pending and Inactive
25 ; medications into the same list
26 ; CLASSORT 0 - Sort meds alphabetically
27 ; 1 - Sort meds by drug class, and within the
28 ; same drug class, sort alphabetically
29 ; 2 - Same as #1, but show drug class in header
30 ; SUPPLIES 0 - Supplies are excluded
31 ; 1 - Supplies are included (Default)
32 N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK
33 N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN
34 N SPACE60,DASH73,LINE,TAB,HEADER
35 N DRUGCLAS,DRUGIDX,UNKNOWNS
36 N NVATYPE,NVAMED,NVASTR,TIUXSTAT
37 N %,%H,STOP,LSTFD ;Clean up after external calls...
38 S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47
39 S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="
40 K @TARGET,^TMP("PS",$J)
41 ; Check for Pharmacy Package and required patches
42 I '$$PATCHSOK^TIULMED3 G LISTX ;P213
43 I '+$G(ACTVONLY) S ACTVONLY=0
44 I '+$G(DETAILED) S DETAILED=0
45 I +$D(ALLMEDS) D
46 .I ALLMEDS="I" S ALLMEDS=2
47 .E I ALLMEDS="O" S ALLMEDS=3
48 I '+$G(ALLMEDS) S ALLMEDS=0
49 I '+$G(ONELIST) S ONELIST=0
50 I '+$G(CLASSORT) S CLASSORT=0
51 I $G(SUPPLIES)'="0" S SUPPLIES=1
52 S (EMPTY,HEADER)=1
53 I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT S HEADER=0
54 I 'DETAILED S LLEN=60
55 S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^"
56 S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
57 S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient? IA 10035
58 I ISINP S INPTYPE=1,OUTPTYPE=2
59 E S INPTYPE=2,OUTPTYPE=1
60 S NVATYPE=3
61 D ADDTITLE^TIULMED1
62 ;
63 ; *** Scan medication data and skip unwanted meds ***
64 ; Changes for *238 required by PSO*7*294
65 D
66 . I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE) S TIUDATE=$$FMADD^XLFDT(DT,-$G(TIUDATE)) D OCL^PSOQ0496(DFN,TIUDATE,"") Q ; IA 2400
67 . D OCL^PSOORRL(DFN,"","") ; IA 2400
68 ;
69 S INDEX=0
70 F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
71 .S NODE=$G(^TMP("PS",$J,INDEX,0))
72 .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
73 .I KEEPMED D
74 ..S STATUS=$P(NODE,U,9)
75 ..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)"
76 ..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1
77 ..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2
78 ..E S STATIDX=3
79 ..S TIUXSTAT=STATUS
80 ..I ACTVONLY=1 S KEEPMED=(STATIDX<3)
81 ..I ACTVONLY=2 S KEEPMED=(STATIDX=3)
82 ..I +ONELIST S STATIDX=1
83 ..; Changes for *238 required by PSO*7*294
84 ..I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE),STATUS["DISCONTINUED" S KEEPMED=0
85 .I KEEPMED D
86 ..S TYPE=$P($P(NODE,U),";",2)
87 ..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
88 ..S NVAMED=$P($P(NODE,U),";")
89 ..S NVAMED=$E(NVAMED,$L(NVAMED))
90 ..S KEEPMED=(TYPE'="")
91 .I KEEPMED D
92 ..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV"
93 ..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV"
94 ..I TYPE="OP" S MEDTYPE=OUTPTYPE
95 ..E S MEDTYPE=INPTYPE
96 ..I NVAMED="N" S MEDTYPE=NVATYPE
97 ..I ALLMEDS=0 D I 1
98 ...I MEDTYPE=INPTYPE S KEEPMED=ISINP
99 ...E S KEEPMED='ISINP
100 ..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE)
101 ..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE))
102 .S DRUGCLAS=" "
103 .S MED=$P(NODE,U,2)
104 .I KEEPMED,(CLASSORT!('SUPPLIES)) D
105 ..S DRUGIDX=$$IENNAME^TIULMED2(MED)
106 ..D GETCLASS
107 .. ; If DRUGIDX="" (MED not in Drug File 50), get info
108 .. ; via Orderable Item instead.
109 ..I KEEPMED,+DRUGIDX=0 D
110 ...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
111 ...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
112 ...S (DRUGIDX,ORDIDX)=0
113 ...K ^TMP($J,"TIULMED")
114 ...; IDX is Order #; ID indicates what file. See IA 2400
115 ...; R;O MED will always be in Drug File (Unless Drug File entry was
116 ...; changed after ordering.
117 ...I ID="R;O" D ;R;O = prescription (file #52). P213
118 ....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820
119 ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6))
120 ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI"))
121 ...;
122 ...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213
123 ....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821
124 ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11))
125 ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8))
126 ...;
127 ...I ID="P;I" D ;P;I = pending inpatient order (file #53.1)
128 ....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D ; IA 2907
129 .....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D
130 ......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U)
131 ....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U)
132 ...;
133 ...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213
134 ....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826
135 ....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D
136 .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0
137 .....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
138 .....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108))
139 ...;
140 ...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213
141 ....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826
142 ....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
143 ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130))
144 ....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D
145 .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D
146 ......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01))
147 ......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662
148 ...;
149 ...S DRUGCLAS=""
150 ...D GETCLASS
151 ...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D
152 ....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES
153 ....N LIST S LIST="TIULMED" K ^TMP($J,LIST)
154 ....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662
155 ....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE)
156 .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
157 .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
158 .....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS=""
159 .....I 'CDONE D
160 ......I DRUGCLAS="" S DRUGCLAS=TMPCLASS
161 ......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS=""
162 .....I 'SDONE D
163 ......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S"))
164 ......I 'ISSUPPLY S SDONE=1
165 ....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0
166 ..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" "
167 .;
168 .; *** Save wanted meds in "B" temp xref, removing duplicates ***
169 .;
170 .I KEEPMED D
171 ..D ADDMED^TIULMED1(1) ; Get XSTR to check for duplicates
172 ..;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL
173 ..S IDATE=$P(NODE,U,15)
174 ..S OK='$D(@TARGET@("B",MED,XSTR,TIUXSTAT))
175 ..I 'OK,(IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT)) S OK=1
176 ..I OK D
177 ...S @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS
178 ...S EMPTY=0
179 ...I DRUGCLAS=" " S UNKNOWNS=1
180 ;
181 D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213
182LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED"),TIUDATE ; K TIUDATE added for PSO*7*294
183 Q "~@"_$NA(@TARGET)
184 ;
185GETCLASS ;
186 D GETCLASS^TIULMED3
187 Q
Note: See TracBrowser for help on using the repository browser.