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

PSOEXRST.m

Go to the documentation of this file. 
  1. PSOEXRST ;BIR/RTR-Reprint/View HL7 Interface batch ;1/1/96
  1.  ;;7.0;OUTPATIENT PHARMACY;**26**;DEC 1997
  1.  ;External reference to ^PSDRUG supported by DBIA 221
  1. VW D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) G END
  1. START W !!,"Enter a date/time range to see all batches sent to the External Interface."
  1. BEG K ^TMP($J,"PSOHLRES"),^TMP($J,"PSOHLSPR"),^UTILITY($J,"PSOHLEPT"),PSOOUT,DTOUT,PSOLISTY
  1.  W ! K %DT S %DT="AEXT",%DT("A")="Start date/time: " D ^%DT K %DT G:Y<0!($D(DTOUT)) END S (%DT(0),BEGDATE)=Y W ! S %DT="AEXT",%DT("A")="End date/time: " D ^%DT K %DT G:Y<0!($D(DTOUT)) END S ENDDATE=Y
  1.  S BEGDATE=BEGDATE-.0001,ENDDATE=$S('$P(ENDDATE,".",2):ENDDATE_".9999",1:ENDDATE+.0001),RECNT=1 W !!,"Gathering batches, please wait...",! H 1
  1.  F ZZZ=BEGDATE:0 S ZZZ=$O(^PS(52.51,"AS",ZZZ)) Q:'ZZZ!(ZZZ>ENDDATE)  F XXX=0:0 S XXX=$O(^PS(52.51,"AS",ZZZ,PSOSITE,XXX)) Q:'XXX  D
  1.  .S ^TMP($J,"PSOHLRES",RECNT,ZZZ,PSOSITE,XXX)="",RECNT=RECNT+1
  1.  I '$D(^TMP($J,"PSOHLRES")) W $C(7),!!,"There are no printed batches found for that date/time range!",! G BEG
  1.  H 1 W @IOF W !?1,"BATCH",?10,"QUEUED TO PRINT ON:",?40,"PRINTED BY:",?56,$E($P($G(^PS(59,PSOSITE,0)),"^"),1,23),! F AA=1:1:78 W "-"
  1.  W ! F AAA=0:0 S AAA=$O(^TMP($J,"PSOHLRES",AAA)) Q:'AAA!($G(PSOOUT))  S PSIDATE=$O(^TMP($J,"PSOHLRES",AAA,0)),PSODUZ=$O(^TMP($J,"PSOHLRES",AAA,PSIDATE,PSOSITE,0)) D ZZNAME D
  1.  .S Y=PSIDATE X ^DD("DD") S PSODATE=Y,PSOUSER=$S($D(^VA(200,PSODUZ,0)):$P($G(^(0)),"^"),1:"UNKNOWN") D:($Y+5)>IOSL  Q:$G(PSOOUT)  W !?2,AAA,?10,PSODATE,?40,PSOUSER
  1.  ..W ! K DIR S DIR(0)="E" D ^DIR K DIR S:'Y PSOOUT=1 I Y W @IOF W !?1,"BATCH",?10,"QUEUED TO PRINT ON:",?40,"PRINTED BY:",?56,$E($P($G(^PS(59,PSOSITE,0)),"^"),1,23),! F AA=1:1:78 W "-"
  1.  I $G(PSOOUT),Y="" G END
  1.  S RECNT=RECNT-1,PSOOUT=0 W ! K DIR S DIR("A")="Select Batch(s) to "_$S($G(PSOEXVW):"view",1:"reprint"),DIR(0)="L^1:"_RECNT D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!?3,"Nothing chosen to "_$S($G(PSOEXVW):"view",1:"reprint"),! G START
  1.  S COUNT=1 F ZZ=1:1:$L(Y) S ZZZ=$E(Y,ZZ) I ZZZ="," S COUNT=COUNT+1
  1.  S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y,",",JJ),^TMP($J,"PSOHLSPR",RR)=""
  1. YLOOP I $G(Y(1)) F PSYLOOP=0:0 S PSYLOOP=$O(Y(PSYLOOP)) Q:'PSYLOOP  D
  1.  .S COUNT=1 F ZZ=1:1:$L(Y(PSYLOOP)) S ZZZ=$E(Y(PSYLOOP),ZZ) I ZZZ="," S COUNT=COUNT+1
  1.  .S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y(PSYLOOP),",",JJ),^TMP($J,"PSOHLSPR",RR)=""
  1.  W !!,"Batches selected for "_$S($G(PSOEXVW):"Viewing",1:"Reprint")_" are:",! F ZZZ=0:0 S ZZZ=$O(^TMP($J,"PSOHLSPR",ZZZ)) Q:'ZZZ  D
  1.  .S PSIDATE=$O(^TMP($J,"PSOHLRES",ZZZ,0)),PSODUZ=$O(^TMP($J,"PSOHLRES",ZZZ,PSIDATE,PSOSITE,0)) S Y=PSIDATE X ^DD("DD") S PSODATE=Y,PSOUSER=$S($D(^VA(200,PSODUZ,0)):$P($G(^(0)),"^"),1:"UNKNOWN")
  1.  .W !,"Batch ",ZZZ," Queued for ",PSODATE," by ",PSOUSER
  1.  K PSOLISTY I $G(PSOEXVW) S Y=1 G VWPASS
  1.  W ! K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Before Reprinting, would you like a list of these prescriptions" D ^DIR K DIR I Y["^"!($D(DTOUT)) W !!?3,"Nothing queued to reprint!",! G START
  1. VWPASS I Y W ! S PSOLISTY=1 S DIR(0)="SB^S:SCREEN;P:PRINTER",DIR("A")="Print list to the screen or to a printer",DIR("B")="Screen" D ^DIR K DIR I $D(DIRUT) W !!?3,"Nothing queued to print!",! G START
  1.  I $G(PSOLISTY),Y="P" D ^PSOEXBCH G START
  1.  I $G(PSOLISTY) D LIST I $G(PSOOUT)!($G(PSOEXVW)) G START
  1.  K DIR W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Are you sure you want to Reprint labels" D ^DIR K DIR I Y'=1 W !!,"Nothing queued to Reprint!",! G START
  1. QUE D GETPPL^PSOEXBCH
  1.  K PSOEXREX
  1.  I '$D(PPLX) W !!,"No Active Labels to Reprint!",! G START
  1.  F ZPPL=0:0 S ZPPL=$O(PPLX(ZPPL)) Q:'ZPPL!($G(PSOEXREX))  D
  1.  .K PPL,RXPR S PPL=PPLX(ZPPL) F PPLPAR=0:0 S PPLPAR=$O(RXPRX(ZPPL,PPLPAR)) Q:'PPLPAR  S RXPR(PPLPAR)=RXPRX(ZPPL,PPLPAR)
  1.  .D RACT
  1.  .S PSOEXREP=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL")
  1.  I '$G(PSOEXREX) W !!,"LABEL(S) QUEUED TO PRINT!",!
  1.  ;W ! K %DT D NOW^%DTC S %DT="REAX",%DT(0)=%,%DT("B")="NOW",%DT("A")="Queue labels to reprint at what time: " D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!?3,"Nothing queued to reprint!",! G START
  1.  ;S PSOSUREP=1,PSORTIME=Y
  1.  ;W ! S %ZIS("A")="REPRINT LABEL DEVICE: ",%ZIS("B")="",%ZIS="MQN" D ^%ZIS I POP!($E(IOST)["C") G START
  1.  ;F J=0,1 S @("PSOBAR"_J)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J)) S @("PSOBAR"_J)=^("BAR"_J)
  1.  ;S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19)
  1.  ;S PSOREDEV=ION
  1.  ;S ZTRTN="BEG^PSOSUSRP",ZTDTH=PSORTIME,ZTIO=PSOREDEV,ZTDESC="REPRINT LABELS FROM SUSPENSE"
  1.  ;F GG="PSOPAR","PSOSYS","PSOSITE","PSOSUREP","PSOBARS","PSOBAR0","PSOBAR1" S:$D(@GG) ZTSAVE(GG)=""
  1.  ;F NNN=0:0 S NNN=$O(^TMP($J,"PSORESPR",NNN)) Q:'NNN  D
  1.  ;.S PSRDATE=$O(^TMP($J,"PSORES",NNN,0)),PSRDUZ=$O(^TMP($J,"PSORES",NNN,PSRDATE,0)),PSRDIV=$O(^TMP($J,"PSORES",NNN,PSRDATE,PSRDUZ,0))
  1.  ;.S ^UTILITY($J,"PSOREPT",PSRDATE,PSRDUZ,PSRDIV)=""
  1.  ;S ZTSAVE("^UTILITY($J,""PSOREPT"",")="" D ^%ZTLOAD
  1.  ;W !!,"REPRINTED LABELS QUEUED TO PRINT!",!
  1. END K ^TMP($J,"PSOHLRES"),^TMP($J,"PSOHLSPR"),%DT,%ZIS,AA,AAA,BEGDATE,COUNT,DUOUT,DTOUT,ENDDATE,GG,INRX,JJ,LLL,MMM,NNN,POP,PSIDATE,PSODATE,PSODUZ,PSOREDEV,PSORTIME,PSOSUREP,PSOUSER,PSYLOOP,NM1,NM2,NM3,HLZNAME,ZZNAME,PSOEXREP,ZPPL,PPLPAR,RXPR
  1.  K HLZZNAME,HLZZDRUG,HLZZDRUL,PSRDATE,PSRDIV,PSOLISTY,PSRDUZ,RECNT,REDT,REDUZ,RR,SS,XXX,ZZ,ZZZ,ZZNM,ZZNM1,ZZZ,PSOEXVW,PSEXSTAT,PSX,PPL,PPLX,RXPRX,RXPR,PSOEXREX D ^%ZISC Q
  1. LIST F LLL=0:0 S LLL=$O(^TMP($J,"PSOHLSPR",LLL)) Q:'LLL!($G(PSOOUT))  D GETN D
  1.  .W ! S DIR(0)="E" D ^DIR K DIR S:'Y PSOOUT=1 Q:$G(PSOOUT)  D HEAD S REDT=$O(^TMP($J,"PSOHLRES",LLL,0)),REDUZ=$O(^TMP($J,"PSOHLRES",LLL,REDT,PSOSITE,0)) F SS=0:0 S SS=$O(^PS(52.51,"AS",REDT,PSOSITE,REDUZ,SS)) Q:'SS!($G(PSOOUT))  D
  1.  ..D:($Y+5)>IOSL HEADONE Q:$G(PSOOUT)  I $D(^PS(52.51,SS,0)),$P($G(^(0)),"^",11)=PSOSITE S INRX=$P(^(0),"^") I $D(^PSRX(INRX,0)) D
  1.  ...;D STAT
  1.  ...S HLZZNAME=$P($G(^DPT(+$P($G(^PSRX(INRX,0)),"^",2),0)),"^")
  1.  ...S HLZZDRUG=$P($G(^PSDRUG(+$P($G(^PSRX(INRX,0)),"^",6),0)),"^"),HLZZDRUL=$L($G(HLZZDRUG))
  1.  ...W !,$P(^PSRX(INRX,0),"^"),?13,$G(HLZZNAME)
  1.  ...I +$G(HLZZDRUL)<37 W ?44,$G(HLZZDRUG) Q
  1.  ...W !?38,$G(HLZZDRUG)
  1.  I $G(PSOOUT),(Y="") Q
  1.  S PSOOUT=0 I Y'=0 W !,"END OF LIST"
  1.  Q
  1.  Q
  1. HEADONE S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
  1.  W @IOF W !,"RX #",?13,"PATIENT NAME",?44,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
  1.  Q
  1. GETN S NM1=$O(^TMP($J,"PSOHLRES",LLL,0)),NM2=$O(^TMP($J,"PSOHLRES",LLL,NM1,PSOSITE,0)),NM3=$O(^PS(52.51,"AS",NM1,PSOSITE,NM2,0))
  1.  S HLZNAME=$P($G(^DPT(+$P($G(^PS(52.51,+$G(NM3),0)),"^",2),0)),"^")
  1.  Q
  1. ZZNAME S ZZNM=+$O(^PS(52.51,"AS",PSIDATE,PSOSITE,PSODUZ,0)),ZZNM1=+$P($G(^PS(52.51,ZZNM,0)),"^",2)
  1.  S ZZNAME=$P($G(^DPT(ZZNM1,0)),"^")
  1.  Q
  1. VIEW ;
  1.  S PSOEXVW=1 G VW
  1.  ;
  1. STAT ;
  1.  S PSX=$P($G(^PSRX(INRX,"STA")),"^")
  1.  S PSEXSTAT=$S(PSX=0:"ACTIVE",PSX=1:"NON-VERIFIED",PSX=3:"HOLD",PSX=4:"DRUG INTERACTION",PSX=5:"SUSPENDED",PSX=11:"EXPIRED",PSX=12!(PSX=14):"DISCONTINUED",PSX=13:"DELETED",PSX=15:"DISCONTINUED (EDIT)",PSX=16:"PROVIDER HOLD",1:"")
  1.  Q
  1. RACT ;Set activity log
  1.  N WW,WRX,WRX,WFILL,WWW,WIR
  1.  F WW=1:1 S WRX=$P(PPL,",",WW) Q:'WRX  D:$G(WRX)
  1.  .I '$G(RXPR(WRX)) S WFILL=0 F WWW=0:0 S WWW=$O(^PSRX(WRX,1,WWW)) Q:'WWW  S WFILL=WWW S:WWW>5 WFILL=WWW+1
  1.  .S WIR=0 F WWW=0:0 S WWW=$O(^PSRX(WRX,"A",WWW)) Q:'WWW  S WIR=WWW
  1.  .S WIR=WIR+1,^PSRX(WRX,"A",0)="^52.3DA^"_WIR_"^"_WIR
  1.  .D NOW^%DTC S ^PSRX(WRX,"A",WIR,0)=%_"^W^"_+$G(DUZ)_"^"_$S($G(RXPR(WRX)):6,1:$G(WFILL))_"^"_"Reprint "_$S($G(RXPR(WRX)):"(PARTIAL) ",1:"")_"(Originally sent to External Interface)"
  1.  Q