PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ;6/28/07 7:35am
;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148,274,347,251,405,440**;DEC 1997;Build 29
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PSDRUG supported by DBIA 3165
;External reference to ^PSSHUIDG supported by DBIA 3621
;External reference to $$DS^PSSDSAPI supported by DBIA 5424
TOP ;
I $G(PSOFROM)="EDIT" S PPL=$G(PSORX("PSOL",1)) Q:$G(PPL)']"" G TEST
I $G(PPL) G START
I '$G(RXLTOP) S PPL=$G(DA) G TEST
S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
START ; Establish CMOP PPL
TEST N ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN
N RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX
S (P1,P2)=1,FLAG=0
LOOP F CNT=1:1 S RX=$P($G(PPL),",",CNT) Q:RX']"" D S:'FLAG $P(RX("PSO"),",",P1)=RX,P1=P1+1 S FLAG=0
.; PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date
.N DFN ;*347
.S DFN=$P(^PSRX(RX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) K DFN ;*347
.I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) K PSOMC,PSOMDT Q ;*347
.; Get drug IEN and check if CMOP
.S CK=$P($G(^PSRX(RX,0)),"^",6) Q:'$D(^PSDRUG("AQ",CK))
.; If not marked for O.P., unmark for CMOP...
.I $P($G(^PSDRUG(CK,2)),"^",3)'["O" D UNMARK^PSOCMOP Q
.; Check Drug Warning >11
.N WARNS,COMM S WARNS=$P(^PSDRUG(CK,0),U,8) I $L(WARNS)>11 D Q
.. S COMM(1)="Rx# "_$P(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters."
.. S COMM(2)="Drug Name: "_$P(^PSDRUG(CK,0),U)_" (IEN: # "_CK_")"
.. D COMM(RX,.COMM)
.; Q:If partial or pull early
.Q:$G(RXPR(RX))!($G(RXRS(RX)))
.; Q:If standard reprint but allow edit reprint
.I $G(RXRP(RX))&($P($G(RXRP(RX)),"^",4)'=1) Q
.; Q:If tradename
.Q:$G(^PSRX(RX,"TN"))]""
.; Q: If Cancelled, Expired, Deleted, Hold
.Q:$P(^PSRX(RX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3)
.; Find last fill
.S RFD=0 F X7=0:0 S X7=$O(^PSRX(RX,1,X7)) Q:'$G(X7) S (RFD)=X7
.;if original fill and a tech stop
.I 'RFD,$P(^PSRX(RX,"STA"),"^")=4!($D(^PSRX(RX,"DRI"))&('$D(^XUSEC("PSORPH",DUZ)))) Q
.I 'RFD,$$DS^PSSDSAPI,($G(^PS(52.4,RX,1))>0)&('$D(^XUSEC("PSORPH",DUZ))) Q
.Q:$G(RXFL(RX))&(RFD)&($G(RXFL(RX))'=RFD)
.I '$O(^PSRX(RX,1,0)),'$P($G(^PSRX(RX,2)),"^",13),$P($G(^(0)),"^",11)="W",$S($P($G(^PSRX(RX,2)),"^",2):$P($G(^(2)),"^",2),1:+$G(PSOX("FILL DATE")))>DT D
..S PSOCPDA=$G(DA) K DIE S DA=RX,DIE="^PSRX(",DR="11////M" D ^DIE K DIE S:$G(PSOCPDA) DA=$G(PSOCPDA) K PSOCPDA
.; Q:If not "Mail"
.S MW=$S($G(RFD)>0:$P(^PSRX(RX,1,RFD,0),"^",2),1:$P(^PSRX(RX,0),"^",11)) K X7 I $G(MW)="W" K RFD Q
.;
.; Q:If fill was CMOPed and other than a '3' 'not dispensed'
.Q:'$$FILTRAN(RX,RFD)
.;
.; Check if released, for use in Sus
.S REL=$S(RFD=0:$P($G(^PSRX(RX,2)),"^",13),1:$P($G(^PSRX(RX,1,RFD,0)),"^",18)) K RFD
.I $G(REL) Q
.Q:($G(XFROM)="UNHOLD")
.; Save CMOP's in PSXPPL1
.S $P(RX("CMOP"),",",P2)=RX,P2=P2+1,FLAG=1 Q
K PPL S PPL=$G(RX("PSO")),RX1("CMOP")=$G(RX("CMOP")) K RX("PSO")
G:$G(XFROM)="EDIT" D1 ; passed from PSXEDIT
RESET ;
G:'$G(RX("CMOP")) D1
I $G(XFROM)="REINSTATE"!($G(XFROM)="UNHOLD") Q
I $G(PSOFROM)="EDIT",($G(REL)]"") S PPL=RX("CMOP") G D1
S ; Auto-Suspend CMOPS
N DA,Y
F PI=1:1 S DA=$P($G(RX("CMOP")),",",PI) Q:'DA D SUS
S SUSPT="SUSPENSE"
G D1
SUS ;
I $G(XFROM)="REINSTATE" W !,RX_" REINSTATED -- "
S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS D Q:$G(DFLG)
.S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
K X7 S RFD1=0 F X7=0:0 S X7=$O(^PSRX(DA,1,X7)) Q:'$G(X7) S (RFD1)=X7
LOCK N PSORXSIT S PSORXSIT=$P(^PSRX(DA,2),U,9)
S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="",X=RXN
S DIC("DR")=".02////"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_$S(PSORXSIT:PSORXSIT,1:PSOSITE)_";2////0;3////Q;9////"_RFD1 ;;PSO*440
K DD,DO D FILE^DICN K DD,DO S DA=RXN I +Y S PSONAME=$P(^PSRX(DA,0),"^",2) K ^PS(52.5,"AC",PSONAME,SD,+Y),PSONAME
S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
W !!,"RX# ",$P(^PSRX(RXN,0),"^")_" SUSPENDED for CMOP Until "_LFD_"."
S VALMSG="Rx# "_$P(^PSRX(RXN,0),"^")_" Suspended for CMOP Until "_LFD_"."
S COMM="Rx# "_$P(^PSRX(RXN,0),"^")_" Suspended for CMOP Until "_LFD_"."
D EN^PSOHLSN1(RXN,"SC","ZS",COMM) K COMM
;- Calling ECME to reverse any PAYABLE claim for the prescription/fill
D REVERSE^PSOBPSU1(RXN,,"DC",3)
Q
ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA
S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD
K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
Q
D1 K CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7
K PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1
Q
RXL N FROM S FROM=$G(PSOFROM)
I ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($G(XFROM)="HOLD")!($G(XFROM)="BATCH")) G TOP
Q
SUS1 ;
N PPL
S PPL=DA D TEST
I $G(PPL)']"" S XFLAG=1
S RX("CMOP")=$G(RX1("CMOP"))
Q
A S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
G TEST
UNMARK ;Entry point to unmark drug for CMOP dispense
N X,Z,%
S $P(^PSDRUG(CK,3),"^",1)=0 K ^PSDRUG("AQ",CK)
S:'$D(^PSDRUG(CK,4,0)) ^PSDRUG(CK,4,0)="^50.0214DA^^"
S (X,Z)=0 F S Z=$O(^PSDRUG(CK,4,Z)) Q:'Z S X=Z
S X=X+1 D NOW^%DTC S ^PSDRUG(CK,4,X,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$S($G(^PSDRUG(CK,3))=1:"YES",$G(^PSDRUG(CK,3))=0:"NO",1:"")
S $P(^PSDRUG(CK,4,0),"^",3)=X,$P(^(0),"^",4)=$P(^(0),"^",4)+1
I $$PATCH^XPDUTL("PSS*1.0*70") D DRG^PSSHUIDG(CK)
K X,Z,%
Q
FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send
N DA,CMOP
S DA=RX
D ^PSOCMOPA
I '$D(CMOP(RFD)) Q 1
I CMOP(RFD)=3 Q 1
Q 0
COMM(RXN,COMM) ;EP process problem message to g.cmop managers
N XMSUB,XMTEXT
S XMTEXT="COMM(",XMY("I:G.CMOP MANAGERS")=""
S XMSUB="CMOP RX PROBLEM ENCOUNTERED"
D ^XMD
Q
CMPRXTYP(SUSDA) ; given suspense record SUSDA returns RX CMOP TYPE C - CS, N -Non-CS
;used in compound index ^PS(52.5,"CMP",STAT,TYP,DIV,DATE,DFN,DA)
N RXDA,DRGDA,DEA,TYP
S RXDA=$P(^PS(52.5,SUSDA,0),U),DRGDA=$P(^PSRX(RXDA,0),U,6)
S TYP="N",DEA=$P(^PSDRUG(DRGDA,0),U,3) F I=3,4,5 I DEA[I S TYP="C"
Q TYP
NOW() D NOW^%DTC Q %
;
PIECE(REC,DLM,VP) ; VP="Variable^Piece"
; Set Variable V = piece P of REC using delimiter DLM
N V,P S V=$P(VP,U),P=$P(VP,U,2),@V=$P(REC,DLM,P)
Q
PUT(REC,DLM,VP) ; VP="Variable^Piece"
; pass by reference D PUT^PSOCMOP(.REC,DLM,VP)
; Set Variable V into piece P of REC using delimiter DLM
N V,P S V=$P(VP,U),P=$P(VP,U,2)
S $P(REC,DLM,P)=$G(@V)
Q
KCMPX(SUS,VAL) ; Kill ^PS(52.5,"CMP",VAL index given SUS
N SDT,TYP,DFN,DIV,RX,F,XX
S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS)
F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
K ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)
Q
SCMPX(SUS,VAL) ; Set ^PS(52.5,"CMP",VAL index given SUS
N SDT,TYP,DFN,DIV,RX,F,XX
S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS)
F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
S ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCMOP 7473 printed Apr 09, 2024@21:27:22 Page 2
PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ;6/28/07 7:35am
+1 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148,274,347,251,405,440**;DEC 1997;Build 29
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External reference to ^PSDRUG supported by DBIA 3165
+5 ;External reference to ^PSSHUIDG supported by DBIA 3621
+6 ;External reference to $$DS^PSSDSAPI supported by DBIA 5424
TOP ;
+1 IF $GET(PSOFROM)="EDIT"
SET PPL=$GET(PSORX("PSOL",1))
if $GET(PPL)']""
QUIT
GOTO TEST
+2 IF $GET(PPL)
GOTO START
+3 IF '$GET(RXLTOP)
SET PPL=$GET(DA)
GOTO TEST
+4 if '$GET(PPL)
SET PPL=$GET(PSORX("PSOL",1))
if $GET(PPL)']""
GOTO D1
START ; Establish CMOP PPL
TEST NEW ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN
+1 NEW RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX
+2 SET (P1,P2)=1
SET FLAG=0
LOOP FOR CNT=1:1
SET RX=$PIECE($GET(PPL),",",CNT)
if RX']""
QUIT
Begin DoDot:1
+1 ; PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date
+2 ;*347
NEW DFN
+3 ;*347
SET DFN=$PIECE(^PSRX(RX,0),"^",2)
SET PSOMDT=$PIECE($GET(^PS(55,DFN,0)),"^",5)
SET PSOMC=$PIECE($GET(^PS(55,DFN,0)),"^",3)
KILL DFN
+4 ;*347
IF (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1))
KILL PSOMC,PSOMDT
QUIT
+5 ; Get drug IEN and check if CMOP
+6 SET CK=$PIECE($GET(^PSRX(RX,0)),"^",6)
if '$DATA(^PSDRUG("AQ",CK))
QUIT
+7 ; If not marked for O.P., unmark for CMOP...
+8 IF $PIECE($GET(^PSDRUG(CK,2)),"^",3)'["O"
DO UNMARK^PSOCMOP
QUIT
+9 ; Check Drug Warning >11
+10 NEW WARNS,COMM
SET WARNS=$PIECE(^PSDRUG(CK,0),U,8)
IF $LENGTH(WARNS)>11
Begin DoDot:2
+11 SET COMM(1)="Rx# "_$PIECE(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters."
+12 SET COMM(2)="Drug Name: "_$PIECE(^PSDRUG(CK,0),U)_" (IEN: # "_CK_")"
+13 DO COMM(RX,.COMM)
End DoDot:2
QUIT
+14 ; Q:If partial or pull early
+15 if $GET(RXPR(RX))!($GET(RXRS(RX)))
QUIT
+16 ; Q:If standard reprint but allow edit reprint
+17 IF $GET(RXRP(RX))&($PIECE($GET(RXRP(RX)),"^",4)'=1)
QUIT
+18 ; Q:If tradename
+19 if $GET(^PSRX(RX,"TN"))]""
QUIT
+20 ; Q: If Cancelled, Expired, Deleted, Hold
+21 if $PIECE(^PSRX(RX,"STA"),"^")>9!($PIECE(^("STA"),"^")=4)!($PIECE(^("STA"),"^")=3)
QUIT
+22 ; Find last fill
+23 SET RFD=0
FOR X7=0:0
SET X7=$ORDER(^PSRX(RX,1,X7))
if '$GET(X7)
QUIT
SET (RFD)=X7
+24 ;if original fill and a tech stop
+25 IF 'RFD
IF $PIECE(^PSRX(RX,"STA"),"^")=4!($DATA(^PSRX(RX,"DRI"))&('$DATA(^XUSEC("PSORPH",DUZ))))
QUIT
+26 IF 'RFD
IF $$DS^PSSDSAPI
IF ($GET(^PS(52.4,RX,1))>0)&('$DATA(^XUSEC("PSORPH",DUZ)))
QUIT
+27 if $GET(RXFL(RX))&(RFD)&($GET(RXFL(RX))'=RFD)
QUIT
+28 IF '$ORDER(^PSRX(RX,1,0))
IF '$PIECE($GET(^PSRX(RX,2)),"^",13)
IF $PIECE($GET(^(0)),"^",11)="W"
IF $SELECT($PIECE($GET(^PSRX(RX,2)),"^",2):$PIECE($GET(^(2)),"^",2),1:+$GET(PSOX("FILL DATE")))>DT
Begin DoDot:2
+29 SET PSOCPDA=$GET(DA)
KILL DIE
SET DA=RX
SET DIE="^PSRX("
SET DR="11////M"
DO ^DIE
KILL DIE
if $GET(PSOCPDA)
SET DA=$GET(PSOCPDA)
KILL PSOCPDA
End DoDot:2
+30 ; Q:If not "Mail"
+31 SET MW=$SELECT($GET(RFD)>0:$PIECE(^PSRX(RX,1,RFD,0),"^",2),1:$PIECE(^PSRX(RX,0),"^",11))
KILL X7
IF $GET(MW)="W"
KILL RFD
QUIT
+32 ;
+33 ; Q:If fill was CMOPed and other than a '3' 'not dispensed'
+34 if '$$FILTRAN(RX,RFD)
QUIT
+35 ;
+36 ; Check if released, for use in Sus
+37 SET REL=$SELECT(RFD=0:$PIECE($GET(^PSRX(RX,2)),"^",13),1:$PIECE($GET(^PSRX(RX,1,RFD,0)),"^",18))
KILL RFD
+38 IF $GET(REL)
QUIT
+39 if ($GET(XFROM)="UNHOLD")
QUIT
+40 ; Save CMOP's in PSXPPL1
+41 SET $PIECE(RX("CMOP"),",",P2)=RX
SET P2=P2+1
SET FLAG=1
QUIT
End DoDot:1
if 'FLAG
SET $PIECE(RX("PSO"),",",P1)=RX
SET P1=P1+1
SET FLAG=0
+42 KILL PPL
SET PPL=$GET(RX("PSO"))
SET RX1("CMOP")=$GET(RX("CMOP"))
KILL RX("PSO")
+43 ; passed from PSXEDIT
if $GET(XFROM)="EDIT"
GOTO D1
RESET ;
+1 if '$GET(RX("CMOP"))
GOTO D1
+2 IF $GET(XFROM)="REINSTATE"!($GET(XFROM)="UNHOLD")
QUIT
+3 IF $GET(PSOFROM)="EDIT"
IF ($GET(REL)]"")
SET PPL=RX("CMOP")
GOTO D1
S ; Auto-Suspend CMOPS
+1 NEW DA,Y
+2 FOR PI=1:1
SET DA=$PIECE($GET(RX("CMOP")),",",PI)
if 'DA
QUIT
DO SUS
+3 SET SUSPT="SUSPENSE"
+4 GOTO D1
SUS ;
+1 IF $GET(XFROM)="REINSTATE"
WRITE !,RX_" REINSTATED -- "
+2 SET ACT=1
SET RXN=DA
SET RX0=^PSRX(DA,0)
SET SD=$SELECT($GET(ZD(DA)):$EXTRACT(ZD(DA),1,7),1:$PIECE(^(3),"^"))
SET RXS=$ORDER(^PS(52.5,"B",DA,0))
IF RXS
Begin DoDot:1
+3 SET DA=RXS
SET DIK="^PS(52.5,"
DO ^DIK
SET DA=RXN
End DoDot:1
if $GET(DFLG)
QUIT
+4 KILL X7
SET RFD1=0
FOR X7=0:0
SET X7=$ORDER(^PSRX(DA,1,X7))
if '$GET(X7)
QUIT
SET (RFD1)=X7
LOCK NEW PSORXSIT
SET PSORXSIT=$PIECE(^PSRX(DA,2),U,9)
+1 SET RXP=+$GET(RXPR(DA))
SET DIC="^PS(52.5,"
SET DIC(0)=""
SET X=RXN
+2 ;;PSO*440
SET DIC("DR")=".02////"_SD_";.03////"_$PIECE(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_$SELECT(PSORXSIT:PSORXSIT,1:PSOSITE)_";2////0;3////Q;9////"_RFD1
+3 KILL DD,DO
DO FILE^DICN
KILL DD,DO
SET DA=RXN
IF +Y
SET PSONAME=$PIECE(^PSRX(DA,0),"^",2)
KILL ^PS(52.5,"AC",PSONAME,SD,+Y),PSONAME
+4 SET $PIECE(^PSRX(RXN,"STA"),"^")=5
SET LFD=$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)
DO ACT
+5 WRITE !!,"RX# ",$PIECE(^PSRX(RXN,0),"^")_" SUSPENDED for CMOP Until "_LFD_"."
+6 SET VALMSG="Rx# "_$PIECE(^PSRX(RXN,0),"^")_" Suspended for CMOP Until "_LFD_"."
+7 SET COMM="Rx# "_$PIECE(^PSRX(RXN,0),"^")_" Suspended for CMOP Until "_LFD_"."
+8 DO EN^PSOHLSN1(RXN,"SC","ZS",COMM)
KILL COMM
+9 ;- Calling ECME to reverse any PAYABLE claim for the prescription/fill
+10 DO REVERSE^PSOBPSU1(RXN,,"DC",3)
+11 QUIT
ACT SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET RXF=I
if I>5
SET RXF=I+1
+1 SET IR=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(DA,"A",FDA))
if 'FDA
QUIT
SET IR=FDA
+2 SET IR=IR+1
SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
+3 DO NOW^%DTC
SET ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD
+4 KILL RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
+5 QUIT
D1 KILL CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7
+1 KILL PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1
+2 QUIT
RXL NEW FROM
SET FROM=$GET(PSOFROM)
+1 IF ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($GET(XFROM)="HOLD")!($GET(XFROM)="BATCH"))
GOTO TOP
+2 QUIT
SUS1 ;
+1 NEW PPL
+2 SET PPL=DA
DO TEST
+3 IF $GET(PPL)']""
SET XFLAG=1
+4 SET RX("CMOP")=$GET(RX1("CMOP"))
+5 QUIT
A if '$GET(PPL)
SET PPL=$GET(PSORX("PSOL",PPL1))
if $GET(PPL)']""
GOTO D1
+1 GOTO TEST
UNMARK ;Entry point to unmark drug for CMOP dispense
+1 NEW X,Z,%
+2 SET $PIECE(^PSDRUG(CK,3),"^",1)=0
KILL ^PSDRUG("AQ",CK)
+3 if '$DATA(^PSDRUG(CK,4,0))
SET ^PSDRUG(CK,4,0)="^50.0214DA^^"
+4 SET (X,Z)=0
FOR
SET Z=$ORDER(^PSDRUG(CK,4,Z))
if 'Z
QUIT
SET X=Z
+5 SET X=X+1
DO NOW^%DTC
SET ^PSDRUG(CK,4,X,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$SELECT($GET(^PSDRUG(CK,3))=1:"YES",$GET(^PSDRUG(CK,3))=0:"NO",1:"")
+6 SET $PIECE(^PSDRUG(CK,4,0),"^",3)=X
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
+7 IF $$PATCH^XPDUTL("PSS*1.0*70")
DO DRG^PSSHUIDG(CK)
+8 KILL X,Z,%
+9 QUIT
FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send
+1 NEW DA,CMOP
+2 SET DA=RX
+3 DO ^PSOCMOPA
+4 IF '$DATA(CMOP(RFD))
QUIT 1
+5 IF CMOP(RFD)=3
QUIT 1
+6 QUIT 0
COMM(RXN,COMM) ;EP process problem message to g.cmop managers
+1 NEW XMSUB,XMTEXT
+2 SET XMTEXT="COMM("
SET XMY("I:G.CMOP MANAGERS")=""
+3 SET XMSUB="CMOP RX PROBLEM ENCOUNTERED"
+4 DO ^XMD
+5 QUIT
CMPRXTYP(SUSDA) ; given suspense record SUSDA returns RX CMOP TYPE C - CS, N -Non-CS
+1 ;used in compound index ^PS(52.5,"CMP",STAT,TYP,DIV,DATE,DFN,DA)
+2 NEW RXDA,DRGDA,DEA,TYP
+3 SET RXDA=$PIECE(^PS(52.5,SUSDA,0),U)
SET DRGDA=$PIECE(^PSRX(RXDA,0),U,6)
+4 SET TYP="N"
SET DEA=$PIECE(^PSDRUG(DRGDA,0),U,3)
FOR I=3,4,5
IF DEA[I
SET TYP="C"
+5 QUIT TYP
NOW() DO NOW^%DTC
QUIT %
+1 ;
PIECE(REC,DLM,VP) ; VP="Variable^Piece"
+1 ; Set Variable V = piece P of REC using delimiter DLM
+2 NEW V,P
SET V=$PIECE(VP,U)
SET P=$PIECE(VP,U,2)
SET @V=$PIECE(REC,DLM,P)
+3 QUIT
PUT(REC,DLM,VP) ; VP="Variable^Piece"
+1 ; pass by reference D PUT^PSOCMOP(.REC,DLM,VP)
+2 ; Set Variable V into piece P of REC using delimiter DLM
+3 NEW V,P
SET V=$PIECE(VP,U)
SET P=$PIECE(VP,U,2)
+4 SET $PIECE(REC,DLM,P)=$GET(@V)
+5 QUIT
KCMPX(SUS,VAL) ; Kill ^PS(52.5,"CMP",VAL index given SUS
+1 NEW SDT,TYP,DFN,DIV,RX,F,XX
+2 SET F=$GET(^PS(52.5,SUS,0))
if '+F
QUIT
SET TYP=$$CMPRXTYP(SUS)
+3 FOR XX="RX^1","SDT^2","DFN^3","DIV^6"
DO PIECE(F,U,XX)
+4 KILL ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)
+5 QUIT
SCMPX(SUS,VAL) ; Set ^PS(52.5,"CMP",VAL index given SUS
+1 NEW SDT,TYP,DFN,DIV,RX,F,XX
+2 SET F=$GET(^PS(52.5,SUS,0))
if '+F
QUIT
SET TYP=$$CMPRXTYP(SUS)
+3 FOR XX="RX^1","SDT^2","DFN^3","DIV^6"
DO PIECE(F,U,XX)
+4 SET ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)=""
+5 QUIT
