PSORESUS ;BIR/EJW - Queue/Requeue an Rx to CMOP ;Jan 04, 2022@07:41:19
;;7.0;OUTPATIENT PHARMACY;**264,462,441,753**;DEC 1997;Build 53
;
;This routine will allow the last unreleased fill of an Rx to be suspended or resuspended to CMOP.
;Examples of when this may be used are if the patient was previously marked as "DO NOT MAIL",
;a drug was recently marked as a CMOP drug, the patient's address was updated to a good address, etc.
;
TOP ;
S SAVEPPL=$G(PPL)
S DIR(0)="FO^1:15",DIR("A")="Enter the Rx # to queue to CMOP"
S DIR("?")="Enter the prescription number you want to suspend for CMOP dispense."
D ^DIR K DIR I $D(DIRUT) G END
S RX=Y K Y
S PSOIEN=$O(^PSRX("B",RX,"")) I $G(PSOIEN)']"" W !,"Rx # "_RX_" not found" D END G TOP
D SENDRX
I $G(PPL)]"" W !!,$P(^PSRX(PSOIEN,0),"^")," cannot be suspended for CMOP. Make sure the last fill has a Mail routing, the drug is marked for CMOP, the last fill has not been released, etc...",!!
D END G TOP
END K CHECK,CT,DIR,DIROUT,DIRUT,PSOIEN,LAST,NODE,PSX,PSXPPL,PPL,RF,RX,X,Y,ZD,%
K PSXSITEA
I $G(SAVEPPL) S PPL=SAVEPPL K SAVEPPL
Q
CM ; ENTRY POINT FOR SPEED QUEUE/REQUEUE TO CMOP
S SAVEPPL=$G(PPL)
N PSOSTA,II
N PSOOELSE,PSOIEN,VALMCNT
I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
OS K DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I '+LST D KILL S VALMBCK="" Q
S PSOOELSE=1 D FULL^VALM1
S PPL="" F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" D
.S ORN=$P(LST,",",ORD),PSOIEN=$P(PSOLST(ORN),"^",2) I $P(PSOLST(ORN),"^",3)'="PENDING" D
..;S PSOSTA=$P($G(^PSRX(PSOIEN,"STA")),"^") I PSOSTA'=0,PSOSTA'=5 W !!,$P(^PSRX(PSOIEN,0),"^")," is not active or suspended" H 2 Q
..N PSOQUIT
..S PSOSTA=$P($G(^PSRX(PSOIEN,"STA")),"^") D Q:PSOQUIT
... S PSOQUIT=1
... I PSOSTA'=0,PSOSTA'=5 W !!,$P(^PSRX(PSOIEN,0),"^")," is not active or suspended" H 2 Q
... I $D(^PSRX(PSOIEN,"PARK")) W !!,$P(^PSRX(PSOIEN,0),"^")," is not active or suspended. Prescription must be unparked to be filled." H 2 Q ;#441 PAPI
... S PSOQUIT=0
..I $P($G(^PSRX(PSOIEN,0)),"^",2) S PPL=$S(PPL:PPL_",",1:"")_PSOIEN
..S VALMBCK="R"
I +PPL S SAVEPPL=PPL F II=1:1 S PSOIEN=$P(SAVEPPL,",",II) Q:PSOIEN="" D
.D SENDRX
.I $G(PPL)]"" W !!,$P(^PSRX(PSOIEN,0),"^")_" cannot be suspended for CMOP. Make sure the last fill has a Mail routing, the drug is marked for CMOP, the last fill has not been released, etc...",! H 2
I '$G(PSOOELSE) S VALMBCK=""
D ^PSOBUILD K SAVEPPL ;PSO*7.0*462
D KILL D KVA^VADPT
Q
;
KILL ; CLEAN UP VARIABLES
K DIC,LST,ORD,ORN,PSOIEN,PNM,PPL,PSZIP,RX,SSNP,VA,VADDR1,VADM,VAEL,VAPA,VASTREET
I $G(SAVEPPL) S PPL=SAVEPPL K SAVEPPL
Q
;
SENDRX ; SET RX INTO SUSPENSE FILE FOR CMOP
N LAST,I,TRX,PSOMC,PSOMDT
S LAST=0 I $D(^PSRX(PSOIEN,1)) S I=0 F S I=$O(^PSRX(PSOIEN,1,I)) Q:'I S LAST=I
I $D(PSOSITE) S PSXSITEA=PSOSITE
S PSOSITE=$S(LAST=0:$P(^PSRX(PSOIEN,2),"^",9),1:$P(^PSRX(PSOIEN,1,LAST,0),"^",9))
D NOW^%DTC
N ZD
S PPL=PSOIEN
S TRX=$P($G(PPL),",",1)
S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) K DFN,TRX
I $$GET1^DIQ(52,PSOIEN,100.2,"I")]"" S PSOMC=$$GET1^DIQ(52,PSOIEN,100.2,"I"),PSOMDT="" ;p753
I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) W !,"Cannot suspend for CMOP. Patient's mail status not a CMOP mail status" H 2 K PPL Q
S ZD(PSOIEN)=% D TEST^PSOCMOP H 2
I $G(PSXSITEA)]"" S PSOSITE=PSXSITEA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORESUS 3592 printed Sep 23, 2025@20:10:18 Page 2
PSORESUS ;BIR/EJW - Queue/Requeue an Rx to CMOP ;Jan 04, 2022@07:41:19
+1 ;;7.0;OUTPATIENT PHARMACY;**264,462,441,753**;DEC 1997;Build 53
+2 ;
+3 ;This routine will allow the last unreleased fill of an Rx to be suspended or resuspended to CMOP.
+4 ;Examples of when this may be used are if the patient was previously marked as "DO NOT MAIL",
+5 ;a drug was recently marked as a CMOP drug, the patient's address was updated to a good address, etc.
+6 ;
TOP ;
+1 SET SAVEPPL=$GET(PPL)
+2 SET DIR(0)="FO^1:15"
SET DIR("A")="Enter the Rx # to queue to CMOP"
+3 SET DIR("?")="Enter the prescription number you want to suspend for CMOP dispense."
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO END
+5 SET RX=Y
KILL Y
+6 SET PSOIEN=$ORDER(^PSRX("B",RX,""))
IF $GET(PSOIEN)']""
WRITE !,"Rx # "_RX_" not found"
DO END
GOTO TOP
+7 DO SENDRX
+8 IF $GET(PPL)]""
WRITE !!,$PIECE(^PSRX(PSOIEN,0),"^")," cannot be suspended for CMOP. Make sure the last fill has a Mail routing, the drug is marked for CMOP, the last fill has not been released, etc...",!!
+9 DO END
GOTO TOP
END KILL CHECK,CT,DIR,DIROUT,DIRUT,PSOIEN,LAST,NODE,PSX,PSXPPL,PPL,RF,RX,X,Y,ZD,%
+1 KILL PSXSITEA
+2 IF $GET(SAVEPPL)
SET PPL=SAVEPPL
KILL SAVEPPL
+3 QUIT
CM ; ENTRY POINT FOR SPEED QUEUE/REQUEUE TO CMOP
+1 SET SAVEPPL=$GET(PPL)
+2 NEW PSOSTA,II
+3 NEW PSOOELSE,PSOIEN,VALMCNT
+4 IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
OS KILL DIR,DUOUT,DIRUT
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
SET LST=Y
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DIR,DIRUT,DTOUT,DUOUT
SET VALMBCK=""
QUIT
+1 KILL DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX
IF '+LST
DO KILL
SET VALMBCK=""
QUIT
+2 SET PSOOELSE=1
DO FULL^VALM1
+3 SET PPL=""
FOR ORD=1:1:$LENGTH(LST,",")
if $PIECE(LST,",",ORD)']""
QUIT
Begin DoDot:1
+4 SET ORN=$PIECE(LST,",",ORD)
SET PSOIEN=$PIECE(PSOLST(ORN),"^",2)
IF $PIECE(PSOLST(ORN),"^",3)'="PENDING"
Begin DoDot:2
+5 ;S PSOSTA=$P($G(^PSRX(PSOIEN,"STA")),"^") I PSOSTA'=0,PSOSTA'=5 W !!,$P(^PSRX(PSOIEN,0),"^")," is not active or suspended" H 2 Q
+6 NEW PSOQUIT
+7 SET PSOSTA=$PIECE($GET(^PSRX(PSOIEN,"STA")),"^")
Begin DoDot:3
+8 SET PSOQUIT=1
+9 IF PSOSTA'=0
IF PSOSTA'=5
WRITE !!,$PIECE(^PSRX(PSOIEN,0),"^")," is not active or suspended"
HANG 2
QUIT
+10 ;#441 PAPI
IF $DATA(^PSRX(PSOIEN,"PARK"))
WRITE !!,$PIECE(^PSRX(PSOIEN,0),"^")," is not active or suspended. Prescription must be unparked to be filled."
HANG 2
QUIT
+11 SET PSOQUIT=0
End DoDot:3
if PSOQUIT
QUIT
+12 IF $PIECE($GET(^PSRX(PSOIEN,0)),"^",2)
SET PPL=$SELECT(PPL:PPL_",",1:"")_PSOIEN
+13 SET VALMBCK="R"
End DoDot:2
End DoDot:1
+14 IF +PPL
SET SAVEPPL=PPL
FOR II=1:1
SET PSOIEN=$PIECE(SAVEPPL,",",II)
if PSOIEN=""
QUIT
Begin DoDot:1
+15 DO SENDRX
+16 IF $GET(PPL)]""
WRITE !!,$PIECE(^PSRX(PSOIEN,0),"^")_" cannot be suspended for CMOP. Make sure the last fill has a Mail routing, the drug is marked for CMOP, the last fill has not been released, etc...",!
HANG 2
End DoDot:1
+17 IF '$GET(PSOOELSE)
SET VALMBCK=""
+18 ;PSO*7.0*462
DO ^PSOBUILD
KILL SAVEPPL
+19 DO KILL
DO KVA^VADPT
+20 QUIT
+21 ;
KILL ; CLEAN UP VARIABLES
+1 KILL DIC,LST,ORD,ORN,PSOIEN,PNM,PPL,PSZIP,RX,SSNP,VA,VADDR1,VADM,VAEL,VAPA,VASTREET
+2 IF $GET(SAVEPPL)
SET PPL=SAVEPPL
KILL SAVEPPL
+3 QUIT
+4 ;
SENDRX ; SET RX INTO SUSPENSE FILE FOR CMOP
+1 NEW LAST,I,TRX,PSOMC,PSOMDT
+2 SET LAST=0
IF $DATA(^PSRX(PSOIEN,1))
SET I=0
FOR
SET I=$ORDER(^PSRX(PSOIEN,1,I))
if 'I
QUIT
SET LAST=I
+3 IF $DATA(PSOSITE)
SET PSXSITEA=PSOSITE
+4 SET PSOSITE=$SELECT(LAST=0:$PIECE(^PSRX(PSOIEN,2),"^",9),1:$PIECE(^PSRX(PSOIEN,1,LAST,0),"^",9))
+5 DO NOW^%DTC
+6 NEW ZD
+7 SET PPL=PSOIEN
+8 SET TRX=$PIECE($GET(PPL),",",1)
+9 SET DFN=$PIECE(^PSRX(TRX,0),"^",2)
SET PSOMDT=$PIECE($GET(^PS(55,DFN,0)),"^",5)
SET PSOMC=$PIECE($GET(^PS(55,DFN,0)),"^",3)
KILL DFN,TRX
+10 ;p753
IF $$GET1^DIQ(52,PSOIEN,100.2,"I")]""
SET PSOMC=$$GET1^DIQ(52,PSOIEN,100.2,"I")
SET PSOMDT=""
+11 IF (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1))
WRITE !,"Cannot suspend for CMOP. Patient's mail status not a CMOP mail status"
HANG 2
KILL PPL
QUIT
+12 SET ZD(PSOIEN)=%
DO TEST^PSOCMOP
HANG 2
+13 IF $GET(PSXSITEA)]""
SET PSOSITE=PSXSITEA
+14 QUIT
+15 ;
