- 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
- 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
