Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOCMOP

PSOCMOP.m

Go to the documentation of this file. 
  1. 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**;DEC 1997;Build 8
  1.  ;External reference to ^PS(55 supported by DBIA 2228
  1.  ;External reference to ^PSDRUG supported by DBIA 221
  1.  ;External reference to ^PSDRUG supported by DBIA 3165
  1.  ;External reference to ^PSSHUIDG supported by DBIA 3621
  1. TOP ;
  1.  I $G(PSOFROM)="EDIT" S PPL=$G(PSORX("PSOL",1)) Q:$G(PPL)']""  G TEST
  1.  I $G(PPL) G START
  1.  I '$G(RXLTOP) S PPL=$G(DA) G TEST
  1.  S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
  1. START ;          Establish CMOP PPL
  1. TEST N ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN
  1.  N RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX
  1.  S (P1,P2)=1,FLAG=0
  1.  ;   PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date
  1.  S TRX=$P($G(PPL),",",1)
  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
  1.  I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) K PSOMC,PSOMDT G RESET
  1. 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
  1.  .;          Get drug IEN and check if CMOP
  1.  .S CK=$P($G(^PSRX(RX,0)),"^",6) Q:'$D(^PSDRUG("AQ",CK))
  1.  .;          If not marked for O.P., unmark for CMOP...
  1.  .I $P($G(^PSDRUG(CK,2)),"^",3)'["O" D UNMARK^PSOCMOP Q
  1.  .;          Check Drug Warning >11
  1.  .N WARNS,COMM S WARNS=$P(^PSDRUG(CK,0),U,8) I $L(WARNS)>11 D  Q
  1.  .. S COMM(1)="Rx# "_$P(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters."
  1.  .. S COMM(2)="Drug Name: "_$P(^PSDRUG(CK,0),U)_"  (IEN: # "_CK_")"
  1.  .. D COMM(RX,.COMM)
  1.  .;           Q:If partial or pull early
  1.  .Q:$G(RXPR(RX))!($G(RXRS(RX)))
  1.  .;           Q:If standard reprint but allow edit reprint
  1.  .I $G(RXRP(RX))&($P($G(RXRP(RX)),"^",4)'=1) Q
  1.  .;           Q:If tradename
  1.  .Q:$G(^PSRX(RX,"TN"))]""
  1.  .;           Q: If Cancelled, Expired, Deleted, Hold
  1.  .Q:$P(^PSRX(RX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3)
  1.  .;        Find last fill
  1.  .S RFD=0 F X7=0:0 S X7=$O(^PSRX(RX,1,X7)) Q:'$G(X7)  S (RFD)=X7
  1.  .Q:$G(RXFL(RX))&(RFD)&($G(RXFL(RX))'=RFD)
  1.  .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
  1.  ..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
  1.  .;           Q:If not "Mail"
  1.  .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
  1.  .;
  1.  .;           Q:If fill was CMOPed and other than a '3' 'not dispensed' 
  1.  .Q:'$$FILTRAN(RX,RFD)
  1.  .;
  1.  .;            Check if released, for use in Sus
  1.  .S REL=$S(RFD=0:$P($G(^PSRX(RX,2)),"^",13),1:$P($G(^PSRX(RX,1,RFD,0)),"^",18)) K RFD
  1.  .I $G(REL) Q
  1.  .;           Save CMOP's in PSXPPL1
  1.  .S $P(RX("CMOP"),",",P2)=RX,P2=P2+1,FLAG=1 Q
  1.  K PPL S PPL=$G(RX("PSO")),RX1("CMOP")=$G(RX("CMOP")) K RX("PSO")
  1.  G:$G(XFROM)="EDIT" D1 ; passed from PSXEDIT
  1. RESET ;
  1.  G:'$G(RX("CMOP")) D1
  1.  I $G(XFROM)="REINSTATE"!($G(XFROM)="UNHOLD") Q
  1.  I $G(PSOFROM)="EDIT",($G(REL)]"") S PPL=RX("CMOP") G D1
  1. S ;           Auto-Suspend CMOPS
  1.  N DA,Y
  1.  F PI=1:1 S DA=$P($G(RX("CMOP")),",",PI) Q:'DA  D SUS
  1.  S SUSPT="SUSPENSE"
  1.  G D1
  1. SUS ;
  1.  I $G(XFROM)="REINSTATE" W !,RX_" REINSTATED -- "
  1.  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)
  1.  .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
  1.  K X7 S RFD1=0 F X7=0:0 S X7=$O(^PSRX(DA,1,X7)) Q:'$G(X7)  S (RFD1)=X7
  1. LOCK S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="",X=RXN
  1.  S DIC("DR")=".02////"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_PSOSITE_";2////0;3////Q;9////"_RFD1
  1.  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
  1.  S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
  1.  W !!,"RX# ",$P(^PSRX(RXN,0),"^")_" HAS BEEN SUSPENDED for CMOP Until "_LFD_"."
  1.  S VALMSG="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"."
  1.  S COMM="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"."
  1.  D EN^PSOHLSN1(RXN,"SC","ZS",COMM) K COMM
  1.  ;- Calling ECME to reverse any PAYABLE claim for the prescription/fill
  1.  D REVERSE^PSOBPSU1(RXN,,"DC",3)
  1.  Q
  1. 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
  1.  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  1.  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
  1.  D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD
  1.  K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
  1.  Q
  1. D1 K CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7
  1.  K PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1
  1.  Q
  1. RXL N FROM S FROM=$G(PSOFROM)
  1.  I ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($G(XFROM)="HOLD")!($G(XFROM)="BATCH")) G TOP
  1.  Q
  1. SUS1 ;
  1.  N PPL
  1.  S PPL=DA D TEST
  1.  I $G(PPL)']"" S XFLAG=1
  1.  S RX("CMOP")=$G(RX1("CMOP"))
  1.  Q
  1. A S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
  1.  G TEST
  1. UNMARK ;Entry point to unmark drug for CMOP dispense
  1.  N X,Z,%
  1.  S $P(^PSDRUG(CK,3),"^",1)=0 K ^PSDRUG("AQ",CK)
  1.  S:'$D(^PSDRUG(CK,4,0)) ^PSDRUG(CK,4,0)="^50.0214DA^^"
  1.  S (X,Z)=0 F  S Z=$O(^PSDRUG(CK,4,Z)) Q:'Z  S X=Z
  1.  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:"")
  1.  S $P(^PSDRUG(CK,4,0),"^",3)=X,$P(^(0),"^",4)=$P(^(0),"^",4)+1
  1.  I $$PATCH^XPDUTL("PSS*1.0*70") D DRG^PSSHUIDG(CK)
  1.  K X,Z,%
  1.  Q
  1. FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send
  1.  N DA,CMOP
  1.  S DA=RX
  1.  D ^PSOCMOPA
  1.  I '$D(CMOP(RFD)) Q 1
  1.  I CMOP(RFD)=3 Q 1
  1.  Q 0
  1. COMM(RXN,COMM) ;EP process problem message to g.cmop managers
  1.  N XMSUB,XMTEXT
  1.  S XMTEXT="COMM(",XMY("I:G.CMOP MANAGERS")=""
  1.  S XMSUB="CMOP RX PROBLEM ENCOUNTERED"
  1.  D ^XMD
  1.  Q
  1. 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)
  1.  N RXDA,DRGDA,DEA,TYP
  1.  S RXDA=$P(^PS(52.5,SUSDA,0),U),DRGDA=$P(^PSRX(RXDA,0),U,6)
  1.  S TYP="N",DEA=$P(^PSDRUG(DRGDA,0),U,3) F I=3,4,5 I DEA[I S TYP="C"
  1.  Q TYP
  1. NOW() D NOW^%DTC Q %
  1.  ;
  1. PIECE(REC,DLM,VP) ; VP="Variable^Piece"
  1.  ; Set Variable V = piece P of REC using delimiter DLM
  1.  N V,P S V=$P(VP,U),P=$P(VP,U,2),@V=$P(REC,DLM,P)
  1.  Q
  1. PUT(REC,DLM,VP) ; VP="Variable^Piece"
  1.  ; pass by reference D PUT^PSOCMOP(.REC,DLM,VP)
  1.  ; Set Variable V into piece P of REC using delimiter DLM
  1.  N V,P S V=$P(VP,U),P=$P(VP,U,2)
  1.  S $P(REC,DLM,P)=$G(@V)
  1.  Q
  1. KCMPX(SUS,VAL) ; Kill ^PS(52.5,"CMP",VAL index given SUS
  1.  N SDT,TYP,DFN,DIV,RX,F,XX
  1.  S F=$G(^PS(52.5,SUS,0)) Q:'+F  S TYP=$$CMPRXTYP(SUS)
  1.  F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
  1.  K ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)
  1.  Q
  1. SCMPX(SUS,VAL) ; Set  ^PS(52.5,"CMP",VAL index given SUS
  1.  N SDT,TYP,DFN,DIV,RX,F,XX
  1.  S F=$G(^PS(52.5,SUS,0)) Q:'+F  S TYP=$$CMPRXTYP(SUS)
  1.  F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
  1.  S ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)=""
  1.  Q