174 lines
8.8 KiB
Mathematica
174 lines
8.8 KiB
Mathematica
PSJPATMR ;BIR/RSB,LDT-UTILITY FOR PATIENT MERGE ;28 Oct 99 / 12:53 PM
|
|
;;5.0; INPATIENT MEDICATIONS ;**36**;16 DEC 97
|
|
;
|
|
; Reference to ^PS(55 supported by DBIA #2191.
|
|
; Reference to ^PS(52.6 is supported by DBIA 1231
|
|
; Reference to ^PS(52.7 is supported by DBIA 2173
|
|
; Reference to ^PSDRUG( is supported by DBIA 2192
|
|
;
|
|
EN(DFN1,DFN2) ;
|
|
; check active IV, UD, and Orders on a pick list
|
|
I $$CHKIVACT(DFN1)!($$CHKUDACT(DFN1))!($$CHKPL(DFN1)) Q 0
|
|
N DUPUD,DUPIV K ^TMP("PSJMERGE_UD",$J),^TMP("PSJMERGE_IV",$J)
|
|
S DUPUD=$$CHKUDDUP(DFN1,DFN2),DUPIV=$$CHKIVDUP(DFN1,DFN2)
|
|
I +DUPUD=1 D
|
|
.S DUPUD=$P(DUPUD,"^",2) D MOVEUD(DFN1,DUPUD)
|
|
I +DUPIV=1 D
|
|
.S DUPIV=$P(DUPIV,"^",2) D MOVEIV(DFN1,DUPIV)
|
|
K ^TMP("PSJMERGE_UD",$J),^TMP("PSJMERGE_IV",$J)
|
|
Q 1
|
|
;
|
|
CHKUDDUP(PSJDFN1,PSJDFN2) ;
|
|
; check for Unit Dose orders in ^PS(55, with duplicate order numbers for both patients
|
|
N ORD1,ORD2,O1,O2,PSJFLAG,DUP1,DUP2,DUP,HIGHEST
|
|
S (PSJFLAG,HIGHEST)=0
|
|
F ORD1=0:0 S ORD1=$O(^PS(55,PSJDFN1,5,"B",ORD1)) Q:'ORD1 D
|
|
. F O1=0:0 S O1=$O(^PS(55,PSJDFN1,5,"B",ORD1,O1)) Q:'O1 D
|
|
. . S DUP1(O1)="" S:O1>HIGHEST HIGHEST=O1
|
|
F ORD2=0:0 S ORD2=$O(^PS(55,PSJDFN2,5,"B",ORD2)) Q:'ORD2 D
|
|
. F O2=0:0 S O2=$O(^PS(55,PSJDFN2,5,"B",ORD2,O2)) Q:'O2 D
|
|
. . S DUP2(O2)="" S:O2>HIGHEST HIGHEST=O2
|
|
F DUP=0:0 S DUP=$O(DUP1(DUP)) Q:'DUP!(PSJFLAG=1) D
|
|
. I $D(DUP2(DUP)) S PSJFLAG=1 ; duplicate order numbers found
|
|
Q PSJFLAG_$S(PSJFLAG=1:"^"_(HIGHEST+1),1:"")
|
|
;
|
|
MOVEUD(DFN1,COUNT) ; move all Unit Dose orders for FROM patient
|
|
N ORDERS,XREF,STOP,X S STOP=COUNT
|
|
F ORDERS=0:0 S ORDERS=$O(^PS(55,DFN1,5,ORDERS)) Q:'ORDERS!(ORDERS=STOP) D
|
|
. M ^PS(55,DFN1,5,COUNT)=^PS(55,DFN1,5,ORDERS) ; Move to new order
|
|
. ; set .01 order number if not a number from 53.1
|
|
. I ORDERS=+$P($G(^PS(55,DFN1,5,ORDERS,0)),"^") S $P(^PS(55,DFN1,5,COUNT,0),"^")=COUNT
|
|
. ; kill xrefs
|
|
. K DA S DA=ORDERS,DA(1)=DFN1
|
|
. 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)
|
|
. K ^PS(55,"ANV",DA(1),DA)
|
|
. K ^PS(55,"APV",DA(1),DA)
|
|
. K ^PS(55,"AUE",DA(1),DA)
|
|
. K ^PS(55,DA(1),5,"B",$P($G(^PS(55,DA(1),5,DA,0)),"^"),DA)
|
|
. S X=$P($G(^PS(55,DA(1),5,DA,2)),"^",4) K ^PS(55,"AUD",$E(X,1,30),DA(1),DA)
|
|
. 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)
|
|
. S X=$P($G(^PS(55,DA(1),5,DA,2)),"^",2) K ^PS(55,"AUDDD",$E(X,1,30),DA(1),DA)
|
|
. K ^PS(55,"AUDS",$E(X,1,30),DA(1),DA)
|
|
. S X=$P($G(^PS(55,DA(1),5,DA,.1)),"^") K:+X ^PS(55,DA(1),5,"C",$E(X,1,30),DA)
|
|
. ; set table for previous and following order numbers
|
|
. 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
|
|
. ; kill entire order
|
|
. K ^PS(55,DFN1,5,ORDERS)
|
|
. ; Set new X-refs
|
|
. K DIK,DA S DA=COUNT,DA(1)=DFN1,DIK="^PS(55,"_DA(1)_",5,"
|
|
. F XREF=7,51,50,34,64,10,".01^AUE^B" S DIK(1)=XREF D EN^DIK
|
|
. D CNVUD(DFN1,COUNT)
|
|
. D EN1^PSJHL2(DFN1,"SC",COUNT_"U") ; Update CPRS pointer to order
|
|
. S COUNT=COUNT+1
|
|
; Check Previous and Following order numbers
|
|
N PREV,FOLL,NEW,OLD,SUB,PREVIEN,FOLLIEN S SUB="PSJMERGE_UD"
|
|
F ORDERS=0:0 S ORDERS=$O(^TMP(SUB,$J,ORDERS)) Q:'ORDERS D
|
|
. S (NEW,OLD,PREV,FOLL,PREVIEN,FOLLIEN)=""
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^",4)]"" NEW=$P(^TMP(SUB,$J,ORDERS),"^",4)
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^")]"" OLD=$P(^TMP(SUB,$J,ORDERS),"^")
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^",2)]"" PREV=$P(^TMP(SUB,$J,ORDERS),"^",2)
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^",3)]"" FOLL=$P(^TMP(SUB,$J,ORDERS),"^",3)
|
|
. I PREV]"" S PREVIEN=$S($D(^TMP(SUB,$J,+PREV)):$P(^TMP(SUB,$J,+PREV),"^",4),1:PREV) D
|
|
. . I PREV["P",$D(^PS(53.1,+PREVIEN,0)) S $P(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"U"
|
|
. . I PREV["U",$D(^PS(55,DFN1,5,+PREVIEN,0)) S $P(^PS(55,DFN1,5,+PREVIEN,0),"^",26)=NEW_"U"
|
|
. I FOLL]"" S FOLLIEN=$S($D(^TMP(SUB,$J,+FOLL)):$P(^TMP(SUB,$J,+FOLL),"^",4),1:FOLL) D
|
|
. . S:$D(@("^PS(55,"_DFN1_",5,"_+FOLLIEN_",0)")) $P(@("^PS(55,"_DFN1_",5,"_+FOLLIEN_",0)"),"^",25)=NEW_"U"
|
|
S $P(^PS(55,DFN1,5,0),"^",3)=COUNT-1 ; reset last used IEN for FROM patient
|
|
S $P(^PS(55,DFN2,5,0),"^",3)=COUNT-1 ; reset last used IEN for TO patient
|
|
Q
|
|
;
|
|
CHKIVDUP(PSJDFN1,PSJDFN2) ;
|
|
; check for IV orders in ^PS(55, with duplicate order numbers for both patients
|
|
N ORD1,ORD2,O1,O2,PSJFLAG,DUP1,DUP2,DUP,HIGHEST
|
|
S (PSJFLAG,HIGHEST)=0
|
|
F ORD1=0:0 S ORD1=$O(^PS(55,PSJDFN1,"IV","B",ORD1)) Q:'ORD1 D
|
|
. F O1=0:0 S O1=$O(^PS(55,PSJDFN1,"IV","B",ORD1,O1)) Q:'O1 D
|
|
. . S DUP1(O1)="" S:O1>HIGHEST HIGHEST=O1
|
|
F ORD2=0:0 S ORD2=$O(^PS(55,PSJDFN2,"IV","B",ORD2)) Q:'ORD2 D
|
|
. F O2=0:0 S O2=$O(^PS(55,PSJDFN2,"IV","B",ORD2,O2)) Q:'O2 D
|
|
. . S DUP2(O2)="" S:O2>HIGHEST HIGHEST=O2
|
|
F DUP=0:0 S DUP=$O(DUP1(DUP)) Q:'DUP!(PSJFLAG=1) D
|
|
. I $D(DUP2(DUP)) S PSJFLAG=1 ; duplicate order numbers found
|
|
Q PSJFLAG_$S(PSJFLAG=1:"^"_(HIGHEST+1),1:"")
|
|
;
|
|
MOVEIV(DFN1,COUNT) ; move all IV orders for FROM patient
|
|
N ORDERS,STOP,X S STOP=COUNT
|
|
F ORDERS=0:0 S ORDERS=$O(^PS(55,DFN1,"IV",ORDERS)) Q:'ORDERS!(ORDERS=STOP) D
|
|
. M ^PS(55,DFN1,"IV",COUNT)=^PS(55,DFN1,"IV",ORDERS) ; Move to new order
|
|
. ; set .01 order number if not a number from 53.1
|
|
. I ORDERS=+$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^") S $P(^PS(55,DFN1,"IV",COUNT,0),"^")=COUNT
|
|
. ; kill xrefs
|
|
. K DA S DA=ORDERS,DA(1)=DFN1
|
|
. 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)
|
|
. K:X'="N" ^PS(55,"ANVO",DA(1),DA)
|
|
. S X=$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^",3) K ^PS(55,DA(1),"IV","AIS",$E(X,1,30),DA)
|
|
. 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)
|
|
. K ^PS(55,"AIV",+$E(X,1,30),DA(1),DA)
|
|
. S X=$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^",2) K ^PS(55,"AIVS",$E(X,1,30),DA(1),DA)
|
|
. S X=$P($G(^PS(55,DFN1,"IV",ORDERS,0)),"^") K ^PS(55,DA(1),"IV","B",$E(X,1,30),DA)
|
|
. 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
|
|
. ; Delete old order
|
|
. K ^PS(55,DFN1,"IV",ORDERS)
|
|
. ; Set new X-refs
|
|
. K DIK,DA S DA=COUNT,DA(1)=DFN1,DIK="^PS(55,"_DA(1)_",""IV"","
|
|
. F XREF="100^ADC^ANVO",".03^AIS^AIT^AIV",".02^AIVS",".01^B" S DIK(1)=XREF D EN^DIK
|
|
. D CNVIV(DFN1,COUNT)
|
|
. D EN1^PSJHL2(DFN1,"SC",COUNT_"V") ; Update CPRS pointer to order
|
|
. S COUNT=COUNT+1
|
|
; Check Previous and Following order numbers
|
|
N PREV,FOLL,NEW,OLD,SUB,PREVIEN,FOLLIEN S SUB="PSJMERGE_IV"
|
|
F ORDERS=0:0 S ORDERS=$O(^TMP(SUB,$J,ORDERS)) Q:'ORDERS D
|
|
. S (NEW,OLD,PREV,FOLL,PREVIEN,FOLLIEN)=""
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^",4)]"" NEW=$P(^TMP(SUB,$J,ORDERS),"^",4)
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^")]"" OLD=$P(^TMP(SUB,$J,ORDERS),"^")
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^",2)]"" PREV=$P(^TMP(SUB,$J,ORDERS),"^",2)
|
|
. S:$P(^TMP(SUB,$J,ORDERS),"^",3)]"" FOLL=$P(^TMP(SUB,$J,ORDERS),"^",3)
|
|
. I PREV]"" S PREVIEN=$S($D(^TMP(SUB,$J,+PREV)):$P(^TMP(SUB,$J,+PREV),"^",4),1:PREV) D
|
|
. . I PREV["P",$D(^PS(53.1,+PREVIEN,0)) S $P(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"V"
|
|
. . I PREV["V",$D(^PS(55,DFN1,"IV",+PREVIEN,0)) S $P(^PS(55,DFN1,"IV",+PREVIEN,2),"^",6)=NEW_"V"
|
|
. I FOLL]"" S FOLLIEN=$S($D(^TMP(SUB,$J,+FOLL)):$P(^TMP(SUB,$J,+FOLL),"^",4),1:FOLL) D
|
|
. . S:$D(^PS(55,DFN1,"IV",+FOLLIEN,0)) $P(^PS(55,DFN1,"IV",+FOLLIEN,2),"^",5)=NEW_"V" Q
|
|
S $P(^PS(55,DFN1,"IV",0),"^",3)=COUNT-1 ; reset last used IEN for FROM patient
|
|
S $P(^PS(55,DFN2,"IV",0),"^",3)=COUNT-1 ; reset last used IEN for TO patient
|
|
Q
|
|
;
|
|
CHKIVACT(PSJDFN1) ;
|
|
; check for active IV orders in ^PS(55, for FROM patient
|
|
N DATE1,PSJFLAG,PSJDT
|
|
D NOW^%DTC S PSJDT=%
|
|
S PSJFLAG=0
|
|
F DATE1=0:0 S DATE1=$O(^PS(55,PSJDFN1,"IV","AIS",DATE1)) Q:'DATE1 D
|
|
. I DATE1>PSJDT S PSJFLAG=1 Q
|
|
Q PSJFLAG
|
|
;
|
|
CHKUDACT(PSJDFN1) ;
|
|
; check for active UD orders in ^PS(55, for FROM patient
|
|
N DATE1,PSJFLAG,PSJDT
|
|
D NOW^%DTC S PSJDT=%
|
|
S PSJFLAG=0
|
|
F DATE1=0:0 S DATE1=$O(^PS(55,PSJDFN1,5,"AUS",DATE1)) Q:'DATE1 D
|
|
. I DATE1>PSJDT S PSJFLAG=1 Q
|
|
Q PSJFLAG
|
|
;
|
|
CHKPL(PSJDFN1) ;
|
|
; check to see if FROM patient is contained on any pick lists
|
|
N PLNUM,PSJFLAG
|
|
S PSJFLAG=0
|
|
F PLNUM=0:0 S PLNUM=$O(^PS(53.5,PLNUM)) Q:'PLNUM D
|
|
. I $D(^PS(53.5,PLNUM,1,"B",PSJDFN1,PSJDFN1)) S PSJFLAG=1 Q
|
|
Q PSJFLAG
|
|
CNVUD(DFN,ON) ;Convert UD orders.
|
|
N PSJOI,ND,DDRG,XX
|
|
I '$G(^PS(55,DFN,5,ON,.2)) D
|
|
.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))
|
|
.I 'PSJOI F DDRG=0:0 S DDRG=$O(^PSDRUG("AP",+ND,DDRG)) Q:'DDRG!PSJOI S PSJOI=+$G(^PSDRUG(DDRG,2))
|
|
.I PSJOI S ^PS(55,DFN,5,ON,.2)=PSJOI_U_$P(ND,U,2)
|
|
Q
|
|
CNVIV(DFN,ON) ;Convert IV orders.
|
|
N PSJOI,ND,ADS,ON1,XX
|
|
I '$G(^PS(55,DFN,"IV",ON,.2)) D
|
|
.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
|
|
..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)
|
|
Q
|
|
|