source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJPATMR.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1PSJPATMR ;BIR/RSB,LDT-UTILITY FOR PATIENT MERGE ;28 Oct 99 / 12:53 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**36**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 supported by DBIA #2191.
5 ; Reference to ^PS(52.6 is supported by DBIA 1231
6 ; Reference to ^PS(52.7 is supported by DBIA 2173
7 ; Reference to ^PSDRUG( is supported by DBIA 2192
8 ;
9EN(DFN1,DFN2) ;
10 ; check active IV, UD, and Orders on a pick list
11 I $$CHKIVACT(DFN1)!($$CHKUDACT(DFN1))!($$CHKPL(DFN1)) Q 0
12 N DUPUD,DUPIV K ^TMP("PSJMERGE_UD",$J),^TMP("PSJMERGE_IV",$J)
13 S DUPUD=$$CHKUDDUP(DFN1,DFN2),DUPIV=$$CHKIVDUP(DFN1,DFN2)
14 I +DUPUD=1 D
15 .S DUPUD=$P(DUPUD,"^",2) D MOVEUD(DFN1,DUPUD)
16 I +DUPIV=1 D
17 .S DUPIV=$P(DUPIV,"^",2) D MOVEIV(DFN1,DUPIV)
18 K ^TMP("PSJMERGE_UD",$J),^TMP("PSJMERGE_IV",$J)
19 Q 1
20 ;
21CHKUDDUP(PSJDFN1,PSJDFN2) ;
22 ; check for Unit Dose orders in ^PS(55, with duplicate order numbers for both patients
23 N ORD1,ORD2,O1,O2,PSJFLAG,DUP1,DUP2,DUP,HIGHEST
24 S (PSJFLAG,HIGHEST)=0
25 F ORD1=0:0 S ORD1=$O(^PS(55,PSJDFN1,5,"B",ORD1)) Q:'ORD1 D
26 . F O1=0:0 S O1=$O(^PS(55,PSJDFN1,5,"B",ORD1,O1)) Q:'O1 D
27 . . S DUP1(O1)="" S:O1>HIGHEST HIGHEST=O1
28 F ORD2=0:0 S ORD2=$O(^PS(55,PSJDFN2,5,"B",ORD2)) Q:'ORD2 D
29 . F O2=0:0 S O2=$O(^PS(55,PSJDFN2,5,"B",ORD2,O2)) Q:'O2 D
30 . . S DUP2(O2)="" S:O2>HIGHEST HIGHEST=O2
31 F DUP=0:0 S DUP=$O(DUP1(DUP)) Q:'DUP!(PSJFLAG=1) D
32 . I $D(DUP2(DUP)) S PSJFLAG=1 ; duplicate order numbers found
33 Q PSJFLAG_$S(PSJFLAG=1:"^"_(HIGHEST+1),1:"")
34 ;
35MOVEUD(DFN1,COUNT) ; move all Unit Dose orders for FROM patient
36 N ORDERS,XREF,STOP,X S STOP=COUNT
37 F ORDERS=0:0 S ORDERS=$O(^PS(55,DFN1,5,ORDERS)) Q:'ORDERS!(ORDERS=STOP) D
38 . M ^PS(55,DFN1,5,COUNT)=^PS(55,DFN1,5,ORDERS) ; Move to new order
39 . ; set .01 order number if not a number from 53.1
40 . I ORDERS=+$P($G(^PS(55,DFN1,5,ORDERS,0)),"^") S $P(^PS(55,DFN1,5,COUNT,0),"^")=COUNT
41 . ; kill xrefs
42 . K DA S DA=ORDERS,DA(1)=DFN1
43 . S X=$P($G(^PS(55,DA(1),5,DA,0)),"^",7) I $D(^PS(55,DA(1),5,DA,2)),$P(^(2),"^",4) K ^PS(55,DA(1),5,"AU",X,+$P(^(2),"^",4),DA)
44 . K ^PS(55,"ANV",DA(1),DA)
45 . K ^PS(55,"APV",DA(1),DA)
46 . K ^PS(55,"AUE",DA(1),DA)
47 . K ^PS(55,DA(1),5,"B",$P($G(^PS(55,DA(1),5,DA,0)),"^"),DA)
48 . S X=$P($G(^PS(55,DA(1),5,DA,2)),"^",4) K ^PS(55,"AUD",$E(X,1,30),DA(1),DA)
49 . K ^PS(55,DA(1),5,"AUS",+X,DA) I $P($G(^PS(55,DA(1),5,DA,0)),"^",7)]"" K ^PS(55,DA(1),5,"AU",$P(^(0),"^",7),+X,DA)
50 . S X=$P($G(^PS(55,DA(1),5,DA,2)),"^",2) K ^PS(55,"AUDDD",$E(X,1,30),DA(1),DA)
51 . K ^PS(55,"AUDS",$E(X,1,30),DA(1),DA)
52 . S X=$P($G(^PS(55,DA(1),5,DA,.1)),"^") K:+X ^PS(55,DA(1),5,"C",$E(X,1,30),DA)
53 . ; set table for previous and following order numbers
54 . S ^TMP("PSJMERGE_UD",$J,ORDERS)=ORDERS_"^"_$P($G(^PS(55,DFN1,5,ORDERS,0)),"^",25)_"^"_$P($G(^PS(55,DFN1,5,ORDERS,0)),"^",26)_"^"_COUNT
55 . ; kill entire order
56 . K ^PS(55,DFN1,5,ORDERS)
57 . ; Set new X-refs
58 . K DIK,DA S DA=COUNT,DA(1)=DFN1,DIK="^PS(55,"_DA(1)_",5,"
59 . F XREF=7,51,50,34,64,10,".01^AUE^B" S DIK(1)=XREF D EN^DIK
60 . D CNVUD(DFN1,COUNT)
61 . D EN1^PSJHL2(DFN1,"SC",COUNT_"U") ; Update CPRS pointer to order
62 . S COUNT=COUNT+1
63 ; Check Previous and Following order numbers
64 N PREV,FOLL,NEW,OLD,SUB,PREVIEN,FOLLIEN S SUB="PSJMERGE_UD"
65 F ORDERS=0:0 S ORDERS=$O(^TMP(SUB,$J,ORDERS)) Q:'ORDERS D
66 . S (NEW,OLD,PREV,FOLL,PREVIEN,FOLLIEN)=""
67 . S:$P(^TMP(SUB,$J,ORDERS),"^",4)]"" NEW=$P(^TMP(SUB,$J,ORDERS),"^",4)
68 . S:$P(^TMP(SUB,$J,ORDERS),"^")]"" OLD=$P(^TMP(SUB,$J,ORDERS),"^")
69 . S:$P(^TMP(SUB,$J,ORDERS),"^",2)]"" PREV=$P(^TMP(SUB,$J,ORDERS),"^",2)
70 . S:$P(^TMP(SUB,$J,ORDERS),"^",3)]"" FOLL=$P(^TMP(SUB,$J,ORDERS),"^",3)
71 . I PREV]"" S PREVIEN=$S($D(^TMP(SUB,$J,+PREV)):$P(^TMP(SUB,$J,+PREV),"^",4),1:PREV) D
72 . . I PREV["P",$D(^PS(53.1,+PREVIEN,0)) S $P(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"U"
73 . . I PREV["U",$D(^PS(55,DFN1,5,+PREVIEN,0)) S $P(^PS(55,DFN1,5,+PREVIEN,0),"^",26)=NEW_"U"
74 . I FOLL]"" S FOLLIEN=$S($D(^TMP(SUB,$J,+FOLL)):$P(^TMP(SUB,$J,+FOLL),"^",4),1:FOLL) D
75 . . S:$D(@("^PS(55,"_DFN1_",5,"_+FOLLIEN_",0)")) $P(@("^PS(55,"_DFN1_",5,"_+FOLLIEN_",0)"),"^",25)=NEW_"U"
76 S $P(^PS(55,DFN1,5,0),"^",3)=COUNT-1 ; reset last used IEN for FROM patient
77 S $P(^PS(55,DFN2,5,0),"^",3)=COUNT-1 ; reset last used IEN for TO patient
78 Q
79 ;
80CHKIVDUP(PSJDFN1,PSJDFN2) ;
81 ; check for IV orders in ^PS(55, with duplicate order numbers for both patients
82 N ORD1,ORD2,O1,O2,PSJFLAG,DUP1,DUP2,DUP,HIGHEST
83 S (PSJFLAG,HIGHEST)=0
84 F ORD1=0:0 S ORD1=$O(^PS(55,PSJDFN1,"IV","B",ORD1)) Q:'ORD1 D
85 . F O1=0:0 S O1=$O(^PS(55,PSJDFN1,"IV","B",ORD1,O1)) Q:'O1 D
86 . . S DUP1(O1)="" S:O1>HIGHEST HIGHEST=O1
87 F ORD2=0:0 S ORD2=$O(^PS(55,PSJDFN2,"IV","B",ORD2)) Q:'ORD2 D
88 . F O2=0:0 S O2=$O(^PS(55,PSJDFN2,"IV","B",ORD2,O2)) Q:'O2 D
89 . . S DUP2(O2)="" S:O2>HIGHEST HIGHEST=O2
90 F DUP=0:0 S DUP=$O(DUP1(DUP)) Q:'DUP!(PSJFLAG=1) D
91 . I $D(DUP2(DUP)) S PSJFLAG=1 ; duplicate order numbers found
92 Q PSJFLAG_$S(PSJFLAG=1:"^"_(HIGHEST+1),1:"")
93 ;
94MOVEIV(DFN1,COUNT) ; move all IV orders for FROM patient
95 N ORDERS,STOP,X S STOP=COUNT
96 F ORDERS=0:0 S ORDERS=$O(^PS(55,DFN1,"IV",ORDERS)) Q:'ORDERS!(ORDERS=STOP) D
97 . M ^PS(55,DFN1,"IV",COUNT)=^PS(55,DFN1,"IV",ORDERS) ; Move to new order
98 . ; set .01 order number if not a number from 53.1
99 . I ORDERS=+$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^") S $P(^PS(55,DFN1,"IV",COUNT,0),"^")=COUNT
100 . ; kill xrefs
101 . K DA S DA=ORDERS,DA(1)=DFN1
102 . S X=$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^",17) K:X'="D"&($D(^PS(55,DA(1),"IV",DA,"ADC"))) ^PS(55,"ADC",^PS(55,DA(1),"IV",DA,"ADC"),DA(1),DA)
103 . K:X'="N" ^PS(55,"ANVO",DA(1),DA)
104 . S X=$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^",3) K ^PS(55,DA(1),"IV","AIS",$E(X,1,30),DA)
105 . I $P($G(^PS(55,DA(1),"IV",DA,0)),U,4)]"" K ^PS(55,DA(1),"IV","AIT",$P(^(0),U,4),+X,DA)
106 . K ^PS(55,"AIV",+$E(X,1,30),DA(1),DA)
107 . S X=$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^",2) K ^PS(55,"AIVS",$E(X,1,30),DA(1),DA)
108 . S X=$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^") K ^PS(55,DA(1),"IV","B",$E(X,1,30),DA)
109 . S ^TMP("PSJMERGE_IV",$J,ORDERS)=ORDERS_"^"_$P($G(^PS(55,DFN1,"IV",ORDERS,2)),"^",5)_"^"_$P($G(^PS(55,DFN1,"IV",ORDERS,2)),"^",6)_"^"_COUNT
110 . ; Delete old order
111 . K ^PS(55,DFN1,"IV",ORDERS)
112 . ; Set new X-refs
113 . K DIK,DA S DA=COUNT,DA(1)=DFN1,DIK="^PS(55,"_DA(1)_",""IV"","
114 . F XREF="100^ADC^ANVO",".03^AIS^AIT^AIV",".02^AIVS",".01^B" S DIK(1)=XREF D EN^DIK
115 . D CNVIV(DFN1,COUNT)
116 . D EN1^PSJHL2(DFN1,"SC",COUNT_"V") ; Update CPRS pointer to order
117 . S COUNT=COUNT+1
118 ; Check Previous and Following order numbers
119 N PREV,FOLL,NEW,OLD,SUB,PREVIEN,FOLLIEN S SUB="PSJMERGE_IV"
120 F ORDERS=0:0 S ORDERS=$O(^TMP(SUB,$J,ORDERS)) Q:'ORDERS D
121 . S (NEW,OLD,PREV,FOLL,PREVIEN,FOLLIEN)=""
122 . S:$P(^TMP(SUB,$J,ORDERS),"^",4)]"" NEW=$P(^TMP(SUB,$J,ORDERS),"^",4)
123 . S:$P(^TMP(SUB,$J,ORDERS),"^")]"" OLD=$P(^TMP(SUB,$J,ORDERS),"^")
124 . S:$P(^TMP(SUB,$J,ORDERS),"^",2)]"" PREV=$P(^TMP(SUB,$J,ORDERS),"^",2)
125 . S:$P(^TMP(SUB,$J,ORDERS),"^",3)]"" FOLL=$P(^TMP(SUB,$J,ORDERS),"^",3)
126 . I PREV]"" S PREVIEN=$S($D(^TMP(SUB,$J,+PREV)):$P(^TMP(SUB,$J,+PREV),"^",4),1:PREV) D
127 . . I PREV["P",$D(^PS(53.1,+PREVIEN,0)) S $P(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"V"
128 . . I PREV["V",$D(^PS(55,DFN1,"IV",+PREVIEN,0)) S $P(^PS(55,DFN1,"IV",+PREVIEN,2),"^",6)=NEW_"V"
129 . I FOLL]"" S FOLLIEN=$S($D(^TMP(SUB,$J,+FOLL)):$P(^TMP(SUB,$J,+FOLL),"^",4),1:FOLL) D
130 . . S:$D(^PS(55,DFN1,"IV",+FOLLIEN,0)) $P(^PS(55,DFN1,"IV",+FOLLIEN,2),"^",5)=NEW_"V" Q
131 S $P(^PS(55,DFN1,"IV",0),"^",3)=COUNT-1 ; reset last used IEN for FROM patient
132 S $P(^PS(55,DFN2,"IV",0),"^",3)=COUNT-1 ; reset last used IEN for TO patient
133 Q
134 ;
135CHKIVACT(PSJDFN1) ;
136 ; check for active IV orders in ^PS(55, for FROM patient
137 N DATE1,PSJFLAG,PSJDT
138 D NOW^%DTC S PSJDT=%
139 S PSJFLAG=0
140 F DATE1=0:0 S DATE1=$O(^PS(55,PSJDFN1,"IV","AIS",DATE1)) Q:'DATE1 D
141 . I DATE1>PSJDT S PSJFLAG=1 Q
142 Q PSJFLAG
143 ;
144CHKUDACT(PSJDFN1) ;
145 ; check for active UD orders in ^PS(55, for FROM patient
146 N DATE1,PSJFLAG,PSJDT
147 D NOW^%DTC S PSJDT=%
148 S PSJFLAG=0
149 F DATE1=0:0 S DATE1=$O(^PS(55,PSJDFN1,5,"AUS",DATE1)) Q:'DATE1 D
150 . I DATE1>PSJDT S PSJFLAG=1 Q
151 Q PSJFLAG
152 ;
153CHKPL(PSJDFN1) ;
154 ; check to see if FROM patient is contained on any pick lists
155 N PLNUM,PSJFLAG
156 S PSJFLAG=0
157 F PLNUM=0:0 S PLNUM=$O(^PS(53.5,PLNUM)) Q:'PLNUM D
158 . I $D(^PS(53.5,PLNUM,1,"B",PSJDFN1,PSJDFN1)) S PSJFLAG=1 Q
159 Q PSJFLAG
160CNVUD(DFN,ON) ;Convert UD orders.
161 N PSJOI,ND,DDRG,XX
162 I '$G(^PS(55,DFN,5,ON,.2)) D
163 .S PSJOI="",ND=$G(^PS(55,DFN,5,+ON,.1)),DDRG=$O(^PS(55,DFN,5,ON,1,0)),XX=+$G(^PS(55,DFN,5,ON,1,+DDRG,0)) S:XX PSJOI=+$G(^PSDRUG(XX,2))
164 .I 'PSJOI F DDRG=0:0 S DDRG=$O(^PSDRUG("AP",+ND,DDRG)) Q:'DDRG!PSJOI S PSJOI=+$G(^PSDRUG(DDRG,2))
165 .I PSJOI S ^PS(55,DFN,5,ON,.2)=PSJOI_U_$P(ND,U,2)
166 Q
167CNVIV(DFN,ON) ;Convert IV orders.
168 N PSJOI,ND,ADS,ON1,XX
169 I '$G(^PS(55,DFN,"IV",ON,.2)) D
170 .S PSJOI="",ND=$G(^PS(55,DFN,"IV",ON,6)) F ADS="AD","SOL" I 'PSJOI F ON1=0:0 S ON1=$O(^PS(55,DFN,"IV",ON,ADS,ON1)) Q:'ON1!PSJOI S XX=+$G(^PS(55,DFN,"IV",ON,ADS,ON1,0)) D
171 ..S:XX PSJOI=$S(ADS="AD":$P($G(^PS(52.6,XX,0)),U,11),1:$P($G(^PS(52.7,XX,0)),U,11)) I PSJOI S ^PS(55,DFN,"IV",ON,.2)=PSJOI_U_$P(ND,U,2,3)
172 Q
173
Note: See TracBrowser for help on using the repository browser.