PSJ0099 ;BIR/JLC - EVALUATE IV ORDER PROBLEMS ;12/03/2002
;;5.0; INPATIENT MEDICATIONS ;**99**;16 DE7 97
;
;Reference to ^PS(55 supported by DBIA 2191
;
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="START^PSJ0099",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."
Q
START ;run through entries in XTMP("PSOPOST7"
S JOB=0 I $D(^XTMP("PSOPOST7")) S $P(^("PSOPOST7",0),"^",1)="3030531"
F S JOB=$O(^XTMP("PSOPOST7",JOB)) Q:JOB="" D
. S DFN=""
. F S DFN=$O(^XTMP("PSOPOST7",JOB,"IV",DFN)) Q:DFN="" D
.. S PSJORD=""
.. F S PSJORD=$O(^XTMP("PSOPOST7",JOB,"IV",DFN,PSJORD)) Q:PSJORD="" D
... W !! S S1="^PS(55,"_DFN_",""IV"","_PSJORD_")",CHK=$P(S1,")")
... F S S1=$Q(@S1) Q:S1="" Q:$P(S1,",",1,4)'=CHK W S1," = ",@S1,!
... S A=$G(^PS(55,DFN,"IV",PSJORD,0)) I A="" S ^XTMP("PSJ0099",$J,DFN,PSJORD)="NOT ON FILE" Q
... S PSSTART=$P(A,"^",2),PSSTOP=$P(A,"^",3),PSSTATUS=$P(A,"^",17)
... I PSSTATUS'["S X=" S ^XTMP("PSJ0099",$J,DFN,PSJORD)="STATUS" D Q
.... I '$D(^PS(55,DFN,"IV",PSJORD,2)) K ^XTMP("PSJ0099",$J,DFN,PSJORD) Q
... S ^XTMP("PSJ0099",$J,DFN,PSJORD)="OTHER" D NOSTOP
D NOW^%DTC S PSJSTART=$E(%,1,12),CREAT=$E(%,1,7),EXPR=$$FMADD^XLFDT(CREAT,90,0,0,0)
I $D(^XTMP("PSJ0099",$J)) S ^($J,0)=EXPR_"^"_CREAT
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_"."
I $D(^XTMP("PSOPOST7")) D
. S PSG(3,0)="There were Pharmacy orders - listed in ^XTMP(""PSOPOST7"",,""IV""",PSG(4,0)="that had changes made."
. S PSG(5,0)="Please spot check some of the affected orders to be sure",PSG(6,0)="they are now correct."
. I $D(^XTMP("PSJ0099")) S PSG(7,0)="Some orders could not be changed. These are listed in XTMP(""PSJ0099"".",PSG(8,0)="Please check these patients to be sure their profile is correct."
D ^XMD
Q
NOSTOP S D2=0,OLD=""
F S D2=$O(^PS(55,DFN,"IV",PSJORD,"A",D2)) Q:'D2 D
. S D3=0
. F S D3=$O(^PS(55,DFN,"IV",PSJORD,"A",D2,1,D3)) Q:'D3 D
.. S ACTDATA=^PS(55,DFN,"IV",PSJORD,"A",D2,1,D3,0)
.. Q:$P(ACTDATA,"^")'="STATUS" S A=$P(ACTDATA,"^",2)
.. I A'="DISCONTINUED",A'="EXPIRED",A'="PURGE",A'="ON CALL",A'="NON VERIFIED" Q
.. S OLD=A
I OLD="",PSSTOP=1 S OLD="PURGE"
S STATUS=$S(OLD="DISCONTINUED":"D",OLD="EXPIRED":"E",OLD="PURGE":"P",OLD="ON CALL":"OC",OLD="NON VERIFIED":"N",1:"")
K DR S DIE="^PS(55,"_DFN_",""IV"",",DA=PSJORD,DA(1)=DFN,DR="100////"_STATUS D ^DIE
I STATUS="" S $P(^PS(55,DFN,"IV",PSJORD,0),"^",17)=""
K ^XTMP("PSJ0099",$J,DFN,PSJORD) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJ0099 3039 printed Sep 23, 2025@19:41:40 Page 2
PSJ0099 ;BIR/JLC - EVALUATE IV ORDER PROBLEMS ;12/03/2002
+1 ;;5.0; INPATIENT MEDICATIONS ;**99**;16 DE7 97
+2 ;
+3 ;Reference to ^PS(55 supported by DBIA 2191
+4 ;
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="START^PSJ0099"
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."
End DoDot:1
+6 QUIT
START ;run through entries in XTMP("PSOPOST7"
+1 SET JOB=0
IF $DATA(^XTMP("PSOPOST7"))
SET $PIECE(^("PSOPOST7",0),"^",1)="3030531"
+2 FOR
SET JOB=$ORDER(^XTMP("PSOPOST7",JOB))
if JOB=""
QUIT
Begin DoDot:1
+3 SET DFN=""
+4 FOR
SET DFN=$ORDER(^XTMP("PSOPOST7",JOB,"IV",DFN))
if DFN=""
QUIT
Begin DoDot:2
+5 SET PSJORD=""
+6 FOR
SET PSJORD=$ORDER(^XTMP("PSOPOST7",JOB,"IV",DFN,PSJORD))
if PSJORD=""
QUIT
Begin DoDot:3
+7 WRITE !!
SET S1="^PS(55,"_DFN_",""IV"","_PSJORD_")"
SET CHK=$PIECE(S1,")")
+8 FOR
SET S1=$QUERY(@S1)
if S1=""
QUIT
if $PIECE(S1,",",1,4)'=CHK
QUIT
WRITE S1," = ",@S1,!
+9 SET A=$GET(^PS(55,DFN,"IV",PSJORD,0))
IF A=""
SET ^XTMP("PSJ0099",$JOB,DFN,PSJORD)="NOT ON FILE"
QUIT
+10 SET PSSTART=$PIECE(A,"^",2)
SET PSSTOP=$PIECE(A,"^",3)
SET PSSTATUS=$PIECE(A,"^",17)
+11 IF PSSTATUS'["S X="
SET ^XTMP("PSJ0099",$JOB,DFN,PSJORD)="STATUS"
Begin DoDot:4
+12 IF '$DATA(^PS(55,DFN,"IV",PSJORD,2))
KILL ^XTMP("PSJ0099",$JOB,DFN,PSJORD)
QUIT
End DoDot:4
QUIT
+13 SET ^XTMP("PSJ0099",$JOB,DFN,PSJORD)="OTHER"
DO NOSTOP
End DoDot:3
End DoDot:2
End DoDot:1
+14 DO NOW^%DTC
SET PSJSTART=$EXTRACT(%,1,12)
SET CREAT=$EXTRACT(%,1,7)
SET EXPR=$$FMADD^XLFDT(CREAT,90,0,0,0)
+15 IF $DATA(^XTMP("PSJ0099",$JOB))
SET ^($JOB,0)=EXPR_"^"_CREAT
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 IF $DATA(^XTMP("PSOPOST7"))
Begin DoDot:1
+4 SET PSG(3,0)="There were Pharmacy orders - listed in ^XTMP(""PSOPOST7"",,""IV"""
SET PSG(4,0)="that had changes made."
+5 SET PSG(5,0)="Please spot check some of the affected orders to be sure"
SET PSG(6,0)="they are now correct."
+6 IF $DATA(^XTMP("PSJ0099"))
SET PSG(7,0)="Some orders could not be changed. These are listed in XTMP(""PSJ0099""."
SET PSG(8,0)="Please check these patients to be sure their profile is correct."
End DoDot:1
+7 DO ^XMD
+8 QUIT
NOSTOP SET D2=0
SET OLD=""
+1 FOR
SET D2=$ORDER(^PS(55,DFN,"IV",PSJORD,"A",D2))
if 'D2
QUIT
Begin DoDot:1
+2 SET D3=0
+3 FOR
SET D3=$ORDER(^PS(55,DFN,"IV",PSJORD,"A",D2,1,D3))
if 'D3
QUIT
Begin DoDot:2
+4 SET ACTDATA=^PS(55,DFN,"IV",PSJORD,"A",D2,1,D3,0)
+5 if $PIECE(ACTDATA,"^")'="STATUS"
QUIT
SET A=$PIECE(ACTDATA,"^",2)
+6 IF A'="DISCONTINUED"
IF A'="EXPIRED"
IF A'="PURGE"
IF A'="ON CALL"
IF A'="NON VERIFIED"
QUIT
+7 SET OLD=A
End DoDot:2
End DoDot:1
+8 IF OLD=""
IF PSSTOP=1
SET OLD="PURGE"
+9 SET STATUS=$SELECT(OLD="DISCONTINUED":"D",OLD="EXPIRED":"E",OLD="PURGE":"P",OLD="ON CALL":"OC",OLD="NON VERIFIED":"N",1:"")
+10 KILL DR
SET DIE="^PS(55,"_DFN_",""IV"","
SET DA=PSJORD
SET DA(1)=DFN
SET DR="100////"_STATUS
DO ^DIE
+11 IF STATUS=""
SET $PIECE(^PS(55,DFN,"IV",PSJORD,0),"^",17)=""
+12 KILL ^XTMP("PSJ0099",$JOB,DFN,PSJORD)
QUIT
