Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOSUCLE

PSOSUCLE.m

Go to the documentation of this file.
  1. PSOSUCLE ;BIR/SAB-utility to resuspended Rxs ;04/11/00
  1. ;;7.0;OUTPATIENT PHARMACY;**39**;DEC 1997
  1. ;External reference to ^PSDRUG supported by DBIA 221
  1. ;External reference to ^DPT supported by DBIA 10035
  1. ;
  1. D ^PSOLSET K DIRUT,DUOUT,DIR
  1. W !! S DIR(0)="SA^Q:Queue Background;R:Run while I wait;E:Exit"
  1. S DIR("A",1)="This utility will re-suspend all prescriptions that have not yet printed or have",DIR("A",2)="not been queued for transmission to CMOP."
  1. S DIR("A",3)=" ",DIR("A",4)="Do you want to Queue to run in the background or"
  1. S DIR("B")="Queue",DIR("A")="Run while you wait? " D ^DIR
  1. G:Y="Q" QUE G:X="E"!($D(DIRUT)) EXIT
  1. EN K SUSDAT,XFLAG,PSOQ,^TMP("PSOSUCLE",$J)
  1. F SU=0:0 S SU=$O(^PS(52.5,SU)) Q:'SU I $P(^PS(52.5,SU,0),"^",7)="",$G(^("P"))=0 D
  1. .I $P(^PS(52.5,SU,0),"^",2)="" S $P(^PS(52.5,SU,0),"^",2)=DT
  1. .I $D(^TMP("PSOSUCLE",$J,"RXN",$P(^PS(52.5,SU,0),"^"))) S DA=SU,DIK="^PS(52.5," D ^DIK Q
  1. .S ^TMP("PSOSUCLE",$J,SU,0)=^PS(52.5,SU,0),^TMP("PSOSUCLE",$J,"RXN",$P(^PS(52.5,SU,0),"^"))=""
  1. F SU=0:0 S SU=$O(^TMP("PSOSUCLE",$J,SU)) Q:'SU S SUSDAT=^TMP("PSOSUCLE",$J,SU,0) D REQUE K XFLAG,SUSDAT
  1. EXIT K ^TMP("PSOSUCLE",$J),SU,RXN,DIR,%DT,PSOQ,SD,L,RXN,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,XFLAG,SUSDAT,PSOSYS S ZTREQ="@"
  1. Q
  1. REQUE S RXN=$P(SUSDAT,"^"),DA=SU,ACT=1,SD=$S($P(SUSDAT,"^",2):$P(SUSDAT,"^",2),1:DT),DIK="^PS(52.5," D ^DIK
  1. I $P($G(^PSRX(RXN,"STA")),"^")=3 Q
  1. I $G(PSXSYS) S DA=RXN D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q
  1. S RXP=+$P(SUSDAT,"^",5),DIC="^PS(52.5,",DIC(0)="L",X=RXN
  1. S DIC("DR")=".02///"_SD_";.03////"_$P(SUSDAT,"^",3)_";.04///M;.05///"_RXP_";.06////"_$P(SUSDAT,"^",6)_";2///0;6////"_$P(SUSDAT,"^",10)_";8////"_$P(SUSDAT,"^",12)_";9////"_$P(SUSDAT,"^",13)
  1. K DD,DO D FILE^DICN K DD,DO
  1. S LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
  1. W:$G(PSOQ)'=1 !!,"Rx# "_$P(^PSRX(RXN,0),"^")_" has been Re-suspended until "_LFD_"."
  1. Q
  1. ACT S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
  1. S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S IR=FDA
  1. S IR=IR+1,^PSRX(RXN,"A",0)="^52.3DA^"_IR_"^"_IR
  1. D NOW^%DTC S ^PSRX(RXN,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"Rx Re-Suspended until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I,IR
  1. Q
  1. QUE ;queues job to background
  1. D NOW^%DTC S %DT(0)=% K %,%H,%I,X
  1. W !! S %DT="AETX",%DT("B")="Now",%DT("A")="Date and Time to Run: " D ^%DT I Y=-1 W !!,"Background Job not queued!",! G EXIT
  1. I $P(Y,".",2)="" W !!,"Date and time Required!",! G QUE
  1. S ZTRTN="EN^PSOSUCLE",ZTIO="",ZTDESC="Outpatient Pharmacy Utility Routine to Re-Suspend Rxs.",ZTDTH=Y,PSOQ=1
  1. F G="PSOQ","DUZ","PSOSYS","PSOPAR","PSOSITE","PSXSYS","PSXVER","PSOINST" S:$D(@G) ZTSAVE(G)=""
  1. D ^%ZTLOAD W:$D(ZTSK) !!,"Background Job Queued to Run.",! K ZTSK G EXIT
  1. Q
  1. RESUS ;resuspends individual Rxs that have printed local but should have gone to CMOP
  1. D ^PSOLSET I '$D(PSOPAR) W !,"No Division Selected!",! Q
  1. S DIC("A")="Select Rx to Re-Suspend: ",DIC=52.5,DIC(0)="AEQMZ",DIC("S")="I $P(^PS(52.5,+Y,0),""^"",7)'=""X"",$G(^(""P""))=1"
  1. D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT)) EXIT G:Y=-1 RESUS
  1. S SU=+Y,SUSDAT=Y(0) D REQUE K Y,XFLAG,SUSDAT,SU G RESUS
  1. Q
  1. SURPT ;prints report of printed Rxs that have cmop drugs
  1. D ^PSOLSET I '$D(PSOPAR) W !,"No Division Selected!",! Q
  1. W !!,"Enter a date range to see Rxs printed locally with CMOP Drugs from suspense within those dates."
  1. BEG W ! K %DT S %DT="AEX",%DT("A")="Start date: " D ^%DT K %DT G:Y<0!($D(DTOUT)) END S (%DT(0),BEGDATE,BEG)=Y
  1. W ! S %DT="AEX",%DT("A")="End date: " D ^%DT K %DT G:Y<0!($D(DTOUT)) END S (END,ENDDATE)=Y
  1. S BEGDATE=BEGDATE-.0001,ENDDATE=ENDDATE+.9999
  1. K %ZIS,IOP,ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G END
  1. K PSOION I $D(IO("Q")) D G END
  1. .S ZTDESC="Report that List Rxs from Suspense with CMOP Drugs.",ZTRTN="ENT^PSOSUCLE",ZTSAVE("ZTREQ")="@"
  1. .F G="BEG","END","BEGDATE","ENDDATE","PSOPAR","PSOSITE" S:$D(@G) ZTSAVE(G)=""
  1. .D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
  1. W !!,"Gathering Rxs, please wait...",! H 1
  1. ENT K ^TMP($J,"PSOREQ")
  1. F Z=BEGDATE:0 S Z=$O(^PS(52.5,"AS",Z)) Q:'Z!(Z>ENDDATE) F X=0:0 S X=$O(^PS(52.5,"AS",Z,X)) Q:'X F M=0:0 S M=$O(^PS(52.5,"AS",Z,X,M)) Q:'M D:M=$G(PSOSITE)
  1. .F Q=0:0 S Q=$O(^PS(52.5,"AS",Z,X,M,Q)) Q:'Q F DA=0:0 S DA=$O(^PS(52.5,"AS",Z,X,M,Q,DA)) Q:'DA D
  1. ..I '$D(^PS(52.5,DA,0)) K ^PS(52.5,"AS",Z,X,M,Q,DA) Q
  1. ..S RXN=$P(^PS(52.5,DA,0),"^"),DRG=$P(^PSRX(RXN,0),"^",6) Q:'$D(^PSDRUG("AQ",DRG))
  1. ..S ^TMP($J,"PSOREQ",DA,0)=RXN I $P(^PS(52.5,DA,0),"^",2)="" S $P(^PS(52.5,DA,0),"^",2)=Z
  1. D LIST
  1. END K ^TMP($J,"PSOREQ"),%DT,%ZIS,BEGDATE,DUOUT,DTOUT,ENDDATE,G,INRX,L,M,POP,X,ZZZZ,BEG,END,DRG,RXN,DRG D ^%ZISC
  1. Q
  1. LIST D HEAD I '$O(^TMP($J,"PSOREQ",0)) U IO W !!,"There are no locally printed CMOP Rxs printed for specified date range!",! Q
  1. F L=0:0 S L=$O(^TMP($J,"PSOREQ",L)) Q:'L!($G(PSOOUT)) I $D(^PS(52.5,L,0)) S INRX=$P(^(0),"^") I $D(^PSRX(INRX,0)) S DRG=$P(^(0),"^",6) D
  1. .W !,$P(^PSRX(INRX,0),"^"),?20,$P($G(^DPT(+$P(^PSRX(INRX,0),"^",2),0)),"^"),?60,$S($P($G(^PS(52.5,L,0)),"^",5):"(PARTIAL)",$P($G(^(0)),"^",12):"(REPRINT)",1:"")
  1. .W ?60,$E($P(^PS(52.5,L,0),"^",8),4,5)_"/"_$E($P(^PS(52.5,L,0),"^",8),6,7)_"/"_$E($P(^PS(52.5,L,0),"^",8),2,3),!?5,"Drug: "_$P($G(^PSDRUG(DRG,0)),"^")
  1. .D:($Y+5)>IOSL HEADONE
  1. W !,$S('$G(PSOOUT):"End of List",1:"Printout Terminated")
  1. Q
  1. W !,"Date Range Requested: "_$E(BEG,4,5)_"/"_$E(BEG,6,7)_"/"_$E(BEG,2,3)_" to "_$E(END,4,5)_"/"_$E(END,6,7)_"/"_$E(END,2,3),!
  1. W ! W "Rx #",?20,"Patient Name",?60,"Date Printed",!
  1. F ZZZZ=1:1:78 W "-"
  1. Q
  1. HEADONE I '$D(ZTSK) S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
  1. D HEAD
  1. Q