PSOCMOPC ;BIR/HTW-Utility for CMOP/OP Edit ;8/30/96
;;7.0;OUTPATIENT PHARMACY;**2,30,43,547**;DEC 1997;Build 1
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSDRUG supported by DBIA 221
EN(XDA) N A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,DA
;
S DA=XDA
D ^PSOCMOPA
; Q:If not in suspense file, set status to 0 - active
I '$G(CMOP("52.5")) D Q
. S:+$P($G(PSOLST(ORN)),"^",2) ^PSRX($P(PSOLST(ORN),"^",2),"STA")=0
;
D CHECK
I $G(CMOP("S"))']"",($G(CMOP)) D ACT D G QUIT
.K ^PS(52.5,"AC",$P(^PSRX(XDA,0),"^",2),$P(^PS(52.5,CMOP("52.5"),0),"^",2),CMOP("52.5"))
.S DIE="^PS(52.5,",DR="3////Q",DA=CMOP("52.5") D ^DIE K DIE
.S T=$P(^PSRX(XDA,3),"^")
.S T1=$E(T,4,5)_"-"_$E(T,6,7)_"-"_$E(T,2,3)
.S $P(^PSRX(XDA,"A",0),"^",3)=A,$P(^PSRX(XDA,"A",0),"^",4)=A1
.D NOW^%DTC
.S ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$S($G(CMOP("L"))<6:$G(CMOP("L")),1:$G(CMOP("L"))+1)_"^ Placed on Suspense for CMOP until "_T1
.K T,T1,%
UNSUS ; If Rx is suspended and is not CMOP, ensure is not suspended as CMOP (Exception of a Partial Fill done after the CMOP Suspense)
I $G(CMOP("S"))["Q",('$G(CMOP)),'$G(RXPR(XDA)),$G(PSOFROM)'="PARTIAL" D G QUIT
.S DIE="^PS(52.5,",DR="3////@",DA=CMOP("52.5") D ^DIE K DIE,DR
.S ^PS(52.5,"AC",$P(^PSRX(XDA,0),"^",2),$P(^PS(52.5,DA,0),"^",2),DA)=""
.D ACT
.S T=$P(^PSRX(XDA,3),"^")
.S T1=$E(T,4,5)_"-"_$E(T,6,7)_"-"_$E(T,2,3)
.S $P(^PSRX(XDA,"A",0),"^",3)=A,$P(^PSRX(XDA,"A",0),"^",4)=A1
.D NOW^%DTC
.S ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$S($G(CMOP("L"))<6:$G(CMOP("L")),1:$G(CMOP("L"))+1)_"^ Removed from CMOP Suspense, returned to OP Suspense. "_T1
.S DA=XDA
QUIT K A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,XDA Q
ACT ; If no act node, make one .... determine last entry
S:'$D(^PSRX(XDA,"A",0)) ^(0)="^52.3XDA^^"
S PSOA="" F S PSOA=$O(^PSRX(XDA,"A",PSOA)) Q:PSOA']"" S PSOB=PSOA+1
S A=$P(^PSRX(XDA,"A",0),"^",3),A1=$P(^PSRX(XDA,"A",0),"^",4),A=A+1,A1=A1+1
K PSOA
Q
CHECK S CMOP=0 Q:'$G(PSXSYS)
; Q:Partial or Reprint
S PSOCMSUS=$O(^PS(52.5,"B",XDA,0))
I $G(PSOCMSUS) I $P($G(^PS(52.5,PSOCMSUS,0)),"^",5)!($P($G(^(0)),"^",12)) K PSOCMSUS Q
K PSOCMSUS
; Q:Do not Mail
S PSOCMPAT=+$P($G(^PSRX(XDA,0)),"^",2),PSOCMDT=$P($G(^PS(55,PSOCMPAT,0)),"^",5),PSOCMMAI=$P($G(^PS(55,PSOCMPAT,0)),"^",3)
I $G(PSOCMMAI)>1,$S($G(PSOCMDT)=""!($G(PSOCMDT)>DT):1,1:0) D KMAIL Q
D KMAIL
; Get drug IEN and check if CMOP
S PSOCK=$P($G(^PSRX(XDA,0)),"^",6) Q:'$D(^PSDRUG("AQ",PSOCK))
I $P($G(^PSDRUG(+$G(PSOCK),2)),"^",3)'["O" Q
Q:$G(PSOFROM)="PARTIAL"
; Q:If tradename
Q:$G(^PSRX(XDA,"TN"))]""
; Q: If Cancelled, Expired, Deleted
Q:$P($G(^PSRX(XDA,"STA")),"^")>10
; Q: If pending
Q:$P($G(^PSRX(XDA,"STA")),"^")=4
; Q:If not "Mail"
S PSOMW=$S($G(CMOP("L"))>0:$P(^PSRX(XDA,1,CMOP("L"),0),"^",2),1:$P(^PSRX(XDA,0),"^",11)) I $G(PSOMW)="W" K CMOP("L") Q
; Q:If fill was CMOPed and other than '3' 'not dispensed'
Q:'$$FILTRAN^PSOCMOP(XDA,CMOP("L"))
S CMOP=1
Q
KMAIL K PSOCMPAT,PSOCMDT,PSOCMMAI Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCMOPC 3113 printed Apr 09, 2024@21:29:50 Page 2
PSOCMOPC ;BIR/HTW-Utility for CMOP/OP Edit ;8/30/96
+1 ;;7.0;OUTPATIENT PHARMACY;**2,30,43,547**;DEC 1997;Build 1
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to ^PSDRUG supported by DBIA 221
EN(XDA) NEW A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,DA
+1 ;
+2 SET DA=XDA
+3 DO ^PSOCMOPA
+4 ; Q:If not in suspense file, set status to 0 - active
+5 IF '$GET(CMOP("52.5"))
Begin DoDot:1
+6 if +$PIECE($GET(PSOLST(ORN)),"^",2)
SET ^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")=0
End DoDot:1
QUIT
+7 ;
+8 DO CHECK
+9 IF $GET(CMOP("S"))']""
IF ($GET(CMOP))
DO ACT
Begin DoDot:1
+10 KILL ^PS(52.5,"AC",$PIECE(^PSRX(XDA,0),"^",2),$PIECE(^PS(52.5,CMOP("52.5"),0),"^",2),CMOP("52.5"))
+11 SET DIE="^PS(52.5,"
SET DR="3////Q"
SET DA=CMOP("52.5")
DO ^DIE
KILL DIE
+12 SET T=$PIECE(^PSRX(XDA,3),"^")
+13 SET T1=$EXTRACT(T,4,5)_"-"_$EXTRACT(T,6,7)_"-"_$EXTRACT(T,2,3)
+14 SET $PIECE(^PSRX(XDA,"A",0),"^",3)=A
SET $PIECE(^PSRX(XDA,"A",0),"^",4)=A1
+15 DO NOW^%DTC
+16 SET ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$SELECT($GET(CMOP("L"))<6:$GET(CMOP("L")),1:$GET(CMOP("L"))+1)_"^ Placed on Suspense for CMOP until "_T1
+17 KILL T,T1,%
End DoDot:1
GOTO QUIT
UNSUS ; If Rx is suspended and is not CMOP, ensure is not suspended as CMOP (Exception of a Partial Fill done after the CMOP Suspense)
+1 IF $GET(CMOP("S"))["Q"
IF ('$GET(CMOP))
IF '$GET(RXPR(XDA))
IF $GET(PSOFROM)'="PARTIAL"
Begin DoDot:1
+2 SET DIE="^PS(52.5,"
SET DR="3////@"
SET DA=CMOP("52.5")
DO ^DIE
KILL DIE,DR
+3 SET ^PS(52.5,"AC",$PIECE(^PSRX(XDA,0),"^",2),$PIECE(^PS(52.5,DA,0),"^",2),DA)=""
+4 DO ACT
+5 SET T=$PIECE(^PSRX(XDA,3),"^")
+6 SET T1=$EXTRACT(T,4,5)_"-"_$EXTRACT(T,6,7)_"-"_$EXTRACT(T,2,3)
+7 SET $PIECE(^PSRX(XDA,"A",0),"^",3)=A
SET $PIECE(^PSRX(XDA,"A",0),"^",4)=A1
+8 DO NOW^%DTC
+9 SET ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$SELECT($GET(CMOP("L"))<6:$GET(CMOP("L")),1:$GET(CMOP("L"))+1)_"^ Removed from CMOP Suspense, returned to OP Suspense. "_T1
+10 SET DA=XDA
End DoDot:1
GOTO QUIT
QUIT KILL A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,XDA
QUIT
ACT ; If no act node, make one .... determine last entry
+1 if '$DATA(^PSRX(XDA,"A",0))
SET ^(0)="^52.3XDA^^"
+2 SET PSOA=""
FOR
SET PSOA=$ORDER(^PSRX(XDA,"A",PSOA))
if PSOA']""
QUIT
SET PSOB=PSOA+1
+3 SET A=$PIECE(^PSRX(XDA,"A",0),"^",3)
SET A1=$PIECE(^PSRX(XDA,"A",0),"^",4)
SET A=A+1
SET A1=A1+1
+4 KILL PSOA
+5 QUIT
CHECK SET CMOP=0
if '$GET(PSXSYS)
QUIT
+1 ; Q:Partial or Reprint
+2 SET PSOCMSUS=$ORDER(^PS(52.5,"B",XDA,0))
+3 IF $GET(PSOCMSUS)
IF $PIECE($GET(^PS(52.5,PSOCMSUS,0)),"^",5)!($PIECE($GET(^(0)),"^",12))
KILL PSOCMSUS
QUIT
+4 KILL PSOCMSUS
+5 ; Q:Do not Mail
+6 SET PSOCMPAT=+$PIECE($GET(^PSRX(XDA,0)),"^",2)
SET PSOCMDT=$PIECE($GET(^PS(55,PSOCMPAT,0)),"^",5)
SET PSOCMMAI=$PIECE($GET(^PS(55,PSOCMPAT,0)),"^",3)
+7 IF $GET(PSOCMMAI)>1
IF $SELECT($GET(PSOCMDT)=""!($GET(PSOCMDT)>DT):1,1:0)
DO KMAIL
QUIT
+8 DO KMAIL
+9 ; Get drug IEN and check if CMOP
+10 SET PSOCK=$PIECE($GET(^PSRX(XDA,0)),"^",6)
if '$DATA(^PSDRUG("AQ",PSOCK))
QUIT
+11 IF $PIECE($GET(^PSDRUG(+$GET(PSOCK),2)),"^",3)'["O"
QUIT
+12 if $GET(PSOFROM)="PARTIAL"
QUIT
+13 ; Q:If tradename
+14 if $GET(^PSRX(XDA,"TN"))]""
QUIT
+15 ; Q: If Cancelled, Expired, Deleted
+16 if $PIECE($GET(^PSRX(XDA,"STA")),"^")>10
QUIT
+17 ; Q: If pending
+18 if $PIECE($GET(^PSRX(XDA,"STA")),"^")=4
QUIT
+19 ; Q:If not "Mail"
+20 SET PSOMW=$SELECT($GET(CMOP("L"))>0:$PIECE(^PSRX(XDA,1,CMOP("L"),0),"^",2),1:$PIECE(^PSRX(XDA,0),"^",11))
IF $GET(PSOMW)="W"
KILL CMOP("L")
QUIT
+21 ; Q:If fill was CMOPed and other than '3' 'not dispensed'
+22 if '$$FILTRAN^PSOCMOP(XDA,CMOP("L"))
QUIT
+23 SET CMOP=1
+24 QUIT
KMAIL KILL PSOCMPAT,PSOCMDT,PSOCMMAI
QUIT
