PSJ0071 ;BIR/JLC - Check for mis-matched schedule internal ; 19-FEB-02
;;5.0; INPATIENT MEDICATIONS ;**71**;16 DEC 97
;
; Reference to ^DD is supported by DBIA# 10017.
; Reference to ^PS(51.1 is supported by DBIA# 2177.
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^VA(200 is supported by DBIA# 10060.
; Reference to ^VADPT is supported by DBIA# 10061.
; Reference to ^XPD is supported by DBIA# 2197.
; 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 ^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^PSJ0071",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 PSJSTART,CREAT,EXPR,OCNT,IEN,PSJBEG,PSJPDFN,PSJORD,PSJND0,PSJSCH,PSJADM,PSJFRE,PSJSTA,A,PSGST,PSGS0XT,X,DAYS,MINS
S PSGOES=1,OCNT=0
D NOW^%DTC S PSJSTART=$E(%,1,12),CREAT=$E(%,1,7),EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0)
K ^XTMP("PSJ71")
;process the IV start date crossreference to find orders
;begin with the first date that PSJ*5*50 was installed
S IEN=$O(^XPD(9.7,"B","PSJ*5.0*50","")),PSJBEG=$P(^XPD(9.7,IEN,1),"^",3)-1
F S PSJBEG=$O(^PS(55,"AIVS",PSJBEG)) Q:'PSJBEG D
. S PSJPDFN=0
. F S PSJPDFN=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN)) Q:'PSJPDFN D
.. S PSJORD=0
.. F S PSJORD=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD)) Q:'PSJORD D
... S PSJND0=$G(^PS(55,PSJPDFN,"IV",PSJORD,0)),PSJSCH=$P(PSJND0,"^",9),PSJADM=$P(PSJND0,"^",11),PSJFRE=$P(PSJND0,"^",15),PSJSTA=$P(PSJND0,"^",17)
... Q:PSJSTA="D" Q:PSJSCH="" Q:PSJFRE="" Q:PSJFRE="O" K PSGS0XT
... I $D(^PS(51.1,"APPSJ",PSJSCH)) D S A=^PS(51.1,X,0),PSGST=$P(A,"^",5),PSGS0XT=$P(A,"^",3) Q:PSGST="O" Q:PSGS0XT=PSJFRE G ERR
.... S X=0 F S X=$O(^PS(51.1,"APPSJ",PSJSCH,X)) Q:'X I $P(^PS(51.1,X,0),"^",2)=PSJADM Q
.... I 'X S X=$O(^PS(51.1,"APPSJ",PSJSCH,0))
... I PSJSCH="ONCE"!(PSJSCH="NOW")!(PSJSCH="ONE TIME")!(PSJSCH="ONETIME")!(PSJSCH="ONE-TIME")!(PSJSCH="1TIME")!(PSJSCH="1 TIME")!(PSJSCH="1-TIME")!(PSJSCH="STAT") Q
... Q:PSJSCH["PRN"
... S X=PSJSCH D EN^PSGS0 I $G(PSGS0XT)="" S PSGS0XT=1440
... I $G(PSGS0XT)=PSJFRE Q
ERR ... S ^XTMP("PSJ71",PSJPDFN,PSJORD)=PSJSCH_"^"_PSJFRE_"^"_$G(PSGS0XT),OCNT=OCNT+1
S:$D(^XTMP("PSJ71")) ^XTMP("PSJ71",0)=EXPR_"^"_CREAT
D SENDMSG
I $D(^XTMP("PSJ71")) D CLEAN
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 potential frequency mis-matches."
D ^XMD
Q
;
CLEAN ;
S INS=$P(^VA(200,DUZ,0),"^"),PSJPDFN=0,BEG=1,END=0,PCNT=2,$P(BLANK," ",40)=""
F S PSJPDFN=$O(^XTMP("PSJ71",PSJPDFN)) Q:'PSJPDFN S PSJORD=0 D
. S DFN=PSJPDFN K VADM D DEM^VADPT
. F S PSJORD=$O(^XTMP("PSJ71",PSJPDFN,PSJORD)) Q:'PSJORD D
.. I '$D(^PS(55,PSJPDFN,"IV",PSJORD)) Q
.. S A=^XTMP("PSJ71",PSJPDFN,PSJORD),PSJFRE=$P(A,"^",2),PSGS0XT=$P(A,"^",3)
.. S $P(^PS(55,PSJPDFN,"IV",PSJORD,0),"^",15)=PSGS0XT
.. D LOG
.. S PCNT=PCNT+1,PSG(PCNT,0)=$E(VADM(1),1,25)_$E(BLANK,1,27-$L(VADM(1)))_$P(VADM(2),"^")
.. S AD=$O(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0)) I AD]"" S AIEN=$P($G(^(AD,0)),"^"),OINAME=$P(^PS(52.6,AIEN,0),"^")
.. S PSJND=$G(^PS(55,PSJPDFN,"IV",PSJORD,0)),PSJSTRT=$P(PSJND,"^",2),PSJSTP=$P(PSJND,"^",3)
.. S Y=PSJSTRT X ^DD("DD") S FSTRT=Y
.. S Y=PSJSTP X ^DD("DD") S FSTOP=Y
.. S OINAME=$G(OINAME)
.. S PCNT=PCNT+1,PSG(PCNT,0)=" "_$E(OINAME,1,25)_$E(BLANK,1,28-$L(OINAME))_"Start: "_FSTRT_" Stop: "_FSTOP
.. S PCNT=PCNT+1,PSG(PCNT,0)=" "
.. 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",XMSUB="INPATIENT MEDS ORDER ("_BEG_"-"_END_") CLEANUP COMPLETED",XMTEXT="PSG(",XMY(DUZ)="" D NOW^%DTC S Y=% X ^DD("DD")
S PSG(1,0)=" The cleanup of Inpatient Medication orders with schedule interval problems ",PSG(2,0)="completed as of "_Y_"."
D ^XMD
Q
LOG ; Create field change entry in activity log.
N %,X,Y S:'$D(^PS(55,PSJPDFN,"IV",PSJORD,"A",0)) ^(0)="^55.04A^^" S PSIVLN=($P(^PS(55,PSJPDFN,"IV",PSJORD,"A",0),"^",3)+1),$P(^(0),"^",3)=PSIVLN,$P(^(0),"^",4)=$P(^(0),"^",4)+1
D NOW^%DTC S ^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,0)=PSIVLN_"^E^"_INS_"^PSJ*5*71 SCHEDULE FREQUENCY MISMATCH^"_%
S ND=$G(^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,1,0)) S:ND="" ND="^55.151^^"
S $P(ND,U,3)=$P(ND,U,3)+1,$P(ND,U,4)=$P(ND,U,4)+1,^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,1,0)=ND,^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,1,$P(ND,U,3),0)="SCHEDULE INTERVAL^"_PSJFRE_"^"_PSGS0XT K ND
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJ0071 5827 printed Oct 16, 2024@18:06:15 Page 2
PSJ0071 ;BIR/JLC - Check for mis-matched schedule internal ; 19-FEB-02
+1 ;;5.0; INPATIENT MEDICATIONS ;**71**;16 DEC 97
+2 ;
+3 ; Reference to ^DD is supported by DBIA# 10017.
+4 ; Reference to ^PS(51.1 is supported by DBIA# 2177.
+5 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+6 ; Reference to ^VA(200 is supported by DBIA# 10060.
+7 ; Reference to ^VADPT is supported by DBIA# 10061.
+8 ; Reference to ^XPD is supported by DBIA# 2197.
+9 ; Reference to ^PS(55 is supported by DBIA# 2191.
+10 ; Reference to ^%DTC is supported by DBIA# 10000.
+11 ; Reference to ^%ZTLOAD is supported by DBIA# 10063.
+12 ; Reference to ^XLFDT is supported by DBIA# 10103.
+13 ; Reference to ^XMD is supported by DBIA# 10070.
+14 ;
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^PSJ0071"
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 PSJSTART,CREAT,EXPR,OCNT,IEN,PSJBEG,PSJPDFN,PSJORD,PSJND0,PSJSCH,PSJADM,PSJFRE,PSJSTA,A,PSGST,PSGS0XT,X,DAYS,MINS
+2 SET PSGOES=1
SET OCNT=0
+3 DO NOW^%DTC
SET PSJSTART=$EXTRACT(%,1,12)
SET CREAT=$EXTRACT(%,1,7)
SET EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0)
+4 KILL ^XTMP("PSJ71")
+5 ;process the IV start date crossreference to find orders
+6 ;begin with the first date that PSJ*5*50 was installed
+7 SET IEN=$ORDER(^XPD(9.7,"B","PSJ*5.0*50",""))
SET PSJBEG=$PIECE(^XPD(9.7,IEN,1),"^",3)-1
+8 FOR
SET PSJBEG=$ORDER(^PS(55,"AIVS",PSJBEG))
if 'PSJBEG
QUIT
Begin DoDot:1
+9 SET PSJPDFN=0
+10 FOR
SET PSJPDFN=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN))
if 'PSJPDFN
QUIT
Begin DoDot:2
+11 SET PSJORD=0
+12 FOR
SET PSJORD=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD))
if 'PSJORD
QUIT
Begin DoDot:3
+13 SET PSJND0=$GET(^PS(55,PSJPDFN,"IV",PSJORD,0))
SET PSJSCH=$PIECE(PSJND0,"^",9)
SET PSJADM=$PIECE(PSJND0,"^",11)
SET PSJFRE=$PIECE(PSJND0,"^",15)
SET PSJSTA=$PIECE(PSJND0,"^",17)
+14 if PSJSTA="D"
QUIT
if PSJSCH=""
QUIT
if PSJFRE=""
QUIT
if PSJFRE="O"
QUIT
KILL PSGS0XT
+15 IF $DATA(^PS(51.1,"APPSJ",PSJSCH))
Begin DoDot:4
+16 SET X=0
FOR
SET X=$ORDER(^PS(51.1,"APPSJ",PSJSCH,X))
if 'X
QUIT
IF $PIECE(^PS(51.1,X,0),"^",2)=PSJADM
QUIT
+17 IF 'X
SET X=$ORDER(^PS(51.1,"APPSJ",PSJSCH,0))
End DoDot:4
SET A=^PS(51.1,X,0)
SET PSGST=$PIECE(A,"^",5)
SET PSGS0XT=$PIECE(A,"^",3)
if PSGST="O"
QUIT
if PSGS0XT=PSJFRE
QUIT
GOTO ERR
+18 IF PSJSCH="ONCE"!(PSJSCH="NOW")!(PSJSCH="ONE TIME")!(PSJSCH="ONETIME")!(PSJSCH="ONE-TIME")!(PSJSCH="1TIME")!(PSJSCH="1 TIME")!(PSJSCH="1-TIME")!(PSJSCH="STAT")
QUIT
+19 if PSJSCH["PRN"
QUIT
+20 SET X=PSJSCH
DO EN^PSGS0
IF $GET(PSGS0XT)=""
SET PSGS0XT=1440
+21 IF $GET(PSGS0XT)=PSJFRE
QUIT
ERR SET ^XTMP("PSJ71",PSJPDFN,PSJORD)=PSJSCH_"^"_PSJFRE_"^"_$GET(PSGS0XT)
SET OCNT=OCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+1 if $DATA(^XTMP("PSJ71"))
SET ^XTMP("PSJ71",0)=EXPR_"^"_CREAT
+2 DO SENDMSG
+3 IF $DATA(^XTMP("PSJ71"))
DO CLEAN
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
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 potential frequency mis-matches."
+6 DO ^XMD
+7 QUIT
+8 ;
CLEAN ;
+1 SET INS=$PIECE(^VA(200,DUZ,0),"^")
SET PSJPDFN=0
SET BEG=1
SET END=0
SET PCNT=2
SET $PIECE(BLANK," ",40)=""
+2 FOR
SET PSJPDFN=$ORDER(^XTMP("PSJ71",PSJPDFN))
if 'PSJPDFN
QUIT
SET PSJORD=0
Begin DoDot:1
+3 SET DFN=PSJPDFN
KILL VADM
DO DEM^VADPT
+4 FOR
SET PSJORD=$ORDER(^XTMP("PSJ71",PSJPDFN,PSJORD))
if 'PSJORD
QUIT
Begin DoDot:2
+5 IF '$DATA(^PS(55,PSJPDFN,"IV",PSJORD))
QUIT
+6 SET A=^XTMP("PSJ71",PSJPDFN,PSJORD)
SET PSJFRE=$PIECE(A,"^",2)
SET PSGS0XT=$PIECE(A,"^",3)
+7 SET $PIECE(^PS(55,PSJPDFN,"IV",PSJORD,0),"^",15)=PSGS0XT
+8 DO LOG
+9 SET PCNT=PCNT+1
SET PSG(PCNT,0)=$EXTRACT(VADM(1),1,25)_$EXTRACT(BLANK,1,27-$LENGTH(VADM(1)))_$PIECE(VADM(2),"^")
+10 SET AD=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0))
IF AD]""
SET AIEN=$PIECE($GET(^(AD,0)),"^")
SET OINAME=$PIECE(^PS(52.6,AIEN,0),"^")
+11 SET PSJND=$GET(^PS(55,PSJPDFN,"IV",PSJORD,0))
SET PSJSTRT=$PIECE(PSJND,"^",2)
SET PSJSTP=$PIECE(PSJND,"^",3)
+12 SET Y=PSJSTRT
XECUTE ^DD("DD")
SET FSTRT=Y
+13 SET Y=PSJSTP
XECUTE ^DD("DD")
SET FSTOP=Y
+14 SET OINAME=$GET(OINAME)
+15 SET PCNT=PCNT+1
SET PSG(PCNT,0)=" "_$EXTRACT(OINAME,1,25)_$EXTRACT(BLANK,1,28-$LENGTH(OINAME))_"Start: "_FSTRT_" Stop: "_FSTOP
+16 SET PCNT=PCNT+1
SET PSG(PCNT,0)=" "
+17 SET END=END+1
IF '(END#500)
DO CLEANMSG(BEG,END)
KILL PSG
SET PCNT=2
SET BEG=END+1
End DoDot:2
End DoDot:1
+18 DO CLEANMSG(BEG,END)
QUIT
CLEANMSG(BEG,END) KILL XMY
SET XMDUZ="MEDICATIONS,INPATIENT"
SET XMSUB="INPATIENT MEDS ORDER ("_BEG_"-"_END_") CLEANUP COMPLETED"
SET XMTEXT="PSG("
SET XMY(DUZ)=""
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+1 SET PSG(1,0)=" The cleanup of Inpatient Medication orders with schedule interval problems "
SET PSG(2,0)="completed as of "_Y_"."
+2 DO ^XMD
+3 QUIT
LOG ; Create field change entry in activity log.
+1 NEW %,X,Y
if '$DATA(^PS(55,PSJPDFN,"IV",PSJORD,"A",0))
SET ^(0)="^55.04A^^"
SET PSIVLN=($PIECE(^PS(55,PSJPDFN,"IV",PSJORD,"A",0),"^",3)+1)
SET $PIECE(^(0),"^",3)=PSIVLN
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
+2 DO NOW^%DTC
SET ^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,0)=PSIVLN_"^E^"_INS_"^PSJ*5*71 SCHEDULE FREQUENCY MISMATCH^"_%
+3 SET ND=$GET(^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,1,0))
if ND=""
SET ND="^55.151^^"
+4 SET $PIECE(ND,U,3)=$PIECE(ND,U,3)+1
SET $PIECE(ND,U,4)=$PIECE(ND,U,4)+1
SET ^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,1,0)=ND
SET ^PS(55,PSJPDFN,"IV",PSJORD,"A",PSIVLN,1,$PIECE(ND,U,3),0)="SCHEDULE INTERVAL^"_PSJFRE_"^"_PSGS0XT
KILL ND
+5 QUIT
