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

PSOCMOPA.m

Go to the documentation of this file.
  1. PSOCMOPA ;BIR/HTW-Utility for Hold/Can/Park ;Feb 07, 2019@06:29:42
  1. ;;7.0;OUTPATIENT PHARMACY;**61,76,443,508,441**;DEC 1997;Build 208
  1. ;External Referrence to file # 550.2 granted by DBIA 2231
  1. ;Required input: DA - internal entry # - ^PSRX
  1. ;Returns:
  1. ;CMOP("L")=LAST FILL... if it is orig Rx =0
  1. ;CMOP(FILL #)=CMOP status from 52...Trans/0,DISP/1,RETRAN/2,NOT DISP/3
  1. ;If suspended CMOP("S")=CMOP suspense status Q,L,X,P,R
  1. ;PSOCMOP=STATUS_^_TRAN DATE_^_LAST FILL
  1. ;All returned variables can be killed by K CMOP,PSOCMOP
  1. ;
  1. N X,XN,BATCH,TDT,BIEN
  1. K PSOCMOP
  1. S (CMOP("L"),X)=0 F S X=$O(^PSRX(DA,1,X)) Q:'X S CMOP("L")=X
  1. I $O(^PSRX(DA,4,0)) F X=0:0 S X=$O(^PSRX(DA,4,X)) Q:'X D
  1. .S XN=$G(^PSRX(DA,4,X,0)),BATCH=$P($G(XN),"^") Q:$G(BATCH)']""
  1. .S BIEN=$O(^PSX(550.2,"B",BATCH,"")) Q:$G(BIEN)']"" S TDT=$P(^PSX(550.2,BIEN,0),"^",6)
  1. .S CMOP($P($G(XN),"^",3))=$P($G(XN),"^",4),PSOCMOP=$P($G(XN),"^",4)_"^"_$G(TDT)_"^"_CMOP("L")
  1. S X=$O(^PS(52.5,"B",DA,0)) I X]"" S CMOP("S")=$P($G(^PS(52.5,X,0)),"^",7),CMOP("52.5")=X
  1. K X,XN,BATCH,TDT,BIEN
  1. Q
  1. UNHOLD N FDT S FDT=PSORX("FILL DATE"),XFROM="UNHOLD" G EN1
  1. UNPARK N FDT S FDT=PSORX("FILL DATE"),XFROM="UNPARK" G EN1 ;441 PAPI
  1. REINS S XFROM="REINSTATE"
  1. EN1 D SUS1^PSOCMOP I '$G(XFLAG) G KILL
  1. D PSOCMOPA
  1. I $G(REL)]""!($G(CMOP(CMOP("L")))=0)!($G(CMOP(CMOP("L")))=2) D G KILL
  1. .I XFROM="REINSTATE" W !!,RX_" REINSTATED -- ",! Q
  1. .I XFROM="UNHOLD" W !!,$P(^PSRX(DA,0),"^")_" Removed from Hold Status",!!
  1. .I XFROM="UNPARK" W !!,$P(^PSRX(DA,0),"^")_" Removed from Park Status",!! ;441 PAPI
  1. I $G(CMOP(CMOP("L")))']"" D S^PSOCMOP G KILL
  1. I $G(CMOP(CMOP("L")))=3,(FDT>DT) D S^PSOCMOP G KILL
  1. KILL D D1^PSOCMOP
  1. K CMOP,DIR,X,DIRUT,DUOUT,Y,DTOUT,XFROM
  1. Q
  1. ;
  1. QS W !! S DIR("A")="LABEL: QUEUE"_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_" or '^' to bypass "
  1. S DIR("?",1)="Enter 'Q' to queue labels for printing" S:$P(PSOPAR,"^",24) DIR("?",2)="Enter 'S' to suspend labels for printing at a later date"
  1. S DIR(0)="SA^Q:QUEUE"_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:""),DIR("B")="Q" D ^DIR K DIR
  1. I $D(DUOUT)!$D(DIRUT) G KILL
  1. I $G(Y)="S" D S^PSOCMOP K CMOP Q
  1. I $G(Y)="Q" D D1^PSOCMOP K CMOP I $G(PSOLAP)]"",($G(PSOLAP)'=ION) S PPL=DA,RXLTOP=1 D QLBL^PSORXL Q
  1. I $G(Y)="Q" S PPL=DA,RXLTOP=1 D Q1^PSORXL
  1. Q
  1. HLD N PSOFROM S PSOFROM="HOLD"
  1. EN ; Called from PSORXDL,HLD+4^PSOHLD, PSOCAN, PSOPRK
  1. ; if in suspense and "loading" no delete
  1. Q:'$G(DA) D PSOCMOPA
  1. I $G(CMOP("S"))="L" D MSG K CMOP Q
  1. ; PSO*7*508 - quit before the DIR call if this is an eRx
  1. I $G(PSOFROM)="HOLD",($G(CMOP(CMOP("L")))=0!($G(CMOP(CMOP("L")))=2)) D MSG D MSG Q:$G(ERXDCIEN) K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR ;*443
  1. I $G(PSOFROM)="DELETE",($G(CMOP(CMOP("L")))=0!($G(CMOP(CMOP("L")))=2)) D MSG
  1. K CMOP
  1. Q
  1. MSG I $G(ERXDCIEN) S XFLAG=1 Q
  1. ;441 PAPI
  1. W !!,"A CMOP Rx cannot be"_$S($G(PSOFROM)="HOLD":" placed on HOLD",$G(PSOFROM)="CANCEL":" DISCONTINUED",$G(PSOFROM)="PARK":" PARKED",1:" DELETED")
  1. W $S($G(PSOFROM)="DELETE":" while in",1:" during")
  1. W $S($G(PSOFROM)="DELETE":" transmission status!",1:" transmission! ")_" Try later.",!!
  1. S XFLAG=1
  1. Q
  1. CMOP ;
  1. I $D(^PSRX(RXN,4)) F PSXZ=0:0 S PSXZ=$O(^PSRX(RXN,4,PSXZ)) Q:'PSXZ D
  1. .S PSX($P(^PSRX(RXN,4,PSXZ,0),U,3))=$P(^PSRX(RXN,4,PSXZ,0),U,4)
  1. K PSXZ
  1. Q
  1. DUPCAN N DA,PSOFROM S DA=+PSOSD(STA,DNM),PSOFROM="CANCEL" G EN
  1. ;Called from ASK+4^PSORENW
  1. MW(PSODIR) ;
  1. K DIR,DIC
  1. S DIR(0)="52,11"
  1. S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
  1. I $G(PSODRUG("DEA"))["D",$E($G(PSORX("MAIL/WINDOW")))="P" S DIR("B")="WINDOW" ;441 PAPI
  1. I ($G(PSODRUG("DEA"))["D")!($G(DRGNM)["CLOZAPINE") S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW" G MW0 ;441 PAPI & CLOZAPINE
  1. ;I $P(PSOPAR,"^",34) S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
  1. ;I '$P(PSOPAR,"^",34) S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
  1. N RESULTS,PSOPARKX
  1. S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
  1. I $G(PSOPARKX(0))="YES" S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
  1. E S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
  1. MW0 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX
  1. I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX
  1. S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0)
  1. MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX
  1. S DIR(0)="52,35O"
  1. S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP")
  1. D DIR G:PSODIR("DFLG") MWX
  1. I X[U W !,"Cannot jump to another field ..",! G MW1
  1. S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
  1. MWX K X,Y
  1. Q
  1. DIR ;
  1. S PSODIR("FIELD")=0
  1. G:$G(DIR(0))']"" DIRX
  1. D ^DIR K DIR,DIE,DIC,DA
  1. I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
  1. DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
  1. Q