PSXNEW ;BIR/HTW/PWC-Rx Order Entry Screen for CMOP ;11 Mar 2002 4:38 PM
;;2.0;CMOP;**41**;11 Apr 97
; reference to ^PS(52.5 supported by DBIA #1978
; reference to ^PSRX supported by DBIA #1977
; reference to EN^PSOHLSN1 supported by DBIA #2385
; reference to ^XTMP("ORLK-" supported by DBIA #4001
RESET(PSXRX,PSXFILL,PSXREAS) ;
OERR ;clear ^XTMP("ORLK" if it is CPRS/CMOP
N ORD S ORD=+$P($G(^PSRX(+$G(PSXRX),"OR1")),"^",2)
I ORD,$D(^XTMP("ORLK-"_ORD,0)),^XTMP("ORLK-"_ORD,0)["CPRS/CMOP" K ^XTMP("ORLK-"_ORD)
; Remove and test individual RX's
N PSXRFD,PSXEDREL,PSOSITE,PSXSD,PSXLFD,PSXDFN,PSX525,PSXD,PSXZ,PSXRXF,PSXFDA
; Q:If tradename
Q:$G(^PSRX(PSXRX,"TN"))]""
; Q: If Cancelled, Expired, Deleted, Drug Interactions, Hold
Q:$P(^PSRX(PSXRX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3)
; Find last fill
S PSXRFD=+$O(^PSRX(PSXRX,1,"A"),-1)
S PSXEDREL=$S(PSXRFD=0:$P($G(^PSRX(PSXRX,2)),"^",13),1:$P($G(^PSRX(PSXRX,1,PSXRFD,0)),"^",18))
I PSXEDREL K DA,DIE,DR D
. I PSXRFD=0 S DA=PSXRX L +^PSRX(DA):600 S DIE="^PSRX(",DR="31///@" D ^DIE L -^PSRX(DA)
. I PSXRFD>0 S DA=PSXRFD,DA(1)=PSXRX L +^PSRX(DA(1),1,DA):600 S DIE="^PSRX(DA(1),1,",DR="17///@" D ^DIE L -^PSRX(DA(1),1,DA)
SUS ; Auto-Suspend CMOPS
N DA,Y
S DA=PSXRX
;D NOW^%DTC ; need to reset back to original suspended date
I PSXRFD=0 S %=$P(^PSRX(PSXRX,2),"^",2)
I PSXRFD>0 S %=$P(^PSRX(PSXRX,1,PSXRFD,0),"^",1)
S PSXSD=$P(%,".",1),PSXLFD=$E(%,4,5)_"-"_$E(%,6,7)_"-"_$E(%,2,3)
S PSXRXS=$O(^PS(52.5,"B",PSXRX,0))
I PSXRXS S DA=PSXRXS,DIK="^PS(52.5," D ^DIK S DA=PSXRX
I $G(PSXRFD)>0 S PSOSITE=$P(^PSRX(PSXRX,1,PSXRFD,0),"^",9)
I $G(PSXRFD)=0 S PSOSITE=$P(^PSRX(PSXRX,2),"^",9)
S DIC="^PS(52.5,",DIC(0)="Z"
K DD,DO S X=PSXRX,PSXDFN=$P(^PSRX(PSXRX,0),"^",2)
S DIC("DR")=".02////"_PSXSD_";.03////"_PSXDFN_";.04////M;.05////0;.06////"_PSOSITE_";2////0;3////Q;9////"_PSXRFD
D FILE^DICN K DIC,DIK,DD,DO
I +Y>0 S PSX525=+Y
E D EXIT Q
LOCK525 ;
L +^PS(52.5,PSX525):600 G:'$T LOCK525
K ^PS(52.5,"AC",PSXDFN,PSXSD,PSX525),PSXDFN
L -^PS(52.5,PSX525)
D SETRX
D ACT
S COMM="Rx# "_$P(^PSRX(PSXRX,0),"^")_" Has Been Suspended for CMOP Until "_PSXLFD_"."
D EN^PSOHLSN1(PSXRX,"SC","ZS",COMM) K COMM
EXIT K PSXRXS,PSXLFD,PSXRXF,PSXFDA,PSXIR,PSXRX,PSXSD,PSXRXDA,PSXRFD,PSX
K PSXEDREL,PSOSITE,PSX525,PSXDFN,PSXFIEN,PSXD,DIC,DIE,Y,X,%,%H,%I,%T,I
Q
SETRX ; Check if last fill has been transmitted (0) or retransmitted (2) -
; edit node and set to not dispensed (3).
; If already dispensed (1) or not dispensed (3), create new entry
; and set to not dispensed (3) with cancelled reason.
S $P(^PSRX(PSXRX,"STA"),"^")=5
K PSX S PSXZ=0
F S PSXZ=$O(^PSRX(PSXRX,4,PSXZ)) Q:'PSXZ D
. S PSXD=$G(^PSRX(PSXRX,4,PSXZ,0))
. S FILL=$P(PSXD,U,3)
. S:FILL'="" PSX($P(PSXD,U,3))=$P(PSXD,U,4)_"^"_PSXZ ; PSX(FILL)=STATUS^IEN
Q:'$D(PSX(PSXRFD)) ;last fill does not have entry in multiple
S PSXST=$P(PSX(PSXRFD),U,1),PSXFIEN=$P(PSX(PSXRFD),U,2)
I PSXST=0!(PSXST=2) D Q
. K DA,DIE,DIC,DR S DIE="^PSRX(DA(1),4,",DA(1)=PSXRX,DA=PSXFIEN
. S DR="3////3;5////"_PSXSD_";8////"_$G(PSXREAS)
. L +^PSRX(DA(1),4,DA):600
. D ^DIE L -^PSRX(DA(1),4,DA) K DIC,DIK,DD,DO
I PSXST=1!(PSXST=3) D
. K DD,DO S X="",DIC="^PSRX("_PSXRX_",4,",DIC(0)="Z"
. S DIC("DR")=".01////"_$P(PSXD,U,1)_";1////"_$P(PSXD,U,2)_";2////"_$P(PSXD,U,3)_";3////3;5////"_PSXSD_";8////"_$G(PSXREAS)
. D FILE^DICN K DIC,DIK,DD,DO
Q
ACT ; adds activity info for CMOP Rx placed on suspense
I '$D(PSXRXF) S PSXRXF=0 F I=0:0 S I=$O(^PSRX(PSXRX,1,I)) Q:'I S PSXRXF=I
S PSXIR=0 F PSXFDA=0:0 S PSXFDA=$O(^PSRX(PSXRX,"A",PSXFDA)) Q:'PSXFDA S PSXIR=PSXFDA
S PSXIR=PSXIR+1,^PSRX(PSXRX,"A",0)="^52.3DA^"_PSXIR_"^"_PSXIR
D NOW^%DTC
I $G(PSXRXF)>5 S PSXRXF=PSXRXF+1
;S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP Disaster Recovery until "_PSXLFD
S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP "_$G(PSXREAS)_" until "_PSXLFD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXNEW 4074 printed Sep 23, 2025@19:20:32 Page 2
PSXNEW ;BIR/HTW/PWC-Rx Order Entry Screen for CMOP ;11 Mar 2002 4:38 PM
+1 ;;2.0;CMOP;**41**;11 Apr 97
+2 ; reference to ^PS(52.5 supported by DBIA #1978
+3 ; reference to ^PSRX supported by DBIA #1977
+4 ; reference to EN^PSOHLSN1 supported by DBIA #2385
+5 ; reference to ^XTMP("ORLK-" supported by DBIA #4001
RESET(PSXRX,PSXFILL,PSXREAS) ;
OERR ;clear ^XTMP("ORLK" if it is CPRS/CMOP
+1 NEW ORD
SET ORD=+$PIECE($GET(^PSRX(+$GET(PSXRX),"OR1")),"^",2)
+2 IF ORD
IF $DATA(^XTMP("ORLK-"_ORD,0))
IF ^XTMP("ORLK-"_ORD,0)["CPRS/CMOP"
KILL ^XTMP("ORLK-"_ORD)
+3 ; Remove and test individual RX's
+4 NEW PSXRFD,PSXEDREL,PSOSITE,PSXSD,PSXLFD,PSXDFN,PSX525,PSXD,PSXZ,PSXRXF,PSXFDA
+5 ; Q:If tradename
+6 if $GET(^PSRX(PSXRX,"TN"))]""
QUIT
+7 ; Q: If Cancelled, Expired, Deleted, Drug Interactions, Hold
+8 if $PIECE(^PSRX(PSXRX,"STA"),"^")>9!($PIECE(^("STA"),"^")=4)!($PIECE(^("STA"),"^")=3)
QUIT
+9 ; Find last fill
+10 SET PSXRFD=+$ORDER(^PSRX(PSXRX,1,"A"),-1)
+11 SET PSXEDREL=$SELECT(PSXRFD=0:$PIECE($GET(^PSRX(PSXRX,2)),"^",13),1:$PIECE($GET(^PSRX(PSXRX,1,PSXRFD,0)),"^",18))
+12 IF PSXEDREL
KILL DA,DIE,DR
Begin DoDot:1
+13 IF PSXRFD=0
SET DA=PSXRX
LOCK +^PSRX(DA):600
SET DIE="^PSRX("
SET DR="31///@"
DO ^DIE
LOCK -^PSRX(DA)
+14 IF PSXRFD>0
SET DA=PSXRFD
SET DA(1)=PSXRX
LOCK +^PSRX(DA(1),1,DA):600
SET DIE="^PSRX(DA(1),1,"
SET DR="17///@"
DO ^DIE
LOCK -^PSRX(DA(1),1,DA)
End DoDot:1
SUS ; Auto-Suspend CMOPS
+1 NEW DA,Y
+2 SET DA=PSXRX
+3 ;D NOW^%DTC ; need to reset back to original suspended date
+4 IF PSXRFD=0
SET %=$PIECE(^PSRX(PSXRX,2),"^",2)
+5 IF PSXRFD>0
SET %=$PIECE(^PSRX(PSXRX,1,PSXRFD,0),"^",1)
+6 SET PSXSD=$PIECE(%,".",1)
SET PSXLFD=$EXTRACT(%,4,5)_"-"_$EXTRACT(%,6,7)_"-"_$EXTRACT(%,2,3)
+7 SET PSXRXS=$ORDER(^PS(52.5,"B",PSXRX,0))
+8 IF PSXRXS
SET DA=PSXRXS
SET DIK="^PS(52.5,"
DO ^DIK
SET DA=PSXRX
+9 IF $GET(PSXRFD)>0
SET PSOSITE=$PIECE(^PSRX(PSXRX,1,PSXRFD,0),"^",9)
+10 IF $GET(PSXRFD)=0
SET PSOSITE=$PIECE(^PSRX(PSXRX,2),"^",9)
+11 SET DIC="^PS(52.5,"
SET DIC(0)="Z"
+12 KILL DD,DO
SET X=PSXRX
SET PSXDFN=$PIECE(^PSRX(PSXRX,0),"^",2)
+13 SET DIC("DR")=".02////"_PSXSD_";.03////"_PSXDFN_";.04////M;.05////0;.06////"_PSOSITE_";2////0;3////Q;9////"_PSXRFD
+14 DO FILE^DICN
KILL DIC,DIK,DD,DO
+15 IF +Y>0
SET PSX525=+Y
+16 IF '$TEST
DO EXIT
QUIT
LOCK525 ;
+1 LOCK +^PS(52.5,PSX525):600
if '$TEST
GOTO LOCK525
+2 KILL ^PS(52.5,"AC",PSXDFN,PSXSD,PSX525),PSXDFN
+3 LOCK -^PS(52.5,PSX525)
+4 DO SETRX
+5 DO ACT
+6 SET COMM="Rx# "_$PIECE(^PSRX(PSXRX,0),"^")_" Has Been Suspended for CMOP Until "_PSXLFD_"."
+7 DO EN^PSOHLSN1(PSXRX,"SC","ZS",COMM)
KILL COMM
EXIT KILL PSXRXS,PSXLFD,PSXRXF,PSXFDA,PSXIR,PSXRX,PSXSD,PSXRXDA,PSXRFD,PSX
+1 KILL PSXEDREL,PSOSITE,PSX525,PSXDFN,PSXFIEN,PSXD,DIC,DIE,Y,X,%,%H,%I,%T,I
+2 QUIT
SETRX ; Check if last fill has been transmitted (0) or retransmitted (2) -
+1 ; edit node and set to not dispensed (3).
+2 ; If already dispensed (1) or not dispensed (3), create new entry
+3 ; and set to not dispensed (3) with cancelled reason.
+4 SET $PIECE(^PSRX(PSXRX,"STA"),"^")=5
+5 KILL PSX
SET PSXZ=0
+6 FOR
SET PSXZ=$ORDER(^PSRX(PSXRX,4,PSXZ))
if 'PSXZ
QUIT
Begin DoDot:1
+7 SET PSXD=$GET(^PSRX(PSXRX,4,PSXZ,0))
+8 SET FILL=$PIECE(PSXD,U,3)
+9 ; PSX(FILL)=STATUS^IEN
if FILL'=""
SET PSX($PIECE(PSXD,U,3))=$PIECE(PSXD,U,4)_"^"_PSXZ
End DoDot:1
+10 ;last fill does not have entry in multiple
if '$DATA(PSX(PSXRFD))
QUIT
+11 SET PSXST=$PIECE(PSX(PSXRFD),U,1)
SET PSXFIEN=$PIECE(PSX(PSXRFD),U,2)
+12 IF PSXST=0!(PSXST=2)
Begin DoDot:1
+13 KILL DA,DIE,DIC,DR
SET DIE="^PSRX(DA(1),4,"
SET DA(1)=PSXRX
SET DA=PSXFIEN
+14 SET DR="3////3;5////"_PSXSD_";8////"_$GET(PSXREAS)
+15 LOCK +^PSRX(DA(1),4,DA):600
+16 DO ^DIE
LOCK -^PSRX(DA(1),4,DA)
KILL DIC,DIK,DD,DO
End DoDot:1
QUIT
+17 IF PSXST=1!(PSXST=3)
Begin DoDot:1
+18 KILL DD,DO
SET X=""
SET DIC="^PSRX("_PSXRX_",4,"
SET DIC(0)="Z"
+19 SET DIC("DR")=".01////"_$PIECE(PSXD,U,1)_";1////"_$PIECE(PSXD,U,2)_";2////"_$PIECE(PSXD,U,3)_";3////3;5////"_PSXSD_";8////"_$GET(PSXREAS)
+20 DO FILE^DICN
KILL DIC,DIK,DD,DO
End DoDot:1
+21 QUIT
ACT ; adds activity info for CMOP Rx placed on suspense
+1 IF '$DATA(PSXRXF)
SET PSXRXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(PSXRX,1,I))
if 'I
QUIT
SET PSXRXF=I
+2 SET PSXIR=0
FOR PSXFDA=0:0
SET PSXFDA=$ORDER(^PSRX(PSXRX,"A",PSXFDA))
if 'PSXFDA
QUIT
SET PSXIR=PSXFDA
+3 SET PSXIR=PSXIR+1
SET ^PSRX(PSXRX,"A",0)="^52.3DA^"_PSXIR_"^"_PSXIR
+4 DO NOW^%DTC
+5 IF $GET(PSXRXF)>5
SET PSXRXF=PSXRXF+1
+6 ;S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP Disaster Recovery until "_PSXLFD
+7 SET ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP "_$GET(PSXREAS)_" until "_PSXLFD
+8 QUIT
