PSXOPUTL ;BIR/HTW-Utility for Hold/Can ;[ 04/08/97 2:06 PM ]
;;2.0;CMOP;;11 Apr 97
;Required input: DA - internal entry # - ^PSRX
;Returns:
;PSXZ("L")=LAST FILL... if it is orig Rx =0
;PSXZ(FILL #)=CMOP status from 52...Trans/0,DISP/1,RETRAN/2,NOT DISP/3
;If suspended PSXZ("S")=CMOP suspense status Q,L,X,P,R
;All returned variables can be killed by K PSXZ
;
N X
S (PSXZ("L"),X)=0 F S X=$O(^PSRX(DA,1,X)) Q:'X S PSXZ("L")=X
I $O(^PSRX(DA,4,0)) F X=0:0 S X=$O(^PSRX(DA,4,X)) Q:'X D
.S PSXZ($P($G(^PSRX(DA,4,X,0)),"^",3))=$P($G(^(0)),"^",4)
S X=$O(^PS(52.5,"B",DA,0)) I X]"" S PSXZ("S")=$P($G(^PS(52.5,X,0)),"^",7)
K X
Q
UNHOLD N FDT S FDT=PSORX("FILL DATE"),PSXFROM="UNHOLD" G EN1
REINS S PSXFROM="REINSTATE"
EN1 D SUS1^PSXNEW I '$G(PSXFLAG) G KILL
D PSXOPUTL
I $G(PSXEDREL)]""!($G(PSXZ(PSXZ("L")))=0)!($G(PSXZ(PSXZ("L")))=2) D G KILL
.I PSXFROM="REINSTATE" W !!,RX_" REINSTATED -- ",! Q
.I PSXFROM="UNHOLD" W !!,$P(^PSRX(DA,0),"^")_" Removed from Hold Status",!!
I $G(PSXZ(PSXZ("L")))']"" D S^PSXNEW G KILL
I $G(PSXZ(PSXZ("L")))=3,(FDT>DT) D S^PSXNEW G KILL
I $G(PSXZ(PSXZ("L")))=3,((FDT<DT)!(FDT=DT)) D QS
KILL D D1^PSXNEW
K PSXZ,DIR,X,DIRUT,DUOUT,Y,DTOUT,PSXFROM
Q
;
QS W !! S DIR("A")="LABEL: QUEUE"_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_" or '^' to bypass "
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"
S DIR(0)="SA^Q:QUEUE"_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:""),DIR("B")="Q" D ^DIR K DIR
I $D(DUOUT)!$D(DIRUT) G KILL
I $G(Y)="S" D S^PSXNEW K PSXZ Q
I $G(Y)="Q" D D1^PSXNEW K PSXZ I $G(PSOLAP)]"",($G(PSOLAP)'=ION) S PPL=DA D QLBL^PSORXL Q
I $G(Y)="Q" S PPL=DA D Q1^PSORXL
Q
HLD N PSOFROM S PSOFROM="HOLD"
EN ; Called from PSORXDL,HLD+4^PSOHLD, PSOCAN
; if in suspense and "loading" no delete
Q:'$G(DA) D ^PSXOPUTL
I $G(PSXZ("S"))="L" D MSG K PSXZ Q
I $G(PSOFROM)="DELETE",($G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2)) D MSG
K PSXZ
Q
MSG W !!,"A CMOP Rx cannot be"_$S($G(PSOFROM)="HOLD":" placed on HOLD",$G(PSOFROM)="CANCEL":" CANCELLED",1:" DELETED")
W $S($G(PSOFROM)="DELETE":" while in",1:" during")
W $S($G(PSOFROM)="DELETE":" transmission status!",1:" transmission! ")_" Try later.",!!
S PSXDFLAG=1
Q
CMOP ;
I $D(^PSRX(RXN,4)) F PSXZ=0:0 S PSXZ=$O(^PSRX(RXN,4,PSXZ)) Q:'PSXZ D
.S PSX($P(^PSRX(RXN,4,PSXZ,0),U,3))=$P(^PSRX(RXN,4,PSXZ,0),U,4)
K PSXZ
Q
DUPCAN N DA,PSOFROM S DA=+PSOSD(DNM),PSOFROM="CANCEL" G EN
;Called from ASK+4^PSORENW
MW(PSODIR) ;
K DIR,DIC
S DIR(0)="52,11"
S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX
I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX
S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0)
MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX
S DIR(0)="52,35O"
S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP")
D DIR G:PSODIR("DFLG") MWX
I X[U W !,"Cannot jump to another field ..",! G MW1
S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
MWX K X,Y
Q
DIR ;
S PSODIR("FIELD")=0
G:$G(DIR(0))']"" DIRX
D ^DIR K DIR,DIE,DIC,DA
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXOPUTL 3356 printed Nov 22, 2024@16:54:50 Page 2
PSXOPUTL ;BIR/HTW-Utility for Hold/Can ;[ 04/08/97 2:06 PM ]
+1 ;;2.0;CMOP;;11 Apr 97
+2 ;Required input: DA - internal entry # - ^PSRX
+3 ;Returns:
+4 ;PSXZ("L")=LAST FILL... if it is orig Rx =0
+5 ;PSXZ(FILL #)=CMOP status from 52...Trans/0,DISP/1,RETRAN/2,NOT DISP/3
+6 ;If suspended PSXZ("S")=CMOP suspense status Q,L,X,P,R
+7 ;All returned variables can be killed by K PSXZ
+8 ;
+9 NEW X
+10 SET (PSXZ("L"),X)=0
FOR
SET X=$ORDER(^PSRX(DA,1,X))
if 'X
QUIT
SET PSXZ("L")=X
+11 IF $ORDER(^PSRX(DA,4,0))
FOR X=0:0
SET X=$ORDER(^PSRX(DA,4,X))
if 'X
QUIT
Begin DoDot:1
+12 SET PSXZ($PIECE($GET(^PSRX(DA,4,X,0)),"^",3))=$PIECE($GET(^(0)),"^",4)
End DoDot:1
+13 SET X=$ORDER(^PS(52.5,"B",DA,0))
IF X]""
SET PSXZ("S")=$PIECE($GET(^PS(52.5,X,0)),"^",7)
+14 KILL X
+15 QUIT
UNHOLD NEW FDT
SET FDT=PSORX("FILL DATE")
SET PSXFROM="UNHOLD"
GOTO EN1
REINS SET PSXFROM="REINSTATE"
EN1 DO SUS1^PSXNEW
IF '$GET(PSXFLAG)
GOTO KILL
+1 DO PSXOPUTL
+2 IF $GET(PSXEDREL)]""!($GET(PSXZ(PSXZ("L")))=0)!($GET(PSXZ(PSXZ("L")))=2)
Begin DoDot:1
+3 IF PSXFROM="REINSTATE"
WRITE !!,RX_" REINSTATED -- ",!
QUIT
+4 IF PSXFROM="UNHOLD"
WRITE !!,$PIECE(^PSRX(DA,0),"^")_" Removed from Hold Status",!!
End DoDot:1
GOTO KILL
+5 IF $GET(PSXZ(PSXZ("L")))']""
DO S^PSXNEW
GOTO KILL
+6 IF $GET(PSXZ(PSXZ("L")))=3
IF (FDT>DT)
DO S^PSXNEW
GOTO KILL
+7 IF $GET(PSXZ(PSXZ("L")))=3
IF ((FDT<DT)!(FDT=DT))
DO QS
KILL DO D1^PSXNEW
+1 KILL PSXZ,DIR,X,DIRUT,DUOUT,Y,DTOUT,PSXFROM
+2 QUIT
+3 ;
QS WRITE !!
SET DIR("A")="LABEL: QUEUE"_$SELECT($PIECE(PSOPAR,"^",24):"/SUSPEND",1:"")_" or '^' to bypass "
+1 SET DIR("?",1)="Enter 'Q' to queue labels for printing"
if $PIECE(PSOPAR,"^",24)
SET DIR("?",2)="Enter 'S' to suspend labels for printing at a later date"
+2 SET DIR(0)="SA^Q:QUEUE"_$SELECT($PIECE(PSOPAR,"^",24):";S:SUSPENSE",1:"")
SET DIR("B")="Q"
DO ^DIR
KILL DIR
+3 IF $DATA(DUOUT)!$DATA(DIRUT)
GOTO KILL
+4 IF $GET(Y)="S"
DO S^PSXNEW
KILL PSXZ
QUIT
+5 IF $GET(Y)="Q"
DO D1^PSXNEW
KILL PSXZ
IF $GET(PSOLAP)]""
IF ($GET(PSOLAP)'=ION)
SET PPL=DA
DO QLBL^PSORXL
QUIT
+6 IF $GET(Y)="Q"
SET PPL=DA
DO Q1^PSORXL
+7 QUIT
HLD NEW PSOFROM
SET PSOFROM="HOLD"
EN ; Called from PSORXDL,HLD+4^PSOHLD, PSOCAN
+1 ; if in suspense and "loading" no delete
+2 if '$GET(DA)
QUIT
DO ^PSXOPUTL
+3 IF $GET(PSXZ("S"))="L"
DO MSG
KILL PSXZ
QUIT
+4 IF $GET(PSOFROM)="DELETE"
IF ($GET(PSXZ(PSXZ("L")))=0!($GET(PSXZ(PSXZ("L")))=2))
DO MSG
+5 KILL PSXZ
+6 QUIT
MSG WRITE !!,"A CMOP Rx cannot be"_$SELECT($GET(PSOFROM)="HOLD":" placed on HOLD",$GET(PSOFROM)="CANCEL":" CANCELLED",1:" DELETED")
+1 WRITE $SELECT($GET(PSOFROM)="DELETE":" while in",1:" during")
+2 WRITE $SELECT($GET(PSOFROM)="DELETE":" transmission status!",1:" transmission! ")_" Try later.",!!
+3 SET PSXDFLAG=1
+4 QUIT
CMOP ;
+1 IF $DATA(^PSRX(RXN,4))
FOR PSXZ=0:0
SET PSXZ=$ORDER(^PSRX(RXN,4,PSXZ))
if 'PSXZ
QUIT
Begin DoDot:1
+2 SET PSX($PIECE(^PSRX(RXN,4,PSXZ,0),U,3))=$PIECE(^PSRX(RXN,4,PSXZ,0),U,4)
End DoDot:1
+3 KILL PSXZ
+4 QUIT
DUPCAN NEW DA,PSOFROM
SET DA=+PSOSD(DNM)
SET PSOFROM="CANCEL"
GOTO EN
+1 ;Called from ASK+4^PSORENW
MW(PSODIR) ;
+1 KILL DIR,DIC
+2 SET DIR(0)="52,11"
+3 SET DIR("B")=$SELECT($GET(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
+4 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO MWX
+5 IF $GET(Y(0))']""
SET PSODIR("DFLG")=1
GOTO MWX
+6 SET PSODIR("MAIL/WINDOW")=Y
SET PSORX("MAIL/WINDOW")=Y(0)
MW1 if PSODIR("MAIL/WINDOW")'="W"!('$PIECE($GET(PSOPAR),"^",12))
GOTO MWX
+1 SET DIR(0)="52,35O"
+2 if $GET(PSORX("METHOD OF PICK-UP"))]""
SET DIR("B")=PSORX("METHOD OF PICK-UP")
+3 DO DIR
if PSODIR("DFLG")
GOTO MWX
+4 IF X[U
WRITE !,"Cannot jump to another field ..",!
GOTO MW1
+5 SET (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
MWX KILL X,Y
+1 QUIT
DIR ;
+1 SET PSODIR("FIELD")=0
+2 if $GET(DIR(0))']""
GOTO DIRX
+3 DO ^DIR
KILL DIR,DIE,DIC,DA
+4 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
IF $LENGTH($GET(X))'>1!(Y="")
SET PSODIR("DFLG")=1
GOTO DIRX
DIRX KILL DIRUT,DTOUT,DUOUT,DIROUT,PSOX
+1 QUIT
