PSJPATMR ;BIR/RSB - UTILITY FOR PATIENT MERGE ;Apr 19, 2022@14:12
;;5.0;INPATIENT MEDICATIONS;**36,217,404,431**;16 DEC 97;Build 5
;
; 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
; Reference to ^PSB(53.79 is supported by DBIA 3370.
;
EN(DFN1,DFN2) ; Patient DFN1 (FROM) / DFN2 (TO)
; check active IV, UD, and Orders on a pick list
I $$CHKIVACT(DFN1)!($$CHKUDACT(DFN1))!($$CHKPL(DFN1)) Q 0
K ^TMP("PSJMERGE_UD",$J),^TMP("PSJMERGE_IV",$J)
D MOVEUD(DFN1,DFN2)
D MOVEIV(DFN1,DFN2)
K ^TMP("PSJMERGE_UD",$J),^TMP("PSJMERGE_IV",$J)
Q 1
;
MOVEUD(DFN1,DFN2) ; move all Unit Dose orders for FROM patient
N ORDERS,XREF,X,NEXT,INITIAL,LASTDFN1,LASTDFN2,HIGHEST
S LASTDFN1=+$O(^PS(55,DFN1,5,9999999999),-1)
S LASTDFN2=+$O(^PS(55,DFN2,5,9999999999),-1)
S HIGHEST=$S(LASTDFN1>LASTDFN2:LASTDFN1,1:LASTDFN2)
S (NEXT,INITIAL)=HIGHEST+1
F ORDERS=0:0 S ORDERS=$O(^PS(55,DFN1,5,ORDERS)) Q:'ORDERS D
. M ^PS(55,DFN2,5,NEXT)=^PS(55,DFN1,5,ORDERS) ; Move to new order
. D UPDBML(DFN1,ORDERS_"U",DFN2,NEXT_"U") ; Update BCMA MED LOG file (#53.79), ORDER REFERENCE NUMBER field (#.11)
. ; 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,DFN2,5,NEXT,0),"^")=NEXT
. S $P(^PS(55,DFN2,5,NEXT,0),"^",15)=DFN2
. ; 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)
. S X=$P($G(^PS(55,DA(1),5,DA,2)),"^",4) K ^PS(55,"AUD",$E(X,1,30),DA(1),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)_"^"_NEXT
. ; Set new X-refs
. K DIK,DA S DA=NEXT,DA(1)=DFN2,DIK="^PS(55,"_DA(1)_",5,"
. F XREF=.5,7,51,50,34,64,10,".01^AUE^B" S DIK(1)=XREF D EN^DIK
. D CNVUD(DFN2,NEXT)
. D EN1^PSJHL2(DFN1,"OC",ORDERS_"U") ; Cancel CPRS order from Patient 'From'
. D EN1^PSJHL2(DFN2,"SC",NEXT_"U") ; Update CPRS with order from Patient 'To'
. ; kill entire order
. K ^PS(55,DFN1,5,ORDERS)
. S NEXT=NEXT+1
; Kills remaining x-refs
F XREF="B","C","AU","AUS" K ^PS(55,DFN1,5,XREF)
;
; Check Previous and Following order numbers
N ORDER,PREV,FOLL,NEW,OLD,PREVIEN
F ORDERS=0:0 S ORDERS=$O(^TMP("PSJMERGE_UD",$J,ORDERS)) Q:'ORDERS D
. S (NEW,PREV,FOLL,PREVIEN)=""
. S:$P(^TMP("PSJMERGE_UD",$J,ORDERS),"^",4)]"" NEW=$P(^TMP("PSJMERGE_UD",$J,ORDERS),"^",4)
. S:$P(^TMP("PSJMERGE_UD",$J,ORDERS),"^",2)]"" PREV=$P(^TMP("PSJMERGE_UD",$J,ORDERS),"^",2)
. I PREV]"" S PREVIEN=$S($D(^TMP("PSJMERGE_UD",$J,+PREV)):$P(^TMP("PSJMERGE_UD",$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"
F ORDER=INITIAL:1 Q:'$D(^PS(55,DFN2,5,ORDER)) D
. S PREV=$P(^PS(55,DFN2,5,ORDER,0),"^",25),FOLL=$P(^PS(55,DFN2,5,ORDER,0),"^",26)
. I PREV["U",$D(^TMP("PSJMERGE_UD",$J,+PREV)) D
. . S $P(^PS(55,DFN2,5,ORDER,0),"^",25)=$P(^TMP("PSJMERGE_UD",$J,+PREV),"^",4)_"U"
. I FOLL["U",$D(^TMP("PSJMERGE_UD",$J,+FOLL)) D
. . S $P(^PS(55,DFN2,5,ORDER,0),"^",26)=$P(^TMP("PSJMERGE_UD",$J,+FOLL),"^",4)_"U"
;
S $P(^PS(55,DFN1,5,0),"^",3,4)="0^0" ; reset last used IEN for FROM patient
S $P(^PS(55,DFN2,5,0),"^",3,4)=(NEXT-1)_"^"_(NEXT-1) ; reset last used IEN for TO patient
;PSJ*5.0*431: set second piece with sub-file if not already set.
I $P(^PS(55,DFN2,5,0),"^",2)="" S $P(^PS(55,DFN2,5,0),"^",2)="55.06IA"
K ^PS(55,"CIMOU",DFN1)
Q
;
MOVEIV(DFN1,DFN2) ; move all IV orders for FROM patient
N ORDERS,X,XREF,NEXT,INITIAL,LASTDFN1,LASTDFN2,HIGHEST
S LASTDFN1=+$O(^PS(55,DFN1,"IV",9999999999),-1)
S LASTDFN2=+$O(^PS(55,DFN2,"IV",9999999999),-1)
S HIGHEST=$S(LASTDFN1>LASTDFN2:LASTDFN1,1:LASTDFN2)
S (NEXT,INITIAL)=HIGHEST+1
F ORDERS=0:0 S ORDERS=$O(^PS(55,DFN1,"IV",ORDERS)) Q:'ORDERS D
. M ^PS(55,DFN2,"IV",NEXT)=^PS(55,DFN1,"IV",ORDERS) ; Move to new order
. D UPDBML(DFN1,ORDERS_"V",DFN2,NEXT_"V") ; Update BCMA MED LOG file (#53.79), ORDER REFERENCE NUMBER field (#.11)
. ; 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,DFN2,"IV",NEXT,0),"^")=NEXT
. ; 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)_"^"_NEXT
. ; Set new X-refs
. K DIK,DA S DA=NEXT,DA(1)=DFN2,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(DFN2,NEXT)
. D EN1^PSJHL2(DFN1,"OC",ORDERS_"V") ; Update CPRS pointer to old order
. D EN1^PSJHL2(DFN2,"SC",NEXT_"V") ; Update CPRS pointer to new order
. ; Delete old order
. K ^PS(55,DFN1,"IV",ORDERS)
. S NEXT=NEXT+1
; Kills remaining x-refs
K ^PS(55,DFN1,"IV","AIN")
;
; Check Previous and Following order numbers
N PREV,FOLL,NEW,PREVIEN
F ORDERS=0:0 S ORDERS=$O(^TMP("PSJMERGE_IV",$J,ORDERS)) Q:'ORDERS D
. S (NEW,PREV,FOLL,PREVIEN)=""
. S:$P(^TMP("PSJMERGE_IV",$J,ORDERS),"^",4)]"" NEW=$P(^TMP("PSJMERGE_IV",$J,ORDERS),"^",4)
. S:$P(^TMP("PSJMERGE_IV",$J,ORDERS),"^",2)]"" PREV=$P(^TMP("PSJMERGE_IV",$J,ORDERS),"^",2)
. I PREV]"" S PREVIEN=$S($D(^TMP("PSJMERGE_IV",$J,+PREV)):$P(^TMP("PSJMERGE_IV",$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"
F ORDER=INITIAL:1 Q:'$D(^PS(55,DFN2,"IV",ORDER)) D
. S PREV=$P(^PS(55,DFN2,"IV",ORDER,2),"^",5),FOLL=$P(^PS(55,DFN2,"IV",ORDER,2),"^",6)
. I PREV["V",$D(^TMP("PSJMERGE_IV",$J,+PREV)) D
. . S $P(^PS(55,DFN2,5,ORDER,2),"^",5)=$P(^TMP("PSJMERGE_IV",$J,+PREV),"^",4)_"U"
. I FOLL["V",$D(^TMP("PSJMERGE_IV",$J,+FOLL)) D
. . S $P(^PS(55,DFN2,5,ORDER,2),"^",6)=$P(^TMP("PSJMERGE_IV",$J,+FOLL),"^",4)_"U"
;
S $P(^PS(55,DFN1,"IV",0),"^",3,4)="0^0" ; reset last used IEN for FROM patient
S $P(^PS(55,DFN2,"IV",0),"^",3,4)=(NEXT-1)_"^"_(NEXT-1) ; reset last used IEN for TO patient
;PSJ*5.0*431: set second piece with sub-file if not already set.
I $P(^PS(55,DFN2,"IV",0),"^",2)="" S $P(^PS(55,DFN2,"IV",0),"^",2)=55.01
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
. ;*217 If pick list is filed away or to be filed away, it should not stop merge.
. I $D(^PS(53.5,PLNUM,1,"B",PSJDFN1,PSJDFN1)),'$P(^PS(53.5,PLNUM,0),"^",5) 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
;
UPDBML(FROMDFN,FROMORD,TODFN,TOORD) ; Update the ORDER REFERENCE NUMBER field (#.11) on the BCMA MED LOG file (#53.79)
; Input: FROMDFN - From Patient IEN - Pointer to the PATIENT file (#2)
; FROMORD - Original Order Number Pointer and Type of order being moved (e.g., "24U", "55V", etc.)
; TODFN - To Patient IEN - Pointer to the PATIENT file (#2)
; TOORD - New Order Number Pointer and Type of order being moved (e.g., "48U", "105V", etc.)
;
N DTTM,BMLIEN,DIE,DA,DR
S (DTTM,BMLIEN)=0
F S DTTM=$O(^PSB(53.79,"AORDX",FROMDFN,FROMORD,DTTM)) Q:'DTTM D
. F S BMLIEN=$O(^PSB(53.79,"AORDX",FROMDFN,FROMORD,DTTM,BMLIEN)) Q:'BMLIEN D
. . S DIE="^PSB(53.79,",DA=BMLIEN,DR=".11////"_TOORD D ^DIE
; Setting (Beforehand) and Killing some x-refs that do not get set/cleaned up by the Merge routines
M ^PSB(53.79,"AADT",TODFN)=^PSB(53.79,"AADT",FROMDFN)
M ^PSB(53.79,"AEDT",TODFN)=^PSB(53.79,"AEDT",FROMDFN)
M ^PSB(53.79,"AOIP",TODFN)=^PSB(53.79,"AOIP",FROMDFN)
K ^PSB(53.79,"AADT",FROMDFN)
K ^PSB(53.79,"AEDT",FROMDFN)
K ^PSB(53.79,"AOIP",FROMDFN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPATMR 10069 printed Nov 22, 2024@17:18:44 Page 2
PSJPATMR ;BIR/RSB - UTILITY FOR PATIENT MERGE ;Apr 19, 2022@14:12
+1 ;;5.0;INPATIENT MEDICATIONS;**36,217,404,431**;16 DEC 97;Build 5
+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 ; Reference to ^PSB(53.79 is supported by DBIA 3370.
+8 ;
EN(DFN1,DFN2) ; Patient DFN1 (FROM) / DFN2 (TO)
+1 ; check active IV, UD, and Orders on a pick list
+2 IF $$CHKIVACT(DFN1)!($$CHKUDACT(DFN1))!($$CHKPL(DFN1))
QUIT 0
+3 KILL ^TMP("PSJMERGE_UD",$JOB),^TMP("PSJMERGE_IV",$JOB)
+4 DO MOVEUD(DFN1,DFN2)
+5 DO MOVEIV(DFN1,DFN2)
+6 KILL ^TMP("PSJMERGE_UD",$JOB),^TMP("PSJMERGE_IV",$JOB)
+7 QUIT 1
+8 ;
MOVEUD(DFN1,DFN2) ; move all Unit Dose orders for FROM patient
+1 NEW ORDERS,XREF,X,NEXT,INITIAL,LASTDFN1,LASTDFN2,HIGHEST
+2 SET LASTDFN1=+$ORDER(^PS(55,DFN1,5,9999999999),-1)
+3 SET LASTDFN2=+$ORDER(^PS(55,DFN2,5,9999999999),-1)
+4 SET HIGHEST=$SELECT(LASTDFN1>LASTDFN2:LASTDFN1,1:LASTDFN2)
+5 SET (NEXT,INITIAL)=HIGHEST+1
+6 FOR ORDERS=0:0
SET ORDERS=$ORDER(^PS(55,DFN1,5,ORDERS))
if 'ORDERS
QUIT
Begin DoDot:1
+7 ; Move to new order
MERGE ^PS(55,DFN2,5,NEXT)=^PS(55,DFN1,5,ORDERS)
+8 ; Update BCMA MED LOG file (#53.79), ORDER REFERENCE NUMBER field (#.11)
DO UPDBML(DFN1,ORDERS_"U",DFN2,NEXT_"U")
+9 ; set .01 order number if not a number from 53.1
+10 IF ORDERS=+$PIECE($GET(^PS(55,DFN1,5,ORDERS,0)),"^")
SET $PIECE(^PS(55,DFN2,5,NEXT,0),"^")=NEXT
+11 SET $PIECE(^PS(55,DFN2,5,NEXT,0),"^",15)=DFN2
+12 ; kill xrefs
+13 KILL DA
SET DA=ORDERS
SET DA(1)=DFN1
+14 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)
+15 KILL ^PS(55,"ANV",DA(1),DA)
+16 KILL ^PS(55,"APV",DA(1),DA)
+17 KILL ^PS(55,"AUE",DA(1),DA)
+18 SET X=$PIECE($GET(^PS(55,DA(1),5,DA,2)),"^",4)
KILL ^PS(55,"AUD",$EXTRACT(X,1,30),DA(1),DA)
+19 SET X=$PIECE($GET(^PS(55,DA(1),5,DA,2)),"^",2)
KILL ^PS(55,"AUDDD",$EXTRACT(X,1,30),DA(1),DA)
+20 KILL ^PS(55,"AUDS",$EXTRACT(X,1,30),DA(1),DA)
+21 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)
+22 ; set table for previous and following order numbers
+23 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)_"^"_NEXT
+24 ; Set new X-refs
+25 KILL DIK,DA
SET DA=NEXT
SET DA(1)=DFN2
SET DIK="^PS(55,"_DA(1)_",5,"
+26 FOR XREF=.5,7,51,50,34,64,10,".01^AUE^B"
SET DIK(1)=XREF
DO EN^DIK
+27 DO CNVUD(DFN2,NEXT)
+28 ; Cancel CPRS order from Patient 'From'
DO EN1^PSJHL2(DFN1,"OC",ORDERS_"U")
+29 ; Update CPRS with order from Patient 'To'
DO EN1^PSJHL2(DFN2,"SC",NEXT_"U")
+30 ; kill entire order
+31 KILL ^PS(55,DFN1,5,ORDERS)
+32 SET NEXT=NEXT+1
End DoDot:1
+33 ; Kills remaining x-refs
+34 FOR XREF="B","C","AU","AUS"
KILL ^PS(55,DFN1,5,XREF)
+35 ;
+36 ; Check Previous and Following order numbers
+37 NEW ORDER,PREV,FOLL,NEW,OLD,PREVIEN
+38 FOR ORDERS=0:0
SET ORDERS=$ORDER(^TMP("PSJMERGE_UD",$JOB,ORDERS))
if 'ORDERS
QUIT
Begin DoDot:1
+39 SET (NEW,PREV,FOLL,PREVIEN)=""
+40 if $PIECE(^TMP("PSJMERGE_UD",$JOB,ORDERS),"^",4)]""
SET NEW=$PIECE(^TMP("PSJMERGE_UD",$JOB,ORDERS),"^",4)
+41 if $PIECE(^TMP("PSJMERGE_UD",$JOB,ORDERS),"^",2)]""
SET PREV=$PIECE(^TMP("PSJMERGE_UD",$JOB,ORDERS),"^",2)
+42 IF PREV]""
SET PREVIEN=$SELECT($DATA(^TMP("PSJMERGE_UD",$JOB,+PREV)):$PIECE(^TMP("PSJMERGE_UD",$JOB,+PREV),"^",4),1:PREV)
Begin DoDot:2
+43 IF PREV["P"
IF $DATA(^PS(53.1,+PREVIEN,0))
SET $PIECE(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"U"
End DoDot:2
End DoDot:1
+44 FOR ORDER=INITIAL:1
if '$DATA(^PS(55,DFN2,5,ORDER))
QUIT
Begin DoDot:1
+45 SET PREV=$PIECE(^PS(55,DFN2,5,ORDER,0),"^",25)
SET FOLL=$PIECE(^PS(55,DFN2,5,ORDER,0),"^",26)
+46 IF PREV["U"
IF $DATA(^TMP("PSJMERGE_UD",$JOB,+PREV))
Begin DoDot:2
+47 SET $PIECE(^PS(55,DFN2,5,ORDER,0),"^",25)=$PIECE(^TMP("PSJMERGE_UD",$JOB,+PREV),"^",4)_"U"
End DoDot:2
+48 IF FOLL["U"
IF $DATA(^TMP("PSJMERGE_UD",$JOB,+FOLL))
Begin DoDot:2
+49 SET $PIECE(^PS(55,DFN2,5,ORDER,0),"^",26)=$PIECE(^TMP("PSJMERGE_UD",$JOB,+FOLL),"^",4)_"U"
End DoDot:2
End DoDot:1
+50 ;
+51 ; reset last used IEN for FROM patient
SET $PIECE(^PS(55,DFN1,5,0),"^",3,4)="0^0"
+52 ; reset last used IEN for TO patient
SET $PIECE(^PS(55,DFN2,5,0),"^",3,4)=(NEXT-1)_"^"_(NEXT-1)
+53 ;PSJ*5.0*431: set second piece with sub-file if not already set.
+54 IF $PIECE(^PS(55,DFN2,5,0),"^",2)=""
SET $PIECE(^PS(55,DFN2,5,0),"^",2)="55.06IA"
+55 KILL ^PS(55,"CIMOU",DFN1)
+56 QUIT
+57 ;
MOVEIV(DFN1,DFN2) ; move all IV orders for FROM patient
+1 NEW ORDERS,X,XREF,NEXT,INITIAL,LASTDFN1,LASTDFN2,HIGHEST
+2 SET LASTDFN1=+$ORDER(^PS(55,DFN1,"IV",9999999999),-1)
+3 SET LASTDFN2=+$ORDER(^PS(55,DFN2,"IV",9999999999),-1)
+4 SET HIGHEST=$SELECT(LASTDFN1>LASTDFN2:LASTDFN1,1:LASTDFN2)
+5 SET (NEXT,INITIAL)=HIGHEST+1
+6 FOR ORDERS=0:0
SET ORDERS=$ORDER(^PS(55,DFN1,"IV",ORDERS))
if 'ORDERS
QUIT
Begin DoDot:1
+7 ; Move to new order
MERGE ^PS(55,DFN2,"IV",NEXT)=^PS(55,DFN1,"IV",ORDERS)
+8 ; Update BCMA MED LOG file (#53.79), ORDER REFERENCE NUMBER field (#.11)
DO UPDBML(DFN1,ORDERS_"V",DFN2,NEXT_"V")
+9 ; set .01 order number if not a number from 53.1
+10 IF ORDERS=+$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^")
SET $PIECE(^PS(55,DFN2,"IV",NEXT,0),"^")=NEXT
+11 ; kill xrefs
+12 KILL DA
SET DA=ORDERS
SET DA(1)=DFN1
+13 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)
+14 if X'="N"
KILL ^PS(55,"ANVO",DA(1),DA)
+15 SET X=$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^",3)
KILL ^PS(55,DA(1),"IV","AIS",$EXTRACT(X,1,30),DA)
+16 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)
+17 KILL ^PS(55,"AIV",+$EXTRACT(X,1,30),DA(1),DA)
+18 SET X=$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^",2)
KILL ^PS(55,"AIVS",$EXTRACT(X,1,30),DA(1),DA)
+19 SET X=$PIECE($GET(^PS(55,DFN1,"IV",ORDERS,0)),"^")
KILL ^PS(55,DA(1),"IV","B",$EXTRACT(X,1,30),DA)
+20 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)_"^"_NEXT
+21 ; Set new X-refs
+22 KILL DIK,DA
SET DA=NEXT
SET DA(1)=DFN2
SET DIK="^PS(55,"_DA(1)_",""IV"","
+23 FOR XREF="100^ADC^ANVO",".03^AIS^AIT^AIV",".02^AIVS",".01^B"
SET DIK(1)=XREF
DO EN^DIK
+24 DO CNVIV(DFN2,NEXT)
+25 ; Update CPRS pointer to old order
DO EN1^PSJHL2(DFN1,"OC",ORDERS_"V")
+26 ; Update CPRS pointer to new order
DO EN1^PSJHL2(DFN2,"SC",NEXT_"V")
+27 ; Delete old order
+28 KILL ^PS(55,DFN1,"IV",ORDERS)
+29 SET NEXT=NEXT+1
End DoDot:1
+30 ; Kills remaining x-refs
+31 KILL ^PS(55,DFN1,"IV","AIN")
+32 ;
+33 ; Check Previous and Following order numbers
+34 NEW PREV,FOLL,NEW,PREVIEN
+35 FOR ORDERS=0:0
SET ORDERS=$ORDER(^TMP("PSJMERGE_IV",$JOB,ORDERS))
if 'ORDERS
QUIT
Begin DoDot:1
+36 SET (NEW,PREV,FOLL,PREVIEN)=""
+37 if $PIECE(^TMP("PSJMERGE_IV",$JOB,ORDERS),"^",4)]""
SET NEW=$PIECE(^TMP("PSJMERGE_IV",$JOB,ORDERS),"^",4)
+38 if $PIECE(^TMP("PSJMERGE_IV",$JOB,ORDERS),"^",2)]""
SET PREV=$PIECE(^TMP("PSJMERGE_IV",$JOB,ORDERS),"^",2)
+39 IF PREV]""
SET PREVIEN=$SELECT($DATA(^TMP("PSJMERGE_IV",$JOB,+PREV)):$PIECE(^TMP("PSJMERGE_IV",$JOB,+PREV),"^",4),1:PREV)
Begin DoDot:2
+40 IF PREV["P"
IF $DATA(^PS(53.1,+PREVIEN,0))
SET $PIECE(^PS(53.1,+PREVIEN,0),"^",26)=NEW_"V"
End DoDot:2
End DoDot:1
+41 FOR ORDER=INITIAL:1
if '$DATA(^PS(55,DFN2,"IV",ORDER))
QUIT
Begin DoDot:1
+42 SET PREV=$PIECE(^PS(55,DFN2,"IV",ORDER,2),"^",5)
SET FOLL=$PIECE(^PS(55,DFN2,"IV",ORDER,2),"^",6)
+43 IF PREV["V"
IF $DATA(^TMP("PSJMERGE_IV",$JOB,+PREV))
Begin DoDot:2
+44 SET $PIECE(^PS(55,DFN2,5,ORDER,2),"^",5)=$PIECE(^TMP("PSJMERGE_IV",$JOB,+PREV),"^",4)_"U"
End DoDot:2
+45 IF FOLL["V"
IF $DATA(^TMP("PSJMERGE_IV",$JOB,+FOLL))
Begin DoDot:2
+46 SET $PIECE(^PS(55,DFN2,5,ORDER,2),"^",6)=$PIECE(^TMP("PSJMERGE_IV",$JOB,+FOLL),"^",4)_"U"
End DoDot:2
End DoDot:1
+47 ;
+48 ; reset last used IEN for FROM patient
SET $PIECE(^PS(55,DFN1,"IV",0),"^",3,4)="0^0"
+49 ; reset last used IEN for TO patient
SET $PIECE(^PS(55,DFN2,"IV",0),"^",3,4)=(NEXT-1)_"^"_(NEXT-1)
+50 ;PSJ*5.0*431: set second piece with sub-file if not already set.
+51 IF $PIECE(^PS(55,DFN2,"IV",0),"^",2)=""
SET $PIECE(^PS(55,DFN2,"IV",0),"^",2)=55.01
+52 QUIT
+53 ;
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) ;Check to see if FROM patient is contained on any pick lists
+1 NEW PLNUM,PSJFLAG
+2 SET PSJFLAG=0
+3 FOR PLNUM=0:0
SET PLNUM=$ORDER(^PS(53.5,PLNUM))
if 'PLNUM
QUIT
Begin DoDot:1
+4 ;*217 If pick list is filed away or to be filed away, it should not stop merge.
+5 IF $DATA(^PS(53.5,PLNUM,1,"B",PSJDFN1,PSJDFN1))
IF '$PIECE(^PS(53.5,PLNUM,0),"^",5)
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 ;
UPDBML(FROMDFN,FROMORD,TODFN,TOORD) ; Update the ORDER REFERENCE NUMBER field (#.11) on the BCMA MED LOG file (#53.79)
+1 ; Input: FROMDFN - From Patient IEN - Pointer to the PATIENT file (#2)
+2 ; FROMORD - Original Order Number Pointer and Type of order being moved (e.g., "24U", "55V", etc.)
+3 ; TODFN - To Patient IEN - Pointer to the PATIENT file (#2)
+4 ; TOORD - New Order Number Pointer and Type of order being moved (e.g., "48U", "105V", etc.)
+5 ;
+6 NEW DTTM,BMLIEN,DIE,DA,DR
+7 SET (DTTM,BMLIEN)=0
+8 FOR
SET DTTM=$ORDER(^PSB(53.79,"AORDX",FROMDFN,FROMORD,DTTM))
if 'DTTM
QUIT
Begin DoDot:1
+9 FOR
SET BMLIEN=$ORDER(^PSB(53.79,"AORDX",FROMDFN,FROMORD,DTTM,BMLIEN))
if 'BMLIEN
QUIT
Begin DoDot:2
+10 SET DIE="^PSB(53.79,"
SET DA=BMLIEN
SET DR=".11////"_TOORD
DO ^DIE
End DoDot:2
End DoDot:1
+11 ; Setting (Beforehand) and Killing some x-refs that do not get set/cleaned up by the Merge routines
+12 MERGE ^PSB(53.79,"AADT",TODFN)=^PSB(53.79,"AADT",FROMDFN)
+13 MERGE ^PSB(53.79,"AEDT",TODFN)=^PSB(53.79,"AEDT",FROMDFN)
+14 MERGE ^PSB(53.79,"AOIP",TODFN)=^PSB(53.79,"AOIP",FROMDFN)
+15 KILL ^PSB(53.79,"AADT",FROMDFN)
+16 KILL ^PSB(53.79,"AEDT",FROMDFN)
+17 KILL ^PSB(53.79,"AOIP",FROMDFN)
+18 QUIT
