Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSJPATMR

PSJPATMR.m

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