- PSJ078A ;BIR/JCH-Check for stop date problems ;28-NOV-01
- ;;5.0; INPATIENT MEDICATIONS ;**78**;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^PSJ078A",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,PSJNVDT,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)
- .... S PSJNVDT=$P($G(^PS(55,PSJPDFN,"IV",ORD,4)),"^",2)
- ... I TYP=5 D
- .... S ND2=$G(^PS(55,PSJPDFN,TYP,ORD,2)),PSJSTRT=$P(ND2,"^",2)
- .... S PSJSTOP=$P(ND2,"^",4)
- .... S PSJNVDT=$P($G(^PS(55,PSJPDFN,5,ORD,4)),"^",2)
- ... 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 Q
- .... S ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJSTRT,OCNT=OCNT+1
- ... I PSJNVDT]"",PSJNVDT'=+PSJNVDT D
- .... S ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJNVDT,OCNT=OCNT+1
- S:$D(^XTMP("PSJ")) ^XTMP("PSJ",0)=EXPR_"^"_CREAT
- D SENDMSG
- I $D(^XTMP("PSJ")) D CLEAN
- D XREFS^PSJ078B
- ;
- 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="PSJ*5*78 INPATIENT MEDS STOP DATE 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))
- ... S PSJND4=$G(^PS(55,PSJPDFN,$S(TYP=5:5,1:"IV"),PSJORD,4))
- ... 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 PSJNVDT=$P(PSJND4,"^",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 PSJNVDT=$P(PSJND4,"^",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^PSJ078B D:$G(STOPCHG) UDSTOP^PSJ078B
- ... I TYP="IV" D:$G(STRTCHG) IVSTART^PSJ078B D:$G(STOPCHG) IVSTOP^PSJ078B
- ... 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="PSJ*5*78 INPATIENT MEDS STOP DATE 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[HPSJ078A 8765 printed Mar 13, 2025@21:10:35 Page 2
- PSJ078A ;BIR/JCH-Check for stop date problems ;28-NOV-01
- +1 ;;5.0; INPATIENT MEDICATIONS ;**78**;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^PSJ078A"
- 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,PSJNVDT,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)
- +15 SET PSJNVDT=$PIECE($GET(^PS(55,PSJPDFN,"IV",ORD,4)),"^",2)
- End DoDot:4
- +16 IF TYP=5
- Begin DoDot:4
- +17 SET ND2=$GET(^PS(55,PSJPDFN,TYP,ORD,2))
- SET PSJSTRT=$PIECE(ND2,"^",2)
- +18 SET PSJSTOP=$PIECE(ND2,"^",4)
- +19 SET PSJNVDT=$PIECE($GET(^PS(55,PSJPDFN,5,ORD,4)),"^",2)
- End DoDot:4
- +20 IF PSJSTOP=""!($PIECE(PSJSTOP,".",2)="")!(PSJSTOP'=+PSJSTOP)!($LENGTH(PSJSTOP)<5)
- Begin DoDot:4
- +21 SET ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJSTRT
- SET OCNT=OCNT+1
- End DoDot:4
- QUIT
- +22 IF PSJSTRT=""!($PIECE(PSJSTRT,".",2)="")!(PSJSTRT'=+PSJSTRT)!($LENGTH(PSJSTRT)<5)
- Begin DoDot:4
- +23 SET ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJSTRT
- SET OCNT=OCNT+1
- End DoDot:4
- QUIT
- +24 IF PSJNVDT]""
- IF PSJNVDT'=+PSJNVDT
- Begin DoDot:4
- +25 SET ^XTMP("PSJ",PSJPDFN,TYP,ORD)=PSJNVDT
- SET OCNT=OCNT+1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +26 if $DATA(^XTMP("PSJ"))
- SET ^XTMP("PSJ",0)=EXPR_"^"_CREAT
- +27 DO SENDMSG
- +28 IF $DATA(^XTMP("PSJ"))
- DO CLEAN
- +29 DO XREFS^PSJ078B
- +30 ;
- 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="PSJ*5*78 INPATIENT MEDS STOP DATE 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 SET PSJND4=$GET(^PS(55,PSJPDFN,$SELECT(TYP=5:5,1:"IV"),PSJORD,4))
- +12 IF $TRANSLATE(PSJND,"^","")=""
- QUIT
- +13 NEW PSJST,PSJPREV,PSJSTP,PSJSTRT,PSJFOL,OPSJSTP,OPSJSTRT
- +14 KILL OINAME,FSTRT,FSTOP,STRTCHG,STOPCHG,FOLL2,FOLSTRT,PREVFO,PREV0
- +15 KILL OI,FOLL0
- +16 IF TYP=5
- Begin DoDot:4
- +17 ;Schedule Type for UD(different than IV)
- SET PSJST=$PIECE(PSJND,"^",7)
- +18 SET PSJFOL=+$PIECE(PSJND,"^",26)
- +19 SET PSJPREV=+$PIECE(PSJND,"^",25)
- SET PSJND2=$GET(^PS(55,PSJPDFN,5,PSJORD,2))
- +20 SET (PSJSTP,OPSJSTP)=$PIECE(PSJND2,"^",4)
- +21 SET (PSJSTRT,OPSJSTRT)=$PIECE(PSJND2,"^",2)
- +22 SET PSJNVDT=$PIECE(PSJND4,"^",2)
- +23 SET OI=$PIECE($GET(^PS(55,PSJPDFN,5,PSJORD,.2)),"^")
- +24 SET OINAME=$SELECT(OI:$PIECE($GET(^PS(50.7,OI,0)),"^"),1:"OI NOT FOUND")
- +25 IF PSJFOL
- Begin DoDot:5
- +26 SET FOLL0=$GET(^PS(55,PSJPDFN,5,PSJFOL,0))
- SET FOLPO=$PIECE(FOLL0,"^",25)
- +27 SET FOLL2=$GET(^PS(55,PSJPDFN,5,PSJFOL,2))
- SET FOLSTRT=$PIECE(FOLL2,"^",2)
- End DoDot:5
- +28 IF PSJPREV
- Begin DoDot:5
- +29 SET PSJOSTP=$PIECE($GET(^PS(55,PSJPDFN,5,PSJPREV,2)),"^",4)
- +30 SET PREV0=$GET(^PS(55,PSJPDFN,5,PSJPREV,0))
- SET PREVFO=$PIECE(PREV0,"^",26)
- +31 SET PREVRFO=$PIECE(PREV0,"^",27)
- End DoDot:5
- End DoDot:4
- +32 IF TYP="IV"
- Begin DoDot:4
- +33 SET PSJST=$PIECE(PSJND,"^",4)
- SET (PSJSTRT,OPSJSTRT)=$PIECE(PSJND,"^",2)
- +34 SET (PSJSTP,OPSJSTP)=$PIECE(PSJND,"^",3)
- +35 SET OI=$PIECE($GET(^PS(55,PSJPDFN,"IV",PSJORD,.2)),"^")
- +36 SET OINAME=$SELECT(OI:$PIECE($GET(^PS(50.7,OI,0)),"^"),1:"")
- +37 SET PSJND2=$GET(^PS(55,PSJPDFN,"IV",PSJORD,2))
- +38 SET PSJNVDT=$PIECE(PSJND4,"^",2)
- +39 SET AD=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0))
- +40 IF OINAME=""
- IF AD]""
- SET AEN=$PIECE($GET(^PS(55,PSJPDFN,"IV",PSJORD,"AD",AD,0)),"^")
- Begin DoDot:5
- +41 SET OINAME=$PIECE($GET(^PS(52.6,+AEN,0)),"^")
- +42 if OINAME=""
- SET OINAME="OI NOT FOUND"
- End DoDot:5
- +43 SET PSJPREV=+$PIECE(PSJND2,"^",5)
- SET PSJFOL=$PIECE(PSJND2,"^",6)
- +44 IF PSJFOL
- SET FOLL0=$GET(^PS(55,PSJPDFN,"IV",+PSJFOL,0))
- Begin DoDot:5
- +45 SET FOLL2=$GET(^PS(55,PSJPDFN,"IV",+PSJFOL,2))
- +46 SET FOLPO=$PIECE(FOLL2,"^",5)
- SET FOLSTRT=$PIECE(FOLL0,"^",2)
- End DoDot:5
- +47 IF PSJPREV
- SET PREV2=$GET(^PS(55,PSJPDFN,"IV",PSJPREV,2))
- Begin DoDot:5
- +48 SET PSJOSTP=$PIECE($GET(^PS(55,PSJPDFN,"IV",PSJPREV,0)),"^",3)
- +49 SET PREVFO=$PIECE(PREV2,"^",6)
- SET PREVRFO=$PIECE(PREV2,"^",9)
- End DoDot:5
- End DoDot:4
- +50 ;
- +51 ;If there's a null start date, check if the previous order was
- +52 ; renewed to cause this order to be created and if the stop date
- +53 ; is there, use it
- +54 ;If there's a null stop date, check if this order has a following
- +55 ; order, and if the start date is there, use it
- +56 ;Check to be sure the dates (even if acquired from a previous or
- +57 ; following order) has a time on it; if not, make it midnight
- +58 ;Check for trailing zeroes by forcing numeric
- +59 ;Check for any other odd format with length < 5
- +60 IF PSJSTRT=""
- IF $GET(PSJOSTP)
- IF (+$GET(PREVFO)=+PSJORD)
- Begin DoDot:4
- +61 SET PSJSTRT=+PSJOSTP
- SET STRTCHG=1
- End DoDot:4
- +62 IF PSJSTRT'["."
- IF $LENGTH(PSJSTRT)>7
- SET PSJSTRT=$EXTRACT(PSJSTRT,1,7)
- SET STRTCHG=1
- +63 IF PSJSTRT
- IF $PIECE(PSJSTRT,".",2)=""
- SET $PIECE(PSJSTRT,".",2)=1
- SET STRTCHG=1
- +64 IF PSJSTRT
- IF (PSJSTRT'=+PSJSTRT)
- SET PSJSTRT=+PSJSTRT
- SET STRTCHG=1
- +65 IF PSJSTP=""
- IF $GET(FOLSTRT)
- IF (+$GET(FOLPO)=PSJORD)
- Begin DoDot:4
- +66 SET PSJSTP=FOLSTRT
- SET STOPCHG=1
- End DoDot:4
- +67 IF PSJSTP'["."
- IF $LENGTH(PSJSTP)>7
- SET PSJSTP=$EXTRACT(PSJSTP,1,7)
- SET STOPCHG=1
- +68 IF PSJSTP
- IF $PIECE(PSJSTP,".",2)=""
- SET $PIECE(PSJSTP,".",2)=24
- SET STOPCHG=1
- +69 IF PSJSTP
- IF (PSJSTP'=+PSJSTP)
- SET PSJSTP=+PSJSTP
- SET STOPCHG=1
- +70 ; Prepare message with results
- +71 IF 'PSJSTRT!'PSJSTP!($GET(STOPCHG))!($GET(STRTCHG))
- Begin DoDot:4
- +72 SET PCNT=PCNT+1
- SET PSGTMP=$EXTRACT(VADM(1),1,25)_$EXTRACT(BLANK,1,27-$LENGTH(VADM(1)))
- +73 SET PSGTMP=PSGTMP_$PIECE(VADM(2),"^")
- +74 SET PSG(PCNT,0)=PSGTMP_" "_$SELECT(TYP=5:"Unit Dose",1:"IV")
- +75 SET Y=PSJSTRT
- XECUTE ^DD("DD")
- SET FSTRT=Y
- SET Y=PSJSTP
- XECUTE ^DD("DD")
- SET FSTOP=Y
- +76 IF $GET(STOPCHG)!$GET(STRTCHG)
- Begin DoDot:5
- +77 SET OINAME=$GET(OINAME)
- SET FSTRT=$GET(FSTRT)
- SET FSTOP=$GET(FSTOP)
- SET PCNT=PCNT+1
- +78 SET PSG(PCNT,0)=" "_$EXTRACT(OINAME,1,20)_$EXTRACT(BLANK,1,22-$LENGTH(OINAME))
- +79 SET PSG(PCNT,0)=PSG(PCNT,0)_"Start: "_FSTRT_" Stop: "_FSTOP
- +80 IF $GET(STOPCHG)
- IF PSJST=""
- SET PCNT=PCNT+1
- Begin DoDot:6
- +81 SET PSG(PCNT,0)=" Missing "_$SELECT(TYP=5:"Schedule Type",1:"IV Type")
- +82 SET PSG(PCNT,0)=PSG(PCNT,0)_" DATE(S) NOT CORRECTED. "
- +83 SET PSG(PCNT,0)=PSG(PCNT,0)_" Order: "_PSJORD
- End DoDot:6
- End DoDot:5
- +84 IF 'PSJSTRT!'PSJSTP
- SET PCNT=PCNT+1
- Begin DoDot:5
- +85 IF $GET(STOPCHG)!$GET(STRTCHG)
- SET OINAME=""
- +86 SET PSGTMP=" "_$EXTRACT(OINAME,1,20)_$EXTRACT(BLANK,1,22-$LENGTH(OINAME))_" Can't determine "_$SELECT('PSJSTRT:"start date",1:"")
- +87 SET PSGTMP=PSGTMP_$SELECT('PSJSTRT&('PSJSTP):" or ",1:"")_$SELECT('PSJSTP:"stop date",1:"")_". Order: "_PSJORD
- +88 SET PSG(PCNT,0)=PSGTMP
- End DoDot:5
- End DoDot:4
- +89 ;
- +90 ; Update ^PS(55 and indices
- +91 IF TYP=5
- if $GET(STRTCHG)
- DO UDSTART^PSJ078B
- if $GET(STOPCHG)
- DO UDSTOP^PSJ078B
- +92 IF TYP="IV"
- if $GET(STRTCHG)
- DO IVSTART^PSJ078B
- if $GET(STOPCHG)
- DO IVSTOP^PSJ078B
- +93 SET END=END+1
- +94 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
- +95 DO CLEANMSG(BEG,END)
- QUIT
- +96 ;
- CLEANMSG(BEG,END) ;
- +1 KILL XMY
- SET XMDUZ="MEDICATIONS,INPATIENT"
- +2 SET XMSUB="PSJ*5*78 INPATIENT MEDS STOP DATE 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
