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
PSJPATMR ;BIR/RSB,LDT-UTILITY FOR PATIENT MERGE ;28 Oct 99 / 12:53 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**36**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA #2191.
+4 ; Reference to ^PS(52.6 is supported by DBIA 1231
+5 ; Reference to ^PS(52.7 is supported by DBIA 2173
+6 ; Reference to ^PSDRUG( is supported by DBIA 2192
+7 ;
EN(DFN1,DFN2) ;
+1 ; check active IV, UD, and Orders on a pick list
+2 IF $$CHKIVACT(DFN1)!($$CHKUDACT(DFN1))!($$CHKPL(DFN1))
QUIT 0
+3 NEW DUPUD,DUPIV
KILL ^TMP("PSJMERGE_UD",$JOB),^TMP("PSJMERGE_IV",$JOB)
+4 SET DUPUD=$$CHKUDDUP(DFN1,DFN2)
SET DUPIV=$$CHKIVDUP(DFN1,DFN2)
+5 IF +DUPUD=1
Begin DoDot:1
+6 SET DUPUD=$PIECE(DUPUD,"^",2)
DO MOVEUD(DFN1,DUPUD)
End DoDot:1
+7 IF +DUPIV=1
Begin DoDot:1
+8 SET DUPIV=$PIECE(DUPIV,"^",2)
DO MOVEIV(DFN1,DUPIV)
End DoDot:1
+9 KILL ^TMP("PSJMERGE_UD",$JOB),^TMP("PSJMERGE_IV",$JOB)
+10 QUIT 1
+11 ;
CHKUDDUP(PSJDFN1,PSJDFN2) ;
+1 ; check for Unit Dose orders in ^PS(55, with duplicate order numbers for both patients
+2 NEW ORD1,ORD2,O1,O2,PSJFLAG,DUP1,DUP2,DUP,HIGHEST
+3 SET (PSJFLAG,HIGHEST)=0
+4 FOR ORD1=0:0
SET ORD1=$ORDER(^PS(55,PSJDFN1,5,"B",ORD1))
IF 'ORD1
QUIT
Begin DoDot:1
+5 FOR O1=0:0
SET O1=$ORDER(^PS(55,PSJDFN1,5,"B",ORD1,O1))
IF 'O1
QUIT
Begin DoDot:2
+6 SET DUP1(O1)=""
IF O1>HIGHEST
SET HIGHEST=O1
End DoDot:2
End DoDot:1
+7 FOR ORD2=0:0
SET ORD2=$ORDER(^PS(55,PSJDFN2,5,"B",ORD2))
IF 'ORD2
QUIT
Begin DoDot:1
+8 FOR O2=0:0
SET O2=$ORDER(^PS(55,PSJDFN2,5,"B",ORD2,O2))
IF 'O2
QUIT
Begin DoDot:2
+9 SET DUP2(O2)=""
IF O2>HIGHEST
SET HIGHEST=O2
End DoDot:2
End DoDot:1
+10 FOR DUP=0:0
SET DUP=$ORDER(DUP1(DUP))
IF 'DUP!(PSJFLAG=1)
QUIT
Begin DoDot:1
+11 ; duplicate order numbers found
IF $DATA(DUP2(DUP))
SET PSJFLAG=1
End DoDot:1
+12 QUIT PSJFLAG_$SELECT(PSJFLAG=1:"^"_(HIGHEST+1),1:"")
+13 ;
MOVEUD(DFN1,COUNT) ; move all Unit Dose orders for FROM patient
+1 NEW ORDERS,XREF,STOP,X
SET STOP=COUNT
+2 FOR ORDERS=0:0
SET ORDERS=$ORDER(^PS(55,DFN1,5,ORDERS))
IF 'ORDERS!(ORDERS=STOP)
QUIT
Begin DoDot:1
+3 ; Move to new order
MERGE ^PS(55,DFN1,5,COUNT)=^PS(55,DFN1,5,ORDERS)
+4 ; set .01 order number if not a number from 53.1
+5 IF ORDERS=+$PIECE($GET(^PS(55,DFN1,5,ORDERS,0)),"^")
SET $PIECE(^PS(55,DFN1,5,COUNT,0),"^")=COUNT
+6 ; kill xrefs
+7 KILL DA
SET DA=ORDERS
SET DA(1)=DFN1
+8 SET X=$PIECE($GET(^PS(55,DA(1),5,DA,0)),"^",7)
IF $DATA(^PS(55,DA(1),5,DA,2))
IF $PIECE(^(2),"^",4)
KILL ^PS(55,DA(1),5,"AU",X,+$PIECE(^(2),"^",4),DA)
+9 KILL ^PS(55,"ANV",DA(1),DA)
+10 KILL ^PS(55,"APV",DA(1),DA)
+11 KILL ^PS(55,"AUE",DA(1),DA)
+12 KILL ^PS(55,DA(1),5,"B",$PIECE($GET(^PS(55,DA(1),5,DA,0)),"^"),DA)
+13 SET X=$PIECE($GET(^PS(55,DA(1),5,DA,2)),"^",4)
KILL ^PS(55,"AUD",$EXTRACT(X,1,30),DA(1),DA)
+14 KILL ^PS(55,DA(1),5,"AUS",+X,DA)
IF $PIECE($GET(^PS(55,DA(1),5,DA,0)),"^",7)]""
KILL ^PS(55,DA(1),5,"AU",$PIECE(^(0),"^",7),+X,DA)
+15 SET X=$PIECE($GET(^PS(55,DA(1),5,DA,2)),"^",2)
KILL ^PS(55,"AUDDD",$EXTRACT(X,1,30),DA(1),DA)
+16 KILL ^PS(55,"AUDS",$EXTRACT(X,1,30),DA(1),DA)
+17 SET X=$PIECE($GET(^PS(55,DA(1),5,DA,.1)),"^")
IF +X
KILL ^PS(55,DA(1),5,"C",$EXTRACT(X,1,30),DA)
+18 ; set table for previous and following order numbers
+19 SET ^TMP("PSJMERGE_UD",$JOB,ORDERS)=ORDERS_"^"_$PIECE($GET(^PS(55,DFN1,5,ORDERS,0)),"^",25)_"^"_$PIECE($GET(^PS(55,DFN1,5,ORDERS,0)),"^",26)_"^"_COUNT
+20 ; kill entire order
+21 KILL ^PS(55,DFN1,5,ORDERS)
+22 ; Set new X-refs
+23 KILL DIK,DA
SET DA=COUNT
SET DA(1)=DFN1
SET DIK="^PS(55,"_DA(1)_",5,"
+24 FOR XREF=7,51,50,34,64,10,".01^AUE^B"
SET DIK(1)=XREF
DO EN^DIK
+25 DO CNVUD(DFN1,COUNT)
+26 ; Update CPRS pointer to order
DO EN1^PSJHL2(DFN1,"SC",COUNT_"U")
+27 SET COUNT=COUNT+1
End DoDot:1
+28 ; Check Previous and Following order numbers
+29 NEW PREV,FOLL,NEW,OLD,SUB,PREVIEN,FOLLIEN
SET SUB="PSJMERGE_UD"
+30 FOR ORDERS=0:0
SET ORDERS=$ORDER(^TMP(SUB,$JOB,ORDERS))
IF 'ORDERS
QUIT
Begin DoDot:1
+31 SET (NEW,OLD,PREV,FOLL,PREVIEN,FOLLIEN)=""
+32 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^",4)]""
SET NEW=$PIECE(^TMP(SUB,$JOB,ORDERS),"^",4)
+33 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^")]""
SET OLD=$PIECE(^TMP(SUB,$JOB,ORDERS),"^")
+34 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^",2)]""
SET PREV=$PIECE(^TMP(SUB,$JOB,ORDERS),"^",2)
+35 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^",3)]""
SET FOLL=$PIECE(^TMP(SUB,$JOB,ORDERS),"^",3)
+36 IF PREV]""
SET PREVIEN=$SELECT($DATA(^TMP(SUB,$JOB,+PREV)):$PIECE(^TMP(SUB,$JOB,+PREV),"^",4),1:PREV)
Begin DoDot:2
+37 IF PREV["P"
IF $DATA(^PS(53.1,+PREVIEN,0))
SET $PIECE(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"U"
+38 IF PREV["U"
IF $DATA(^PS(55,DFN1,5,+PREVIEN,0))
SET $PIECE(^PS(55,DFN1,5,+PREVIEN,0),"^",26)=NEW_"U"
End DoDot:2
+39 IF FOLL]""
SET FOLLIEN=$SELECT($DATA(^TMP(SUB,$JOB,+FOLL)):$PIECE(^TMP(SUB,$JOB,+FOLL),"^",4),1:FOLL)
Begin DoDot:2
+40 IF $DATA(@("^PS(55,"_DFN1_",5,"_+FOLLIEN_",0)"))
SET $PIECE(@("^PS(55,"_DFN1_",5,"_+FOLLIEN_",0)"),"^",25)=NEW_"U"
End DoDot:2
End DoDot:1
+41 ; reset last used IEN for FROM patient
SET $PIECE(^PS(55,DFN1,5,0),"^",3)=COUNT-1
+42 ; reset last used IEN for TO patient
SET $PIECE(^PS(55,DFN2,5,0),"^",3)=COUNT-1
+43 QUIT
+44 ;
CHKIVDUP(PSJDFN1,PSJDFN2) ;
+1 ; check for IV orders in ^PS(55, with duplicate order numbers for both patients
+2 NEW ORD1,ORD2,O1,O2,PSJFLAG,DUP1,DUP2,DUP,HIGHEST
+3 SET (PSJFLAG,HIGHEST)=0
+4 FOR ORD1=0:0
SET ORD1=$ORDER(^PS(55,PSJDFN1,"IV","B",ORD1))
IF 'ORD1
QUIT
Begin DoDot:1
+5 FOR O1=0:0
SET O1=$ORDER(^PS(55,PSJDFN1,"IV","B",ORD1,O1))
IF 'O1
QUIT
Begin DoDot:2
+6 SET DUP1(O1)=""
IF O1>HIGHEST
SET HIGHEST=O1
End DoDot:2
End DoDot:1
+7 FOR ORD2=0:0
SET ORD2=$ORDER(^PS(55,PSJDFN2,"IV","B",ORD2))
IF 'ORD2
QUIT
Begin DoDot:1
+8 FOR O2=0:0
SET O2=$ORDER(^PS(55,PSJDFN2,"IV","B",ORD2,O2))
IF 'O2
QUIT
Begin DoDot:2
+9 SET DUP2(O2)=""
IF O2>HIGHEST
SET HIGHEST=O2
End DoDot:2
End DoDot:1
+10 FOR DUP=0:0
SET DUP=$ORDER(DUP1(DUP))
IF 'DUP!(PSJFLAG=1)
QUIT
Begin DoDot:1
+11 ; duplicate order numbers found
IF $DATA(DUP2(DUP))
SET PSJFLAG=1
End DoDot:1
+12 QUIT PSJFLAG_$SELECT(PSJFLAG=1:"^"_(HIGHEST+1),1:"")
+13 ;
MOVEIV(DFN1,COUNT) ; move all IV orders for FROM patient
+1 NEW ORDERS,STOP,X
SET STOP=COUNT
+2 FOR ORDERS=0:0
SET ORDERS=$ORDER(^PS(55,DFN1,"IV",ORDERS))
IF 'ORDERS!(ORDERS=STOP)
QUIT
Begin DoDot:1
+3 ; Move to new order
MERGE ^PS(55,DFN1,"IV",COUNT)=^PS(55,DFN1,"IV",ORDERS)
+4 ; set .01 order number if not a number from 53.1
+5 IF ORDERS=+$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^")
SET $PIECE(^PS(55,DFN1,"IV",COUNT,0),"^")=COUNT
+6 ; kill xrefs
+7 KILL DA
SET DA=ORDERS
SET DA(1)=DFN1
+8 SET X=$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^",17)
IF X'="D"&($DATA(^PS(55,DA(1),"IV",DA,"ADC")))
KILL ^PS(55,"ADC",^PS(55,DA(1),"IV",DA,"ADC"),DA(1),DA)
+9 IF X'="N"
KILL ^PS(55,"ANVO",DA(1),DA)
+10 SET X=$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^",3)
KILL ^PS(55,DA(1),"IV","AIS",$EXTRACT(X,1,30),DA)
+11 IF $PIECE($GET(^PS(55,DA(1),"IV",DA,0)),U,4)]""
KILL ^PS(55,DA(1),"IV","AIT",$PIECE(^(0),U,4),+X,DA)
+12 KILL ^PS(55,"AIV",+$EXTRACT(X,1,30),DA(1),DA)
+13 SET X=$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^",2)
KILL ^PS(55,"AIVS",$EXTRACT(X,1,30),DA(1),DA)
+14 SET X=$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^")
KILL ^PS(55,DA(1),"IV","B",$EXTRACT(X,1,30),DA)
+15 SET ^TMP("PSJMERGE_IV",$JOB,ORDERS)=ORDERS_"^"_$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,2)),"^",5)_"^"_$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,2)),"^",6)_"^"_COUNT
+16 ; Delete old order
+17 KILL ^PS(55,DFN1,"IV",ORDERS)
+18 ; Set new X-refs
+19 KILL DIK,DA
SET DA=COUNT
SET DA(1)=DFN1
SET DIK="^PS(55,"_DA(1)_",""IV"","
+20 FOR XREF="100^ADC^ANVO",".03^AIS^AIT^AIV",".02^AIVS",".01^B"
SET DIK(1)=XREF
DO EN^DIK
+21 DO CNVIV(DFN1,COUNT)
+22 ; Update CPRS pointer to order
DO EN1^PSJHL2(DFN1,"SC",COUNT_"V")
+23 SET COUNT=COUNT+1
End DoDot:1
+24 ; Check Previous and Following order numbers
+25 NEW PREV,FOLL,NEW,OLD,SUB,PREVIEN,FOLLIEN
SET SUB="PSJMERGE_IV"
+26 FOR ORDERS=0:0
SET ORDERS=$ORDER(^TMP(SUB,$JOB,ORDERS))
IF 'ORDERS
QUIT
Begin DoDot:1
+27 SET (NEW,OLD,PREV,FOLL,PREVIEN,FOLLIEN)=""
+28 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^",4)]""
SET NEW=$PIECE(^TMP(SUB,$JOB,ORDERS),"^",4)
+29 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^")]""
SET OLD=$PIECE(^TMP(SUB,$JOB,ORDERS),"^")
+30 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^",2)]""
SET PREV=$PIECE(^TMP(SUB,$JOB,ORDERS),"^",2)
+31 IF $PIECE(^TMP(SUB,$JOB,ORDERS),"^",3)]""
SET FOLL=$PIECE(^TMP(SUB,$JOB,ORDERS),"^",3)
+32 IF PREV]""
SET PREVIEN=$SELECT($DATA(^TMP(SUB,$JOB,+PREV)):$PIECE(^TMP(SUB,$JOB,+PREV),"^",4),1:PREV)
Begin DoDot:2
+33 IF PREV["P"
IF $DATA(^PS(53.1,+PREVIEN,0))
SET $PIECE(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"V"
+34 IF PREV["V"
IF $DATA(^PS(55,DFN1,"IV",+PREVIEN,0))
SET $PIECE(^PS(55,DFN1,"IV",+PREVIEN,2),"^",6)=NEW_"V"
End DoDot:2
+35 IF FOLL]""
SET FOLLIEN=$SELECT($DATA(^TMP(SUB,$JOB,+FOLL)):$PIECE(^TMP(SUB,$JOB,+FOLL),"^",4),1:FOLL)
Begin DoDot:2
+36 IF $DATA(^PS(55,DFN1,"IV",+FOLLIEN,0))
SET $PIECE(^PS(55,DFN1,"IV",+FOLLIEN,2),"^",5)=NEW_"V"
QUIT
End DoDot:2
End DoDot:1
+37 ; reset last used IEN for FROM patient
SET $PIECE(^PS(55,DFN1,"IV",0),"^",3)=COUNT-1
+38 ; reset last used IEN for TO patient
SET $PIECE(^PS(55,DFN2,"IV",0),"^",3)=COUNT-1
+39 QUIT
+40 ;
CHKIVACT(PSJDFN1) ;
+1 ; check for active IV orders in ^PS(55, for FROM patient
+2 NEW DATE1,PSJFLAG,PSJDT
+3 DO NOW^%DTC
SET PSJDT=%
+4 SET PSJFLAG=0
+5 FOR DATE1=0:0
SET DATE1=$ORDER(^PS(55,PSJDFN1,"IV","AIS",DATE1))
IF 'DATE1
QUIT
Begin DoDot:1
+6 IF DATE1>PSJDT
SET PSJFLAG=1
QUIT
End DoDot:1
+7 QUIT PSJFLAG
+8 ;
CHKUDACT(PSJDFN1) ;
+1 ; check for active UD orders in ^PS(55, for FROM patient
+2 NEW DATE1,PSJFLAG,PSJDT
+3 DO NOW^%DTC
SET PSJDT=%
+4 SET PSJFLAG=0
+5 FOR DATE1=0:0
SET DATE1=$ORDER(^PS(55,PSJDFN1,5,"AUS",DATE1))
IF 'DATE1
QUIT
Begin DoDot:1
+6 IF DATE1>PSJDT
SET PSJFLAG=1
QUIT
End DoDot:1
+7 QUIT PSJFLAG
+8 ;
CHKPL(PSJDFN1) ;
+1 ; check to see if FROM patient is contained on any pick lists
+2 NEW PLNUM,PSJFLAG
+3 SET PSJFLAG=0
+4 FOR PLNUM=0:0
SET PLNUM=$ORDER(^PS(53.5,PLNUM))
IF 'PLNUM
QUIT
Begin DoDot:1
+5 IF $DATA(^PS(53.5,PLNUM,1,"B",PSJDFN1,PSJDFN1))
SET PSJFLAG=1
QUIT
End DoDot:1
+6 QUIT PSJFLAG
CNVUD(DFN,ON) ;Convert UD orders.
+1 NEW PSJOI,ND,DDRG,XX
+2 IF '$GET(^PS(55,DFN,5,ON,.2))
Begin DoDot:1
+3 SET PSJOI=""
SET ND=$GET(^PS(55,DFN,5,+ON,.1))
SET DDRG=$ORDER(^PS(55,DFN,5,ON,1,0))
SET XX=+$GET(^PS(55,DFN,5,ON,1,+DDRG,0))
IF XX
SET PSJOI=+$GET(^PSDRUG(XX,2))
+4 IF 'PSJOI
FOR DDRG=0:0
SET DDRG=$ORDER(^PSDRUG("AP",+ND,DDRG))
IF 'DDRG!PSJOI
QUIT
SET PSJOI=+$GET(^PSDRUG(DDRG,2))
+5 IF PSJOI
SET ^PS(55,DFN,5,ON,.2)=PSJOI_U_$PIECE(ND,U,2)
End DoDot:1
+6 QUIT
CNVIV(DFN,ON) ;Convert IV orders.
+1 NEW PSJOI,ND,ADS,ON1,XX
+2 IF '$GET(^PS(55,DFN,"IV",ON,.2))
Begin DoDot:1
+3 SET PSJOI=""
SET ND=$GET(^PS(55,DFN,"IV",ON,6))
FOR ADS="AD","SOL"
IF 'PSJOI
FOR ON1=0:0
SET ON1=$ORDER(^PS(55,DFN,"IV",ON,ADS,ON1))
IF 'ON1!PSJOI
QUIT
SET XX=+$GET(^PS(55,DFN,"IV",ON,ADS,ON1,0))
Begin DoDot:2
+4 IF XX
SET PSJOI=$SELECT(ADS="AD":$PIECE($GET(^PS(52.6,XX,0)),U,11),1:$PIECE($GET(^PS(52.7,XX,0)),U,11))
IF PSJOI
SET ^PS(55,DFN,"IV",ON,.2)=PSJOI_U_$PIECE(ND,U,2,3)
End DoDot:2
End DoDot:1
+5 QUIT
+6
***** ERRORS & WARNINGS IN PSJPATMR *****
PSJPATMR+1 S - 2nd line of routine violates the SAC.
