PSJUTL1 ;BIR/MLM-MISC. INPATIENT UTILITIES ;29 Jul 98 / 4:29 PM
;;5.0;INPATIENT MEDICATIONS;**15,50,58,260**;16 DEC 97;Build 94
;
; Reference to ^PSSLOCK is supported by DBIA# 2789.
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PS(50.7 is supported by DBIA# 2180.
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^PS(52.7 is supported by DBIA# 2173.
; Reference to ^PS(59.7 is supported by DBIA# 2181.
; Reference to ^PSDRUG is supported by DBIA# 2192.
; Reference to ^XPD(9.7 is supported by DBIA# 2197.
; Reference to ^PSSDIUTL is supported by DBIA# 5737.
;
CONVERT(DFN,TYPE) ;
; Convert existing UD orders to new format. Only run once/patient, and
; only converts orders with a stop date<(5.0 Install date-365)
; DFN = Patient IEN
; TYPE = Background or Interactive mode
;
S TYPE=TYPE&($E($G(IOST))="C")
;I '$D(^PS(55,DFN,0))!($P($G(^PS(55,DFN,5.1)),U,11)=1) Q
;I $S($P($G(^PS(55,DFN,5.1)),U,11)=1:1,$O(^PS(55,DFN,"IV",0)):0,$O(^PS(55,DFN,5,0)):0,1:'$O(^PS(53.1,"C",DFN,0))) Q
I $P($G(^PS(55,DFN,5.1)),U,11)=1 Q
N ADS,ADS1,DDRG,ND,ON,ON1,PSGDT,PSJOI,STAT,STPDT,STS,X,XX,X1,X2
;I '$D(^PS(55,DFN,0)) D
;I '$D(^PS(55,DFN,0))&(($O(^PS(55,DFN,"IV",0)))!($O(^PS(55,DFN,5,0)))!($O(^PS(53.1,"C",DFN,0)))) D
I '$D(^PS(55,DFN,0))&($D(^PS(55,DFN))!($O(^PS(53.1,"C",DFN,0)))) D
.N X,Y,DA,DIK S ^PS(55,DFN,0)=DFN K DIK S DA=DFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK
;I TYPE W !!,"Converting old orders for ",$P($G(^DPT(DFN,0)),U)," to new format."
S X1=$P($G(^PS(59.7,1,20)),U,2),X2=-365 I 'X1 D NOW^%DTC S X1=$P(%,".")
D C^%DTC S PSGDT=X
;Convert and Backfill orders in 53.1.
F STAT="D","DE","N","P","U" S STS=$O(^PS(53.1,"AS",STAT)) F ON=0:0 S ON=$O(^PS(53.1,"AS",STAT,DFN,ON)) Q:'ON I '$G(^PS(53.1,ON,.2)) D
.S PSJOI="",ND=$G(^PS(53.1,+ON,.1)),DDRG=+$G(^PS(53.1,ON,1,+$O(^PS(53.1,ON,1,0)),0)) S:DDRG PSJOI=+$G(^PSDRUG(DDRG,2))
.I 'PSJOI F DDRG=0:0 S DDRG=$O(^PSDRUG("AP",+ND,DDRG)) Q:'DDRG!PSJOI S PSJOI=+$G(^PSDRUG(DDRG,2)) D
.; convert pending UD orders that have "I" in 4th piece for TYPE
.I STAT="P",($P($G(^PS(53.1,ON,0)),"^",4)="I"),(PSJOI) S $P(^PS(53.1,ON,0),"^",4)=$$CNV2(PSJOI)
.I PSJOI S ^PS(53.1,ON,.2)=PSJOI_U_$P(ND,U,2) W:TYPE "."
.I PSJOI!($P($G(^PS(53.1,+ON,0)),U,4)="F") D EN1^PSJHL2(DFN,"ZC",ON_"P")
.; convert order location codes for ^PS(53.1
.K PSJXX S PSJXX=$G(^PS(53.1,ON,0)) I $L(PSJXX) S $P(PSJXX,"^",25,26)=$$CNV($P(PSJXX,"^",25))_"^"_$$CNV($P(PSJXX,"^",26)) S ^(0)=PSJXX K PSJXX
;Convert and Backfill UD orders.
F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,5,"AUS",STPDT)) Q:'STPDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",STPDT,ON)) Q:'ON 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) W:TYPE "." D EN1^PSJHL2(DFN,"ZC",ON_"U")
.; convert order location codes for Unit Dose orders
.K PSJXX S PSJXX=$G(^PS(55,DFN,5,ON,0)) I $L(PSJXX) S $P(PSJXX,"^",25,26)=$$CNV($P(PSJXX,"^",25))_"^"_$$CNV($P(PSJXX,"^",26)) S ^(0)=PSJXX K PSJXX
;Convert and Backfill IV orders.
F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,"IV","AIS",STPDT)) Q:'STPDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",STPDT,ON)) Q:'ON 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) W:TYPE "."
.S PSJ200=$P($G(^PS(55,DFN,"IV",ON,2)),U,3) Q:PSJ200=""
.S X=$O(^VA(200,"B",PSJ200,0)),XX=$O(^VA(200,"B",PSJ200,X))
.I 'X!XX S ^XTMP("PSJ NEW PERSON",PSJ200,DFN,ON)="" Q
.S $P(^PS(55,DFN,"IV",ON,2),U,11)=X
.D EN1^PSJHL2(DFN,"ZC",ON_"V")
.; convert order location codes for IVs
.K PSJXX S PSJXX=$G(^PS(55,DFN,"IV",ON,2)) I $L(PSJXX) S $P(PSJXX,"^",5,6)=$$CNV($P(PSJXX,"^",5))_"^"_$$CNV($P(PSJXX,"^",6)) S ^(2)=PSJXX K PSJXX
;Delete Unreleased entries after converting.
F ON=0:0 S ON=$O(^PS(53.1,"AS","U",DFN,ON)) Q:'ON I $G(^PS(53.1,ON,.2)) S DIK="^PS(53.1,",DA=ON D ^DIK K DIK
S:$D(^PS(55,DFN,0)) $P(^PS(55,DFN,5.1),U,11)=1
Q
;
NFWS(DFN,ON,PSJPWD) ; Determine if order is NF or WS
;Input: DFN - Patient IEN
; ON - Order #_Order Code
; PSJPWD - IEN of patient's ward
; Where Order Code IDs order location ("P":53.1; "U":55.06,1:55.01)
;Output: NF flag^WS flag^Self Med^Hosp Supplied Self Med
N ND
Q:$S(ON["U":0,1:ON'["P") ""
;S PSJPWD="",X=$P($G(^DPT(DFN,.1)),U) I X]"" S PSJPWD=$O(^DIC(42,"B",X,0))
S PSJ="",PSJREF=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,")_+ON_","
F PSJDD=0:0 S PSJDD=$O(@(PSJREF_"1,"_PSJDD_")")) Q:'PSJDD S ND=$G(^(PSJDD,0)) D CHKDD
S $P(PSJ,U,3,4)=$P($G(@(PSJREF_"0)")),U,5,6)
Q PSJ
;
CHKDD ; Determine if dispense drug is NF or WS
;
S:$P($G(^PSDRUG(+ND,0)),U,9) $P(PSJ,U)=1
S:$$WSCHK^PSJO(PSJPWD,+ND) $P(PSJ,U,2)=1
Q
FIND ;
F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN D
.I $O(^PS(55,DFN,5,0))!$O(^PS(55,DFN,"IV",0)) D
..I '$P($G(^PS(55,DFN,5.1)),U,11) W !,DFN
Q
;
CNV(PSJM) ; converts order location codes to just 'U' 'P' and 'V'
I PSJM="" Q PSJM
I PSJM["V" Q PSJM
I PSJM["A"!(PSJM["O") Q ($E(PSJM,1,$L(+PSJM))_"U")
I PSJM["N"!(PSJM["P") Q ($E(PSJM,1,$L(+PSJM))_"P")
Q PSJM
CNV2(IEN507) ; converts pending orders with 3rd piece set to "I"
; is the orderable item marked for IV ?
I $P($G(^PS(50.7,IEN507,0)),"^",3)=1 Q "I"
E Q "U"
Q
CNIV(DFN) ;Converts OI on active and pending IV orders for POE
;for all patients or a selected patient
NEW ON,PSGDT,STPDT,START,PSJX
I $G(DFN) D Q:PSJX>1
. S PSJX=$P($G(^PS(55,DFN,5.1)),U,11)
. Q:PSJX=3
. I PSJX=2 D MARKIV^PSJUTL3(DFN) Q
;I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) Q
D NOW^%DTC S START=%
S X1=DT_".0001",X2=-365
D C^%DTC S PSGDT=X
I $G(DFN) D CNIV1(DFN),MARKIV^PSJUTL3(DFN) Q
NEW DFN
F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN D CNIV1(DFN),MARKIV^PSJUTL3(DFN)
D ENIVUD^PSJ0050
D SEND
Q
CNIV1(DFN) ;
;I $P($G(^PS(55,DFN,5.1)),U,11)=2 Q
Q:'$$L^PSSLOCK(DFN,0)
S $P(^PS(55,DFN,5.1),U,11)=2
I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) D UL^PSSLOCK(DFN) Q
F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,"IV","AIS",STPDT)) Q:'STPDT D
. F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",STPDT,ON)) Q:'ON D IVCHK
F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON D PENDING
D UL^PSSLOCK(DFN)
Q
IVCHK ;Match AD/SOL against Xtmp
NEW PSJAD,PSJCNR,PSJOI,PSJSOL,PSJXAD,PSJXNOI,PSJXSOL
S PSJOI=+$G(^PS(55,DFN,"IV",ON,.2)) Q:'+PSJOI
;
;Set local array for AD/SOL from the order
F PSJAD=0:0 S PSJAD=$O(^PS(55,DFN,"IV",ON,"AD",PSJAD)) Q:'PSJAD D
. I $G(^PS(55,DFN,"IV",ON,"AD",PSJAD,0)) S PSJAD(+^(0))=""
F PSJSOL=0:0 S PSJSOL=$O(^PS(55,DFN,"IV",ON,"SOL",PSJSOL)) Q:'PSJSOL D
. I $G(^PS(55,DFN,"IV",ON,"SOL",PSJSOL,0)) S PSJSOL(+^(0))=""
D MATCH,UPD(ON_"V")
Q
;
MATCH ;If AD/SOL from XTMP matches to AD/SOL within the order, set new OI array
K PSJXNOI
F PSJXAD=0:0 S PSJXAD=$O(^XTMP("PSSCONA",+PSJOI,PSJXAD)) Q:'PSJXAD D
. I $D(PSJAD(PSJXAD)) S PSJXNOI(+^XTMP("PSSCONA",+PSJOI,PSJXAD))=""
F PSJXSOL=0:0 S PSJXSOL=$O(^XTMP("PSSCONS",+PSJOI,PSJXSOL)) Q:'PSJXSOL D
. I $D(PSJSOL(PSJXSOL)) S PSJXNOI(+^XTMP("PSSCONS",+PSJOI,PSJXSOL))=""
Q
;
UPD(ON) ;Loop thru the new OI array
NEW PSJCNT S PSJCNT=0
F X=0:0 S X=$O(PSJXNOI(X)) Q:'X S PSJCNT=PSJCNT+1
I PSJCNT=1 D
. S PSJXNOI=$O(PSJXNOI(0))
. I +PSJOI=PSJXNOI Q
. S X=$P($G(^PS(50.7,PSJXNOI,0)),U,4)
. I X]"",(X'>DT) Q
. ;/W !,"DFN: ",DFN," ON: ",ON," NEW OI: ",PSJXNOI
. S:ON["V" $P(^PS(55,DFN,"IV",+ON,.2),U,1)=+PSJXNOI
. S:ON["P" $P(^PS(53.1,+ON,.2),U,1)=+PSJXNOI
. D EN1^PSJHL2(DFN,"ZC",ON)
. D EN^PSJ0050(DFN,+ON,+PSJOI,PSJXNOI)
Q
PENDING ;Converting Pending IV order with Ad/Sol
NEW PSJAD,PSJOI,PSJSOL,PSJXNOI
S X=$P($G(^PS(53.1,ON,0)),U,4) I $S(X="I":0,X="F":0,1:1) Q
S PSJOI=+$G(^PS(53.1,ON,.2)) Q:'+PSJOI
;
;If pending has no AD/SOL, and on 1 new OI matched to old OI then update.
I '$D(^PS(53.1,ON,"AD")),'$D(^PS(53.1,ON,"SOL")) D Q
. F X=0:0 S X=$O(^XTMP("PSSCONA",PSJOI,X)) Q:'X S PSJXNOI(+^(X))=""
. F X=0:0 S X=$O(^XTMP("PSSCONS",PSJOI,X)) Q:'X S PSJXNOI(+^(X))=""
. D UPD(ON_"P")
;
;Loop thru the pending AD/SOL
F PSJAD=0:0 S PSJAD=$O(^PS(53.1,ON,"AD",PSJAD)) Q:'PSJAD D
. I $G(^PS(53.1,ON,"AD",PSJAD,0)) S PSJAD(+^(0))=""
F PSJSOL=0:0 S PSJSOL=$O(^PS(55,ON,"SOL",PSJSOL)) Q:'PSJSOL D
. I $G(^PS(53.1,ON,"SOL",PSJSOL,0)) S PSJSOL(+^(0))=""
D MATCH,UPD(ON_"P")
Q
SEND ;Send mail message
NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY,STOP,LINE
D NOW^%DTC S STOP=%
S LINE(1)="The conversion was first started: "_$$FMTE^XLFDT(START)
S LINE(2)="It ran to completion: "_$$FMTE^XLFDT(STOP)
S XMSUB="Inpatient Meds IV conversion",XMTEXT="LINE("
S XMDUZ="Inpatient Meds POE"
S XMY(+DUZ)="" D ^XMD
Q
PSSDGCK ;Run Drug Check Util
D ^PSSDIUTL
Q
INSTLDT() ;Return the date PSJ*5*58 was first installed
NEW DIC,X,Y
S X=$O(^XPD(9.7,"B","PSJ*5.0*58",0))
Q:'+X ""
S DIC="^XPD(9.7,",DIC(0)="NZ" D ^DIC
Q $P($G(Y(0)),U,3)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJUTL1 9392 printed Apr 09, 2024@21:06:58 Page 2
PSJUTL1 ;BIR/MLM-MISC. INPATIENT UTILITIES ;29 Jul 98 / 4:29 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**15,50,58,260**;16 DEC 97;Build 94
+2 ;
+3 ; Reference to ^PSSLOCK is supported by DBIA# 2789.
+4 ; Reference to ^PS(55 is supported by DBIA# 2191.
+5 ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+6 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+7 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+8 ; Reference to ^PS(59.7 is supported by DBIA# 2181.
+9 ; Reference to ^PSDRUG is supported by DBIA# 2192.
+10 ; Reference to ^XPD(9.7 is supported by DBIA# 2197.
+11 ; Reference to ^PSSDIUTL is supported by DBIA# 5737.
+12 ;
CONVERT(DFN,TYPE) ;
+1 ; Convert existing UD orders to new format. Only run once/patient, and
+2 ; only converts orders with a stop date<(5.0 Install date-365)
+3 ; DFN = Patient IEN
+4 ; TYPE = Background or Interactive mode
+5 ;
+6 SET TYPE=TYPE&($EXTRACT($GET(IOST))="C")
+7 ;I '$D(^PS(55,DFN,0))!($P($G(^PS(55,DFN,5.1)),U,11)=1) Q
+8 ;I $S($P($G(^PS(55,DFN,5.1)),U,11)=1:1,$O(^PS(55,DFN,"IV",0)):0,$O(^PS(55,DFN,5,0)):0,1:'$O(^PS(53.1,"C",DFN,0))) Q
+9 IF $PIECE($GET(^PS(55,DFN,5.1)),U,11)=1
QUIT
+10 NEW ADS,ADS1,DDRG,ND,ON,ON1,PSGDT,PSJOI,STAT,STPDT,STS,X,XX,X1,X2
+11 ;I '$D(^PS(55,DFN,0)) D
+12 ;I '$D(^PS(55,DFN,0))&(($O(^PS(55,DFN,"IV",0)))!($O(^PS(55,DFN,5,0)))!($O(^PS(53.1,"C",DFN,0)))) D
+13 IF '$DATA(^PS(55,DFN,0))&($DATA(^PS(55,DFN))!($ORDER(^PS(53.1,"C",DFN,0))))
Begin DoDot:1
+14 NEW X,Y,DA,DIK
SET ^PS(55,DFN,0)=DFN
KILL DIK
SET DA=DFN
SET DIK="^PS(55,"
SET DIK(1)=.01
DO EN^DIK
End DoDot:1
+15 ;I TYPE W !!,"Converting old orders for ",$P($G(^DPT(DFN,0)),U)," to new format."
+16 SET X1=$PIECE($GET(^PS(59.7,1,20)),U,2)
SET X2=-365
IF 'X1
DO NOW^%DTC
SET X1=$PIECE(%,".")
+17 DO C^%DTC
SET PSGDT=X
+18 ;Convert and Backfill orders in 53.1.
+19 FOR STAT="D","DE","N","P","U"
SET STS=$ORDER(^PS(53.1,"AS",STAT))
FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AS",STAT,DFN,ON))
if 'ON
QUIT
IF '$GET(^PS(53.1,ON,.2))
Begin DoDot:1
+20 SET PSJOI=""
SET ND=$GET(^PS(53.1,+ON,.1))
SET DDRG=+$GET(^PS(53.1,ON,1,+$ORDER(^PS(53.1,ON,1,0)),0))
if DDRG
SET PSJOI=+$GET(^PSDRUG(DDRG,2))
+21 IF 'PSJOI
FOR DDRG=0:0
SET DDRG=$ORDER(^PSDRUG("AP",+ND,DDRG))
if 'DDRG!PSJOI
QUIT
SET PSJOI=+$GET(^PSDRUG(DDRG,2))
Begin DoDot:2
End DoDot:2
+22 ; convert pending UD orders that have "I" in 4th piece for TYPE
+23 IF STAT="P"
IF ($PIECE($GET(^PS(53.1,ON,0)),"^",4)="I")
IF (PSJOI)
SET $PIECE(^PS(53.1,ON,0),"^",4)=$$CNV2(PSJOI)
+24 IF PSJOI
SET ^PS(53.1,ON,.2)=PSJOI_U_$PIECE(ND,U,2)
if TYPE
WRITE "."
+25 IF PSJOI!($PIECE($GET(^PS(53.1,+ON,0)),U,4)="F")
DO EN1^PSJHL2(DFN,"ZC",ON_"P")
+26 ; convert order location codes for ^PS(53.1
+27 KILL PSJXX
SET PSJXX=$GET(^PS(53.1,ON,0))
IF $LENGTH(PSJXX)
SET $PIECE(PSJXX,"^",25,26)=$$CNV($PIECE(PSJXX,"^",25))_"^"_$$CNV($PIECE(PSJXX,"^",26))
SET ^(0)=PSJXX
KILL PSJXX
End DoDot:1
+28 ;Convert and Backfill UD orders.
+29 FOR STPDT=PSGDT:0
SET STPDT=$ORDER(^PS(55,DFN,5,"AUS",STPDT))
if 'STPDT
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,5,"AUS",STPDT,ON))
if 'ON
QUIT
IF '$GET(^PS(55,DFN,5,ON,.2))
Begin DoDot:1
+30 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))
+31 IF 'PSJOI
FOR DDRG=0:0
SET DDRG=$ORDER(^PSDRUG("AP",+ND,DDRG))
if 'DDRG!PSJOI
QUIT
SET PSJOI=+$GET(^PSDRUG(DDRG,2))
+32 IF PSJOI
SET ^PS(55,DFN,5,ON,.2)=PSJOI_U_$PIECE(ND,U,2)
if TYPE
WRITE "."
DO EN1^PSJHL2(DFN,"ZC",ON_"U")
+33 ; convert order location codes for Unit Dose orders
+34 KILL PSJXX
SET PSJXX=$GET(^PS(55,DFN,5,ON,0))
IF $LENGTH(PSJXX)
SET $PIECE(PSJXX,"^",25,26)=$$CNV($PIECE(PSJXX,"^",25))_"^"_$$CNV($PIECE(PSJXX,"^",26))
SET ^(0)=PSJXX
KILL PSJXX
End DoDot:1
+35 ;Convert and Backfill IV orders.
+36 FOR STPDT=PSGDT:0
SET STPDT=$ORDER(^PS(55,DFN,"IV","AIS",STPDT))
if 'STPDT
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,"IV","AIS",STPDT,ON))
if 'ON
QUIT
IF '$GET(^PS(55,DFN,"IV",ON,.2))
Begin DoDot:1
+37 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
+38 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)
if TYPE
WRITE "."
End DoDot:2
+39 SET PSJ200=$PIECE($GET(^PS(55,DFN,"IV",ON,2)),U,3)
if PSJ200=""
QUIT
+40 SET X=$ORDER(^VA(200,"B",PSJ200,0))
SET XX=$ORDER(^VA(200,"B",PSJ200,X))
+41 IF 'X!XX
SET ^XTMP("PSJ NEW PERSON",PSJ200,DFN,ON)=""
QUIT
+42 SET $PIECE(^PS(55,DFN,"IV",ON,2),U,11)=X
+43 DO EN1^PSJHL2(DFN,"ZC",ON_"V")
+44 ; convert order location codes for IVs
+45 KILL PSJXX
SET PSJXX=$GET(^PS(55,DFN,"IV",ON,2))
IF $LENGTH(PSJXX)
SET $PIECE(PSJXX,"^",5,6)=$$CNV($PIECE(PSJXX,"^",5))_"^"_$$CNV($PIECE(PSJXX,"^",6))
SET ^(2)=PSJXX
KILL PSJXX
End DoDot:1
+46 ;Delete Unreleased entries after converting.
+47 FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AS","U",DFN,ON))
if 'ON
QUIT
IF $GET(^PS(53.1,ON,.2))
SET DIK="^PS(53.1,"
SET DA=ON
DO ^DIK
KILL DIK
+48 if $DATA(^PS(55,DFN,0))
SET $PIECE(^PS(55,DFN,5.1),U,11)=1
+49 QUIT
+50 ;
NFWS(DFN,ON,PSJPWD) ; Determine if order is NF or WS
+1 ;Input: DFN - Patient IEN
+2 ; ON - Order #_Order Code
+3 ; PSJPWD - IEN of patient's ward
+4 ; Where Order Code IDs order location ("P":53.1; "U":55.06,1:55.01)
+5 ;Output: NF flag^WS flag^Self Med^Hosp Supplied Self Med
+6 NEW ND
+7 if $SELECT(ON["U"
QUIT ""
+8 ;S PSJPWD="",X=$P($G(^DPT(DFN,.1)),U) I X]"" S PSJPWD=$O(^DIC(42,"B",X,0))
+9 SET PSJ=""
SET PSJREF=$SELECT(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,")_+ON_","
+10 FOR PSJDD=0:0
SET PSJDD=$ORDER(@(PSJREF_"1,"_PSJDD_")"))
if 'PSJDD
QUIT
SET ND=$GET(^(PSJDD,0))
DO CHKDD
+11 SET $PIECE(PSJ,U,3,4)=$PIECE($GET(@(PSJREF_"0)")),U,5,6)
+12 QUIT PSJ
+13 ;
CHKDD ; Determine if dispense drug is NF or WS
+1 ;
+2 if $PIECE($GET(^PSDRUG(+ND,0)),U,9)
SET $PIECE(PSJ,U)=1
+3 if $$WSCHK^PSJO(PSJPWD,+ND)
SET $PIECE(PSJ,U,2)=1
+4 QUIT
FIND ;
+1 FOR DFN=0:0
SET DFN=$ORDER(^PS(55,DFN))
if 'DFN
QUIT
Begin DoDot:1
+2 IF $ORDER(^PS(55,DFN,5,0))!$ORDER(^PS(55,DFN,"IV",0))
Begin DoDot:2
+3 IF '$PIECE($GET(^PS(55,DFN,5.1)),U,11)
WRITE !,DFN
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
CNV(PSJM) ; converts order location codes to just 'U' 'P' and 'V'
+1 IF PSJM=""
QUIT PSJM
+2 IF PSJM["V"
QUIT PSJM
+3 IF PSJM["A"!(PSJM["O")
QUIT ($EXTRACT(PSJM,1,$LENGTH(+PSJM))_"U")
+4 IF PSJM["N"!(PSJM["P")
QUIT ($EXTRACT(PSJM,1,$LENGTH(+PSJM))_"P")
+5 QUIT PSJM
CNV2(IEN507) ; converts pending orders with 3rd piece set to "I"
+1 ; is the orderable item marked for IV ?
+2 IF $PIECE($GET(^PS(50.7,IEN507,0)),"^",3)=1
QUIT "I"
+3 IF '$TEST
QUIT "U"
+4 QUIT
CNIV(DFN) ;Converts OI on active and pending IV orders for POE
+1 ;for all patients or a selected patient
+2 NEW ON,PSGDT,STPDT,START,PSJX
+3 IF $GET(DFN)
Begin DoDot:1
+4 SET PSJX=$PIECE($GET(^PS(55,DFN,5.1)),U,11)
+5 if PSJX=3
QUIT
+6 IF PSJX=2
DO MARKIV^PSJUTL3(DFN)
QUIT
End DoDot:1
if PSJX>1
QUIT
+7 ;I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) Q
+8 DO NOW^%DTC
SET START=%
+9 SET X1=DT_".0001"
SET X2=-365
+10 DO C^%DTC
SET PSGDT=X
+11 IF $GET(DFN)
DO CNIV1(DFN)
DO MARKIV^PSJUTL3(DFN)
QUIT
+12 NEW DFN
+13 FOR DFN=0:0
SET DFN=$ORDER(^PS(55,DFN))
if 'DFN
QUIT
DO CNIV1(DFN)
DO MARKIV^PSJUTL3(DFN)
+14 DO ENIVUD^PSJ0050
+15 DO SEND
+16 QUIT
CNIV1(DFN) ;
+1 ;I $P($G(^PS(55,DFN,5.1)),U,11)=2 Q
+2 if '$$L^PSSLOCK(DFN,0)
QUIT
+3 SET $PIECE(^PS(55,DFN,5.1),U,11)=2
+4 IF '$DATA(^XTMP("PSSCONA"))
IF '$DATA(^XTMP("PSSCONS"))
DO UL^PSSLOCK(DFN)
QUIT
+5 FOR STPDT=PSGDT:0
SET STPDT=$ORDER(^PS(55,DFN,"IV","AIS",STPDT))
if 'STPDT
QUIT
Begin DoDot:1
+6 FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,"IV","AIS",STPDT,ON))
if 'ON
QUIT
DO IVCHK
End DoDot:1
+7 FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AS","P",DFN,ON))
if 'ON
QUIT
DO PENDING
+8 DO UL^PSSLOCK(DFN)
+9 QUIT
IVCHK ;Match AD/SOL against Xtmp
+1 NEW PSJAD,PSJCNR,PSJOI,PSJSOL,PSJXAD,PSJXNOI,PSJXSOL
+2 SET PSJOI=+$GET(^PS(55,DFN,"IV",ON,.2))
if '+PSJOI
QUIT
+3 ;
+4 ;Set local array for AD/SOL from the order
+5 FOR PSJAD=0:0
SET PSJAD=$ORDER(^PS(55,DFN,"IV",ON,"AD",PSJAD))
if 'PSJAD
QUIT
Begin DoDot:1
+6 IF $GET(^PS(55,DFN,"IV",ON,"AD",PSJAD,0))
SET PSJAD(+^(0))=""
End DoDot:1
+7 FOR PSJSOL=0:0
SET PSJSOL=$ORDER(^PS(55,DFN,"IV",ON,"SOL",PSJSOL))
if 'PSJSOL
QUIT
Begin DoDot:1
+8 IF $GET(^PS(55,DFN,"IV",ON,"SOL",PSJSOL,0))
SET PSJSOL(+^(0))=""
End DoDot:1
+9 DO MATCH
DO UPD(ON_"V")
+10 QUIT
+11 ;
MATCH ;If AD/SOL from XTMP matches to AD/SOL within the order, set new OI array
+1 KILL PSJXNOI
+2 FOR PSJXAD=0:0
SET PSJXAD=$ORDER(^XTMP("PSSCONA",+PSJOI,PSJXAD))
if 'PSJXAD
QUIT
Begin DoDot:1
+3 IF $DATA(PSJAD(PSJXAD))
SET PSJXNOI(+^XTMP("PSSCONA",+PSJOI,PSJXAD))=""
End DoDot:1
+4 FOR PSJXSOL=0:0
SET PSJXSOL=$ORDER(^XTMP("PSSCONS",+PSJOI,PSJXSOL))
if 'PSJXSOL
QUIT
Begin DoDot:1
+5 IF $DATA(PSJSOL(PSJXSOL))
SET PSJXNOI(+^XTMP("PSSCONS",+PSJOI,PSJXSOL))=""
End DoDot:1
+6 QUIT
+7 ;
UPD(ON) ;Loop thru the new OI array
+1 NEW PSJCNT
SET PSJCNT=0
+2 FOR X=0:0
SET X=$ORDER(PSJXNOI(X))
if 'X
QUIT
SET PSJCNT=PSJCNT+1
+3 IF PSJCNT=1
Begin DoDot:1
+4 SET PSJXNOI=$ORDER(PSJXNOI(0))
+5 IF +PSJOI=PSJXNOI
QUIT
+6 SET X=$PIECE($GET(^PS(50.7,PSJXNOI,0)),U,4)
+7 IF X]""
IF (X'>DT)
QUIT
+8 ;/W !,"DFN: ",DFN," ON: ",ON," NEW OI: ",PSJXNOI
+9 if ON["V"
SET $PIECE(^PS(55,DFN,"IV",+ON,.2),U,1)=+PSJXNOI
+10 if ON["P"
SET $PIECE(^PS(53.1,+ON,.2),U,1)=+PSJXNOI
+11 DO EN1^PSJHL2(DFN,"ZC",ON)
+12 DO EN^PSJ0050(DFN,+ON,+PSJOI,PSJXNOI)
End DoDot:1
+13 QUIT
PENDING ;Converting Pending IV order with Ad/Sol
+1 NEW PSJAD,PSJOI,PSJSOL,PSJXNOI
+2 SET X=$PIECE($GET(^PS(53.1,ON,0)),U,4)
IF $SELECT(X="I":0,X="F":0,1:1)
QUIT
+3 SET PSJOI=+$GET(^PS(53.1,ON,.2))
if '+PSJOI
QUIT
+4 ;
+5 ;If pending has no AD/SOL, and on 1 new OI matched to old OI then update.
+6 IF '$DATA(^PS(53.1,ON,"AD"))
IF '$DATA(^PS(53.1,ON,"SOL"))
Begin DoDot:1
+7 FOR X=0:0
SET X=$ORDER(^XTMP("PSSCONA",PSJOI,X))
if 'X
QUIT
SET PSJXNOI(+^(X))=""
+8 FOR X=0:0
SET X=$ORDER(^XTMP("PSSCONS",PSJOI,X))
if 'X
QUIT
SET PSJXNOI(+^(X))=""
+9 DO UPD(ON_"P")
End DoDot:1
QUIT
+10 ;
+11 ;Loop thru the pending AD/SOL
+12 FOR PSJAD=0:0
SET PSJAD=$ORDER(^PS(53.1,ON,"AD",PSJAD))
if 'PSJAD
QUIT
Begin DoDot:1
+13 IF $GET(^PS(53.1,ON,"AD",PSJAD,0))
SET PSJAD(+^(0))=""
End DoDot:1
+14 FOR PSJSOL=0:0
SET PSJSOL=$ORDER(^PS(55,ON,"SOL",PSJSOL))
if 'PSJSOL
QUIT
Begin DoDot:1
+15 IF $GET(^PS(53.1,ON,"SOL",PSJSOL,0))
SET PSJSOL(+^(0))=""
End DoDot:1
+16 DO MATCH
DO UPD(ON_"P")
+17 QUIT
SEND ;Send mail message
+1 NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY,STOP,LINE
+2 DO NOW^%DTC
SET STOP=%
+3 SET LINE(1)="The conversion was first started: "_$$FMTE^XLFDT(START)
+4 SET LINE(2)="It ran to completion: "_$$FMTE^XLFDT(STOP)
+5 SET XMSUB="Inpatient Meds IV conversion"
SET XMTEXT="LINE("
+6 SET XMDUZ="Inpatient Meds POE"
+7 SET XMY(+DUZ)=""
DO ^XMD
+8 QUIT
PSSDGCK ;Run Drug Check Util
+1 DO ^PSSDIUTL
+2 QUIT
INSTLDT() ;Return the date PSJ*5*58 was first installed
+1 NEW DIC,X,Y
+2 SET X=$ORDER(^XPD(9.7,"B","PSJ*5.0*58",0))
+3 if '+X
QUIT ""
+4 SET DIC="^XPD(9.7,"
SET DIC(0)="NZ"
DO ^DIC
+5 QUIT $PIECE($GET(Y(0)),U,3)
