PSJ074 ;BIR/JCH-Check for stop date problems; 28-NOV-01
;;5.0; INPATIENT MEDICATIONS ;**74**;16 DEC 97
;
;Reference to ^DD is supported by DBIA# 10017.
;Reference to ^PS(50.7 is supported by DBIA# 2180.
;Reference to ^PS(52.6 is supported by DBIA# 1231.
;Reference to ^PS(55 is supported by DBIA# 2191.
;Reference to ^%DTC is supported by DBIA# 10000.
;Reference to ^%ZTLOAD is supported by DBIA# 10063.
;Reference to ^VADPT is supported by DBIA# 10061.
;Reference to ^XLFDT is supported by DBIA# 10103.
;Reference to ^XMD is supported by DBIA# 10070.
;
ENNV ; Begin check of existing orders
I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined to run this routine." Q
K ZTSAVE,ZTSK S ZTRTN="ENQN^PSJ074",ZTDESC="Inpatient Orders Check (INPATIENT MEDS)",ZTIO="" D ^%ZTLOAD
W !!,"The check of existing Pharmacy orders is",$S($D(ZTSK):"",1:" NOT")," queued",!
I $D(ZTSK) D
. W " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED. IF"
. W !,"ERRORS ARE DETECTED, YOU WILL RECEIVE A SECOND MESSAGE INDICATING CLEANUP"
. W !,"HAS COMPLETED."
Q
ENQN ; Check of existing Pharmacy orders.
N PSJBEG,PSJPDFN,PSJORD,PSJSTOP,CREAT,EXPR,OCNT,PSJND0,PSJND2,START
N PSJSTRT
D NOW^%DTC S PSJSTART=$E(%,1,12),CREAT=$E(%,1,7)
S EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0),OCNT=0
K ^XTMP("PSJ"),^XTMP("PSJ XREF")
;
;process data nodes
S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,PSJPDFN)) Q:'PSJPDFN D
. F TYP="IV",5 D
.. S ORD=0 F S ORD=$O(^PS(55,PSJPDFN,TYP,ORD)) Q:'ORD D
... Q:$TR($P($G(^PS(55,PSJPDFN,TYP,ORD,0)),"^",2,8),"^")=""
... I TYP="IV" D
.... S PSJND0=$G(^PS(55,PSJPDFN,"IV",ORD,0))
.... S PSJSTRT=$P(PSJND0,"^",2),PSJSTOP=$P(PSJND0,"^",3)
... I TYP=5 D
.... S ND2=$G(^PS(55,PSJPDFN,TYP,ORD,2)),PSJSTRT=$P(ND2,"^",2)
.... S PSJSTOP=$P(ND2,"^",4)
... I PSJSTOP=""!($P(PSJSTOP,".",2)="")!(PSJSTOP'=+PSJSTOP)!($L(PSJSTOP)<5) D Q
.... S ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJSTRT,OCNT=OCNT+1
... I PSJSTRT=""!($P(PSJSTRT,".",2)="")!(PSJSTRT'=+PSJSTRT)!($L(PSJSTRT)<5) D
.... S ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJSTRT,OCNT=OCNT+1
S:$D(^XTMP("PSJ")) ^XTMP("PSJ",0)=EXPR_"^"_CREAT
D SENDMSG
I $D(^XTMP("PSJ")) D CLEAN
D XREFS^PSJ0742
;
DONE ;
K DAYS,MINS,HOURS,PSG,PSJSTART,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK S ZTREQ="@"
Q
;
SENDMSG ;Send mail message when check is complete.
K PSG,XMY S XMDUZ="MEDICATIONS,INPATIENT",XMSUB="INPATIENT MEDS ORDER CHECK COMPLETED",XMTEXT="PSG(",XMY(DUZ)="" D NOW^%DTC S Y=% X ^DD("DD")
S PSG(1,0)=" The check of existing Pharmacy orders for use with Inpatient",PSG(2,0)="Medications 5.0 completed as of "_Y_"."
S X=$$FMDIFF^XLFDT(%,PSJSTART,3) S:$L(X," ")>1 DAYS=+$P(X," "),X=$P(X," ",2) S HOURS=+$P(X,":"),MINS=+$P(X,":",2)
S PSG(3,0)=" ",PSG(4,0)="This process checked orders for patients in "_$S($G(DAYS):DAYS_" day"_$E("s",DAYS'=1)_", ",1:"")_HOURS_" hour"_$E("s",HOURS'=1),PSG(5,0)="and "_MINS_" minute"_$E("s",MINS'=1)_"."
S PSG(6,0)=OCNT_" pharmacy orders were found with invalid stop dates."
D ^XMD
Q
;
CLEAN ;
N PSJPDFN,PSJORD,PSJND,PSJND2,PSJSTRT,PSJLOG,Y,PSJOSTP
N PSJFOL,AD,AEN,BEG,END,DFN,PO,FSTOP,FSTRT,PCNT,FOLL0,PREV2,RFO
N OPSJSTP,OPSJSTRT,TYP,OI,OINAME,BLANK,PSGTMP
S PSJPDFN=0,BEG=1,END=0,PCNT=6,$P(BLANK," ",40)="",AEN=0
F S PSJPDFN=$O(^XTMP("PSJ",PSJPDFN)) Q:'PSJPDFN D
. F TYP="IV",5 D
.. S DFN=PSJPDFN K VADM D DEM^VADPT
.. S PSJORD=0
.. F S PSJORD=$O(^XTMP("PSJ",PSJPDFN,TYP,PSJORD)) Q:'PSJORD D
... S PSJND=$G(^PS(55,PSJPDFN,$S(TYP=5:5,1:"IV"),PSJORD,0))
... I $TR(PSJND,"^","")="" Q
... N PSJST,PSJPREV,PSJSTP,PSJSTRT,PSJFOL,OPSJSTP,OPSJSTRT
... K OINAME,FSTRT,FSTOP,STRTCHG,STOPCHG,FOLL2,FOLSTRT,PREVFO,PREV0
... K OI,FOLL0
... I TYP=5 D
.... S PSJST=$P(PSJND,"^",7) ;Schedule Type for UD(different than IV)
.... S PSJFOL=+$P(PSJND,"^",26)
.... S PSJPREV=+$P(PSJND,"^",25),PSJND2=$G(^PS(55,PSJPDFN,5,PSJORD,2))
.... S (PSJSTP,OPSJSTP)=$P(PSJND2,"^",4)
.... S (PSJSTRT,OPSJSTRT)=$P(PSJND2,"^",2)
.... S OI=$P($G(^PS(55,PSJPDFN,5,PSJORD,.2)),"^")
.... S OINAME=$S(OI:$P($G(^PS(50.7,OI,0)),"^"),1:"OI NOT FOUND")
.... I PSJFOL D
..... S FOLL0=$G(^PS(55,PSJPDFN,5,PSJFOL,0)),FOLPO=$P(FOLL0,"^",25)
..... S FOLL2=$G(^PS(55,PSJPDFN,5,PSJFOL,2)),FOLSTRT=$P(FOLL2,"^",2)
.... I PSJPREV D
..... S PSJOSTP=$P($G(^PS(55,PSJPDFN,5,PSJPREV,2)),"^",4)
..... S PREV0=$G(^PS(55,PSJPDFN,5,PSJPREV,0)),PREVFO=$P(PREV0,"^",26)
..... S PREVRFO=$P(PREV0,"^",27)
... I TYP="IV" D
.... S PSJST=$P(PSJND,"^",4),(PSJSTRT,OPSJSTRT)=$P(PSJND,"^",2)
.... S (PSJSTP,OPSJSTP)=$P(PSJND,"^",3)
.... S OI=$P($G(^PS(55,PSJPDFN,"IV",PSJORD,.2)),"^")
.... S OINAME=$S(OI:$P($G(^PS(50.7,OI,0)),"^"),1:"")
.... S PSJND2=$G(^PS(55,PSJPDFN,"IV",PSJORD,2))
.... S AD=$O(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0))
.... I OINAME="",AD]"" S AEN=$P($G(^PS(55,PSJPDFN,"IV",PSJORD,"AD",AD,0)),"^") D
..... S OINAME=$P($G(^PS(52.6,+AEN,0)),"^")
..... S:OINAME="" OINAME="OI NOT FOUND"
.... S PSJPREV=+$P(PSJND2,"^",5),PSJFOL=$P(PSJND2,"^",6)
.... I PSJFOL S FOLL0=$G(^PS(55,PSJPDFN,"IV",+PSJFOL,0)) D
..... S FOLL2=$G(^PS(55,PSJPDFN,"IV",+PSJFOL,2))
..... S FOLPO=$P(FOLL2,"^",5),FOLSTRT=$P(FOLL0,"^",2)
.... I PSJPREV S PREV2=$G(^PS(55,PSJPDFN,"IV",PSJPREV,2)) D
..... S PSJOSTP=$P($G(^PS(55,PSJPDFN,"IV",PSJPREV,0)),"^",3)
..... S PREVFO=$P(PREV2,"^",6),PREVRFO=$P(PREV2,"^",9)
... ;
... ;If there's a null start date, check if the previous order was
... ; renewed to cause this order to be created and if the stop date
... ; is there, use it
... ;If there's a null stop date, check if this order has a following
... ; order, and if the start date is there, use it
... ;Check to be sure the dates (even if acquired from a previous or
... ; following order) has a time on it; if not, make it midnight
... ;Check for trailing zeroes by forcing numeric
... ;Check for any other odd format with length < 5
... I PSJSTRT="",$G(PSJOSTP) I (+$G(PREVFO)=+PSJORD) D
.... S PSJSTRT=+PSJOSTP,STRTCHG=1
... I PSJSTRT'[".",$L(PSJSTRT)>7 S PSJSTRT=$E(PSJSTRT,1,7),STRTCHG=1
... I PSJSTRT,$P(PSJSTRT,".",2)="" S $P(PSJSTRT,".",2)=1,STRTCHG=1
... I PSJSTRT,(PSJSTRT'=+PSJSTRT) S PSJSTRT=+PSJSTRT,STRTCHG=1
... I PSJSTP="",$G(FOLSTRT) I (+$G(FOLPO)=PSJORD) D
.... S PSJSTP=FOLSTRT,STOPCHG=1
... I PSJSTP'[".",$L(PSJSTP)>7 S PSJSTP=$E(PSJSTP,1,7),STOPCHG=1
... I PSJSTP,$P(PSJSTP,".",2)="" S $P(PSJSTP,".",2)=24,STOPCHG=1
... I PSJSTP,(PSJSTP'=+PSJSTP) S PSJSTP=+PSJSTP,STOPCHG=1
... ; Prepare message with results
... I 'PSJSTRT!'PSJSTP!($G(STOPCHG))!($G(STRTCHG)) D
.... S PCNT=PCNT+1,PSGTMP=$E(VADM(1),1,25)_$E(BLANK,1,27-$L(VADM(1)))
.... S PSGTMP=PSGTMP_$P(VADM(2),"^")
.... S PSG(PCNT,0)=PSGTMP_" "_$S(TYP=5:"Unit Dose",1:"IV")
.... S Y=PSJSTRT X ^DD("DD") S FSTRT=Y,Y=PSJSTP X ^DD("DD") S FSTOP=Y
.... I $G(STOPCHG)!$G(STRTCHG) D
..... S OINAME=$G(OINAME),FSTRT=$G(FSTRT),FSTOP=$G(FSTOP),PCNT=PCNT+1
..... S PSG(PCNT,0)=" "_$E(OINAME,1,20)_$E(BLANK,1,22-$L(OINAME))
..... S PSG(PCNT,0)=PSG(PCNT,0)_"Start: "_FSTRT_" Stop: "_FSTOP
..... I $G(STOPCHG),PSJST="" S PCNT=PCNT+1 D
...... S PSG(PCNT,0)=" Missing "_$S(TYP=5:"Schedule Type",1:"IV Type")
...... S PSG(PCNT,0)=PSG(PCNT,0)_" DATE(S) NOT CORRECTED. "
...... S PSG(PCNT,0)=PSG(PCNT,0)_" Order: "_PSJORD
.... I 'PSJSTRT!'PSJSTP S PCNT=PCNT+1 D
..... I $G(STOPCHG)!$G(STRTCHG) S OINAME=""
..... S PSGTMP=" "_$E(OINAME,1,20)_$E(BLANK,1,22-$L(OINAME))_" Can't determine "_$S('PSJSTRT:"start date",1:"")
..... S PSGTMP=PSGTMP_$S('PSJSTRT&('PSJSTP):" or ",1:"")_$S('PSJSTP:"stop date",1:"")_". Order: "_PSJORD
..... S PSG(PCNT,0)=PSGTMP
... ;
... ; Update ^PS(55 and indices
... I TYP=5 D:$G(STRTCHG) UDSTART^PSJ0742 D:$G(STOPCHG) UDSTOP^PSJ0742
... I TYP="IV" D:$G(STRTCHG) IVSTART^PSJ0742 D:$G(STOPCHG) IVSTOP^PSJ0742
... S END=END+1
... I '(END#500) D CLEANMSG(BEG,END) K PSG S PCNT=2,BEG=END+1
D CLEANMSG(BEG,END) Q
;
CLEANMSG(BEG,END) ;
K XMY S XMDUZ="MEDICATIONS,INPATIENT"
S XMSUB="INPATIENT MEDS ORDER ("_BEG_"-"_END_") CLEANUP COMPLETED"
S XMTEXT="PSG(",XMY(DUZ)="" D NOW^%DTC S Y=% X ^DD("DD")
S PSG(1,0)=" The cleanup of Inpatient Medication orders ("_BEG_"-"_END_") with invalid dates ",PSG(2,0)="completed as of "_Y_"."
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJ074 8373 printed Sep 23, 2025@19:41:47 Page 2
PSJ074 ;BIR/JCH-Check for stop date problems; 28-NOV-01
+1 ;;5.0; INPATIENT MEDICATIONS ;**74**;16 DEC 97
+2 ;
+3 ;Reference to ^DD is supported by DBIA# 10017.
+4 ;Reference to ^PS(50.7 is supported by DBIA# 2180.
+5 ;Reference to ^PS(52.6 is supported by DBIA# 1231.
+6 ;Reference to ^PS(55 is supported by DBIA# 2191.
+7 ;Reference to ^%DTC is supported by DBIA# 10000.
+8 ;Reference to ^%ZTLOAD is supported by DBIA# 10063.
+9 ;Reference to ^VADPT is supported by DBIA# 10061.
+10 ;Reference to ^XLFDT is supported by DBIA# 10103.
+11 ;Reference to ^XMD is supported by DBIA# 10070.
+12 ;
ENNV ; Begin check of existing orders
+1 IF $GET(DUZ)=""
WRITE !,"Your DUZ is not defined. It must be defined to run this routine."
QUIT
+2 KILL ZTSAVE,ZTSK
SET ZTRTN="ENQN^PSJ074"
SET ZTDESC="Inpatient Orders Check (INPATIENT MEDS)"
SET ZTIO=""
DO ^%ZTLOAD
+3 WRITE !!,"The check of existing Pharmacy orders is",$SELECT($DATA(ZTSK):"",1:" NOT")," queued",!
+4 IF $DATA(ZTSK)
Begin DoDot:1
+5 WRITE " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED. IF"
+6 WRITE !,"ERRORS ARE DETECTED, YOU WILL RECEIVE A SECOND MESSAGE INDICATING CLEANUP"
+7 WRITE !,"HAS COMPLETED."
End DoDot:1
+8 QUIT
ENQN ; Check of existing Pharmacy orders.
+1 NEW PSJBEG,PSJPDFN,PSJORD,PSJSTOP,CREAT,EXPR,OCNT,PSJND0,PSJND2,START
+2 NEW PSJSTRT
+3 DO NOW^%DTC
SET PSJSTART=$EXTRACT(%,1,12)
SET CREAT=$EXTRACT(%,1,7)
+4 SET EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0)
SET OCNT=0
+5 KILL ^XTMP("PSJ"),^XTMP("PSJ XREF")
+6 ;
+7 ;process data nodes
+8 SET PSJPDFN=0
FOR
SET PSJPDFN=$ORDER(^PS(55,PSJPDFN))
if 'PSJPDFN
QUIT
Begin DoDot:1
+9 FOR TYP="IV",5
Begin DoDot:2
+10 SET ORD=0
FOR
SET ORD=$ORDER(^PS(55,PSJPDFN,TYP,ORD))
if 'ORD
QUIT
Begin DoDot:3
+11 if $TRANSLATE($PIECE($GET(^PS(55,PSJPDFN,TYP,ORD,0)),"^",2,8),"^")=""
QUIT
+12 IF TYP="IV"
Begin DoDot:4
+13 SET PSJND0=$GET(^PS(55,PSJPDFN,"IV",ORD,0))
+14 SET PSJSTRT=$PIECE(PSJND0,"^",2)
SET PSJSTOP=$PIECE(PSJND0,"^",3)
End DoDot:4
+15 IF TYP=5
Begin DoDot:4
+16 SET ND2=$GET(^PS(55,PSJPDFN,TYP,ORD,2))
SET PSJSTRT=$PIECE(ND2,"^",2)
+17 SET PSJSTOP=$PIECE(ND2,"^",4)
End DoDot:4
+18 IF PSJSTOP=""!($PIECE(PSJSTOP,".",2)="")!(PSJSTOP'=+PSJSTOP)!($LENGTH(PSJSTOP)<5)
Begin DoDot:4
+19 SET ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJSTRT
SET OCNT=OCNT+1
End DoDot:4
QUIT
+20 IF PSJSTRT=""!($PIECE(PSJSTRT,".",2)="")!(PSJSTRT'=+PSJSTRT)!($LENGTH(PSJSTRT)<5)
Begin DoDot:4
+21 SET ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJSTRT
SET OCNT=OCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 if $DATA(^XTMP("PSJ"))
SET ^XTMP("PSJ",0)=EXPR_"^"_CREAT
+23 DO SENDMSG
+24 IF $DATA(^XTMP("PSJ"))
DO CLEAN
+25 DO XREFS^PSJ0742
+26 ;
DONE ;
+1 KILL DAYS,MINS,HOURS,PSG,PSJSTART,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK
SET ZTREQ="@"
+2 QUIT
+3 ;
SENDMSG ;Send mail message when check is complete.
+1 KILL PSG,XMY
SET XMDUZ="MEDICATIONS,INPATIENT"
SET XMSUB="INPATIENT MEDS ORDER CHECK COMPLETED"
SET XMTEXT="PSG("
SET XMY(DUZ)=""
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+2 SET PSG(1,0)=" The check of existing Pharmacy orders for use with Inpatient"
SET PSG(2,0)="Medications 5.0 completed as of "_Y_"."
+3 SET X=$$FMDIFF^XLFDT(%,PSJSTART,3)
if $LENGTH(X," ")>1
SET DAYS=+$PIECE(X," ")
SET X=$PIECE(X," ",2)
SET HOURS=+$PIECE(X,":")
SET MINS=+$PIECE(X,":",2)
+4 SET PSG(3,0)=" "
SET PSG(4,0)="This process checked orders for patients in "_$SELECT($GET(DAYS):DAYS_" day"_$EXTRACT("s",DAYS'=1)_", ",1:"")_HOURS_" hour"_$EXTRACT("s",HOURS'=1)
SET PSG(5,0)="and "_MINS_" minute"_$EXTRACT("s",MINS'=1)_"."
+5 SET PSG(6,0)=OCNT_" pharmacy orders were found with invalid stop dates."
+6 DO ^XMD
+7 QUIT
+8 ;
CLEAN ;
+1 NEW PSJPDFN,PSJORD,PSJND,PSJND2,PSJSTRT,PSJLOG,Y,PSJOSTP
+2 NEW PSJFOL,AD,AEN,BEG,END,DFN,PO,FSTOP,FSTRT,PCNT,FOLL0,PREV2,RFO
+3 NEW OPSJSTP,OPSJSTRT,TYP,OI,OINAME,BLANK,PSGTMP
+4 SET PSJPDFN=0
SET BEG=1
SET END=0
SET PCNT=6
SET $PIECE(BLANK," ",40)=""
SET AEN=0
+5 FOR
SET PSJPDFN=$ORDER(^XTMP("PSJ",PSJPDFN))
if 'PSJPDFN
QUIT
Begin DoDot:1
+6 FOR TYP="IV",5
Begin DoDot:2
+7 SET DFN=PSJPDFN
KILL VADM
DO DEM^VADPT
+8 SET PSJORD=0
+9 FOR
SET PSJORD=$ORDER(^XTMP("PSJ",PSJPDFN,TYP,PSJORD))
if 'PSJORD
QUIT
Begin DoDot:3
+10 SET PSJND=$GET(^PS(55,PSJPDFN,$SELECT(TYP=5:5,1:"IV"),PSJORD,0))
+11 IF $TRANSLATE(PSJND,"^","")=""
QUIT
+12 NEW PSJST,PSJPREV,PSJSTP,PSJSTRT,PSJFOL,OPSJSTP,OPSJSTRT
+13 KILL OINAME,FSTRT,FSTOP,STRTCHG,STOPCHG,FOLL2,FOLSTRT,PREVFO,PREV0
+14 KILL OI,FOLL0
+15 IF TYP=5
Begin DoDot:4
+16 ;Schedule Type for UD(different than IV)
SET PSJST=$PIECE(PSJND,"^",7)
+17 SET PSJFOL=+$PIECE(PSJND,"^",26)
+18 SET PSJPREV=+$PIECE(PSJND,"^",25)
SET PSJND2=$GET(^PS(55,PSJPDFN,5,PSJORD,2))
+19 SET (PSJSTP,OPSJSTP)=$PIECE(PSJND2,"^",4)
+20 SET (PSJSTRT,OPSJSTRT)=$PIECE(PSJND2,"^",2)
+21 SET OI=$PIECE($GET(^PS(55,PSJPDFN,5,PSJORD,.2)),"^")
+22 SET OINAME=$SELECT(OI:$PIECE($GET(^PS(50.7,OI,0)),"^"),1:"OI NOT FOUND")
+23 IF PSJFOL
Begin DoDot:5
+24 SET FOLL0=$GET(^PS(55,PSJPDFN,5,PSJFOL,0))
SET FOLPO=$PIECE(FOLL0,"^",25)
+25 SET FOLL2=$GET(^PS(55,PSJPDFN,5,PSJFOL,2))
SET FOLSTRT=$PIECE(FOLL2,"^",2)
End DoDot:5
+26 IF PSJPREV
Begin DoDot:5
+27 SET PSJOSTP=$PIECE($GET(^PS(55,PSJPDFN,5,PSJPREV,2)),"^",4)
+28 SET PREV0=$GET(^PS(55,PSJPDFN,5,PSJPREV,0))
SET PREVFO=$PIECE(PREV0,"^",26)
+29 SET PREVRFO=$PIECE(PREV0,"^",27)
End DoDot:5
End DoDot:4
+30 IF TYP="IV"
Begin DoDot:4
+31 SET PSJST=$PIECE(PSJND,"^",4)
SET (PSJSTRT,OPSJSTRT)=$PIECE(PSJND,"^",2)
+32 SET (PSJSTP,OPSJSTP)=$PIECE(PSJND,"^",3)
+33 SET OI=$PIECE($GET(^PS(55,PSJPDFN,"IV",PSJORD,.2)),"^")
+34 SET OINAME=$SELECT(OI:$PIECE($GET(^PS(50.7,OI,0)),"^"),1:"")
+35 SET PSJND2=$GET(^PS(55,PSJPDFN,"IV",PSJORD,2))
+36 SET AD=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0))
+37 IF OINAME=""
IF AD]""
SET AEN=$PIECE($GET(^PS(55,PSJPDFN,"IV",PSJORD,"AD",AD,0)),"^")
Begin DoDot:5
+38 SET OINAME=$PIECE($GET(^PS(52.6,+AEN,0)),"^")
+39 if OINAME=""
SET OINAME="OI NOT FOUND"
End DoDot:5
+40 SET PSJPREV=+$PIECE(PSJND2,"^",5)
SET PSJFOL=$PIECE(PSJND2,"^",6)
+41 IF PSJFOL
SET FOLL0=$GET(^PS(55,PSJPDFN,"IV",+PSJFOL,0))
Begin DoDot:5
+42 SET FOLL2=$GET(^PS(55,PSJPDFN,"IV",+PSJFOL,2))
+43 SET FOLPO=$PIECE(FOLL2,"^",5)
SET FOLSTRT=$PIECE(FOLL0,"^",2)
End DoDot:5
+44 IF PSJPREV
SET PREV2=$GET(^PS(55,PSJPDFN,"IV",PSJPREV,2))
Begin DoDot:5
+45 SET PSJOSTP=$PIECE($GET(^PS(55,PSJPDFN,"IV",PSJPREV,0)),"^",3)
+46 SET PREVFO=$PIECE(PREV2,"^",6)
SET PREVRFO=$PIECE(PREV2,"^",9)
End DoDot:5
End DoDot:4
+47 ;
+48 ;If there's a null start date, check if the previous order was
+49 ; renewed to cause this order to be created and if the stop date
+50 ; is there, use it
+51 ;If there's a null stop date, check if this order has a following
+52 ; order, and if the start date is there, use it
+53 ;Check to be sure the dates (even if acquired from a previous or
+54 ; following order) has a time on it; if not, make it midnight
+55 ;Check for trailing zeroes by forcing numeric
+56 ;Check for any other odd format with length < 5
+57 IF PSJSTRT=""
IF $GET(PSJOSTP)
IF (+$GET(PREVFO)=+PSJORD)
Begin DoDot:4
+58 SET PSJSTRT=+PSJOSTP
SET STRTCHG=1
End DoDot:4
+59 IF PSJSTRT'["."
IF $LENGTH(PSJSTRT)>7
SET PSJSTRT=$EXTRACT(PSJSTRT,1,7)
SET STRTCHG=1
+60 IF PSJSTRT
IF $PIECE(PSJSTRT,".",2)=""
SET $PIECE(PSJSTRT,".",2)=1
SET STRTCHG=1
+61 IF PSJSTRT
IF (PSJSTRT'=+PSJSTRT)
SET PSJSTRT=+PSJSTRT
SET STRTCHG=1
+62 IF PSJSTP=""
IF $GET(FOLSTRT)
IF (+$GET(FOLPO)=PSJORD)
Begin DoDot:4
+63 SET PSJSTP=FOLSTRT
SET STOPCHG=1
End DoDot:4
+64 IF PSJSTP'["."
IF $LENGTH(PSJSTP)>7
SET PSJSTP=$EXTRACT(PSJSTP,1,7)
SET STOPCHG=1
+65 IF PSJSTP
IF $PIECE(PSJSTP,".",2)=""
SET $PIECE(PSJSTP,".",2)=24
SET STOPCHG=1
+66 IF PSJSTP
IF (PSJSTP'=+PSJSTP)
SET PSJSTP=+PSJSTP
SET STOPCHG=1
+67 ; Prepare message with results
+68 IF 'PSJSTRT!'PSJSTP!($GET(STOPCHG))!($GET(STRTCHG))
Begin DoDot:4
+69 SET PCNT=PCNT+1
SET PSGTMP=$EXTRACT(VADM(1),1,25)_$EXTRACT(BLANK,1,27-$LENGTH(VADM(1)))
+70 SET PSGTMP=PSGTMP_$PIECE(VADM(2),"^")
+71 SET PSG(PCNT,0)=PSGTMP_" "_$SELECT(TYP=5:"Unit Dose",1:"IV")
+72 SET Y=PSJSTRT
XECUTE ^DD("DD")
SET FSTRT=Y
SET Y=PSJSTP
XECUTE ^DD("DD")
SET FSTOP=Y
+73 IF $GET(STOPCHG)!$GET(STRTCHG)
Begin DoDot:5
+74 SET OINAME=$GET(OINAME)
SET FSTRT=$GET(FSTRT)
SET FSTOP=$GET(FSTOP)
SET PCNT=PCNT+1
+75 SET PSG(PCNT,0)=" "_$EXTRACT(OINAME,1,20)_$EXTRACT(BLANK,1,22-$LENGTH(OINAME))
+76 SET PSG(PCNT,0)=PSG(PCNT,0)_"Start: "_FSTRT_" Stop: "_FSTOP
+77 IF $GET(STOPCHG)
IF PSJST=""
SET PCNT=PCNT+1
Begin DoDot:6
+78 SET PSG(PCNT,0)=" Missing "_$SELECT(TYP=5:"Schedule Type",1:"IV Type")
+79 SET PSG(PCNT,0)=PSG(PCNT,0)_" DATE(S) NOT CORRECTED. "
+80 SET PSG(PCNT,0)=PSG(PCNT,0)_" Order: "_PSJORD
End DoDot:6
End DoDot:5
+81 IF 'PSJSTRT!'PSJSTP
SET PCNT=PCNT+1
Begin DoDot:5
+82 IF $GET(STOPCHG)!$GET(STRTCHG)
SET OINAME=""
+83 SET PSGTMP=" "_$EXTRACT(OINAME,1,20)_$EXTRACT(BLANK,1,22-$LENGTH(OINAME))_" Can't determine "_$SELECT('PSJSTRT:"start date",1:"")
+84 SET PSGTMP=PSGTMP_$SELECT('PSJSTRT&('PSJSTP):" or ",1:"")_$SELECT('PSJSTP:"stop date",1:"")_". Order: "_PSJORD
+85 SET PSG(PCNT,0)=PSGTMP
End DoDot:5
End DoDot:4
+86 ;
+87 ; Update ^PS(55 and indices
+88 IF TYP=5
if $GET(STRTCHG)
DO UDSTART^PSJ0742
if $GET(STOPCHG)
DO UDSTOP^PSJ0742
+89 IF TYP="IV"
if $GET(STRTCHG)
DO IVSTART^PSJ0742
if $GET(STOPCHG)
DO IVSTOP^PSJ0742
+90 SET END=END+1
+91 IF '(END#500)
DO CLEANMSG(BEG,END)
KILL PSG
SET PCNT=2
SET BEG=END+1
End DoDot:3
End DoDot:2
End DoDot:1
+92 DO CLEANMSG(BEG,END)
QUIT
+93 ;
CLEANMSG(BEG,END) ;
+1 KILL XMY
SET XMDUZ="MEDICATIONS,INPATIENT"
+2 SET XMSUB="INPATIENT MEDS ORDER ("_BEG_"-"_END_") CLEANUP COMPLETED"
+3 SET XMTEXT="PSG("
SET XMY(DUZ)=""
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+4 SET PSG(1,0)=" The cleanup of Inpatient Medication orders ("_BEG_"-"_END_") with invalid dates "
SET PSG(2,0)="completed as of "_Y_"."
+5 DO ^XMD
+6 QUIT
