- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m
r613 r623 1 PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ; 6/28/07 7:35am2 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148,274**;DEC 1997;Build 8 3 4 5 6 7 TOP 8 9 10 11 12 START 13 TEST 14 15 16 17 18 19 20 LOOP 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 RESET 57 58 59 60 S 61 62 63 64 65 SUS 66 67 68 69 70 LOCK 71 72 73 74 75 76 77 78 79 80 81 ACT 82 83 84 85 86 87 D1 88 89 90 RXL 91 92 93 SUS1 94 95 96 97 98 99 A 100 101 UNMARK 102 103 104 105 106 107 108 109 110 111 FILTRAN(RX,RFD) 112 113 114 115 116 117 118 COMM(RXN,COMM) 119 120 121 122 123 124 CMPRXTYP(SUSDA) 125 126 127 128 129 130 NOW() 131 132 PIECE(REC,DLM,VP) 133 134 135 136 PUT(REC,DLM,VP) 137 138 139 140 141 142 KCMPX(SUS,VAL) 143 144 145 146 147 148 SCMPX(SUS,VAL) 149 150 151 152 153 1 PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ;02/19/98 9:21 AM 2 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148**;DEC 1997 3 ;External reference to ^PS(55 supported by DBIA 2228 4 ;External reference to ^PSDRUG supported by DBIA 221 5 ;External reference to ^PSDRUG supported by DBIA 3165 6 ;External reference to ^PSSHUIDG supported by DBIA 3621 7 TOP ; 8 I $G(PSOFROM)="EDIT" S PPL=$G(PSORX("PSOL",1)) Q:$G(PPL)']"" G TEST 9 I $G(PPL) G START 10 I '$G(RXLTOP) S PPL=$G(DA) G TEST 11 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1 12 START ; Establish CMOP PPL 13 TEST N ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN 14 N RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX 15 S (P1,P2)=1,FLAG=0 16 ; PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date 17 S TRX=$P($G(PPL),",",1) 18 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 19 I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) K PSOMC,PSOMDT G RESET 20 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 21 .; Get drug IEN and check if CMOP 22 .S CK=$P($G(^PSRX(RX,0)),"^",6) Q:'$D(^PSDRUG("AQ",CK)) 23 .; If not marked for O.P., unmark for CMOP... 24 .I $P($G(^PSDRUG(CK,2)),"^",3)'["O" D UNMARK^PSOCMOP Q 25 .; Check Drug Warning >11 26 .N WARNS,COMM S WARNS=$P(^PSDRUG(CK,0),U,8) I $L(WARNS)>11 D Q 27 .. S COMM(1)="Rx# "_$P(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters." 28 .. S COMM(2)="Drug Name: "_$P(^PSDRUG(CK,0),U)_" (IEN: # "_CK_")" 29 .. D COMM(RX,.COMM) 30 .; Q:If partial or pull early 31 .Q:$G(RXPR(RX))!($G(RXRS(RX))) 32 .; Q:If standard reprint but allow edit reprint 33 .I $G(RXRP(RX))&($P($G(RXRP(RX)),"^",4)'=1) Q 34 .; Q:If tradename 35 .Q:$G(^PSRX(RX,"TN"))]"" 36 .; Q: If Cancelled, Expired, Deleted, Hold 37 .Q:$P(^PSRX(RX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3) 38 .; Find last fill 39 .S RFD=0 F X7=0:0 S X7=$O(^PSRX(RX,1,X7)) Q:'$G(X7) S (RFD)=X7 40 .Q:$G(RXFL(RX))&(RFD)&($G(RXFL(RX))'=RFD) 41 .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 42 ..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 43 .; Q:If not "Mail" 44 .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 45 .; 46 .; Q:If fill was CMOPed and other than a '3' 'not dispensed' 47 .Q:'$$FILTRAN(RX,RFD) 48 .; 49 .; Check if released, for use in Sus 50 .S REL=$S(RFD=0:$P($G(^PSRX(RX,2)),"^",13),1:$P($G(^PSRX(RX,1,RFD,0)),"^",18)) K RFD 51 .I $G(REL) Q 52 .; Save CMOP's in PSXPPL1 53 .S $P(RX("CMOP"),",",P2)=RX,P2=P2+1,FLAG=1 Q 54 K PPL S PPL=$G(RX("PSO")),RX1("CMOP")=$G(RX("CMOP")) K RX("PSO") 55 G:$G(XFROM)="EDIT" D1 ; passed from PSXEDIT 56 RESET ; 57 G:'$G(RX("CMOP")) D1 58 I $G(XFROM)="REINSTATE"!($G(XFROM)="UNHOLD") Q 59 I $G(PSOFROM)="EDIT",($G(REL)]"") S PPL=RX("CMOP") G D1 60 S ; Auto-Suspend CMOPS 61 N DA,Y 62 F PI=1:1 S DA=$P($G(RX("CMOP")),",",PI) Q:'DA D SUS 63 S SUSPT="SUSPENSE" 64 G D1 65 SUS ; 66 I $G(XFROM)="REINSTATE" W !,RX_" REINSTATED -- " 67 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) 68 .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN 69 K X7 S RFD1=0 F X7=0:0 S X7=$O(^PSRX(DA,1,X7)) Q:'$G(X7) S (RFD1)=X7 70 LOCK S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="",X=RXN 71 S DIC("DR")=".02////"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_PSOSITE_";2////0;3////Q;9////"_RFD1 72 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 73 S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT 74 W !!,"RX# ",$P(^PSRX(RXN,0),"^")_" HAS BEEN SUSPENDED for CMOP Until "_LFD_"." 75 S VALMSG="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"." 76 S COMM="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"." 77 D EN^PSOHLSN1(RXN,"SC","ZS",COMM) K COMM 78 ;- Calling ECME to reverse any PAYABLE claim for the prescription/fill 79 D REVERSE^PSOBPSU1(RXN,,"DC",3) 80 Q 81 ACT I '$D(RXF) 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 82 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA 83 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR 84 D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD 85 K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I 86 Q 87 D1 K CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7 88 K PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1 89 Q 90 RXL N FROM S FROM=$G(PSOFROM) 91 I ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($G(XFROM)="HOLD")!($G(XFROM)="BATCH")) G TOP 92 Q 93 SUS1 ; 94 N PPL 95 S PPL=DA D TEST 96 I $G(PPL)']"" S XFLAG=1 97 S RX("CMOP")=$G(RX1("CMOP")) 98 Q 99 A S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1 100 G TEST 101 UNMARK ;Entry point to unmark drug for CMOP dispense 102 N X,Z,% 103 S $P(^PSDRUG(CK,3),"^",1)=0 K ^PSDRUG("AQ",CK) 104 S:'$D(^PSDRUG(CK,4,0)) ^PSDRUG(CK,4,0)="^50.0214DA^^" 105 S (X,Z)=0 F S Z=$O(^PSDRUG(CK,4,Z)) Q:'Z S X=Z 106 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:"") 107 S $P(^PSDRUG(CK,4,0),"^",3)=X,$P(^(0),"^",4)=$P(^(0),"^",4)+1 108 I $$PATCH^XPDUTL("PSS*1.0*70") D DRG^PSSHUIDG(CK) 109 K X,Z,% 110 Q 111 FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send 112 N DA,CMOP 113 S DA=RX 114 D ^PSOCMOPA 115 I '$D(CMOP(RFD)) Q 1 116 I CMOP(RFD)=3 Q 1 117 Q 0 118 COMM(RXN,COMM) ;EP process problem message to g.cmop managers 119 N XMSUB,XMTEXT 120 S XMTEXT="COMM(",XMY("I:G.CMOP MANAGERS")="" 121 S XMSUB="CMOP RX PROBLEM ENCOUNTERED" 122 D ^XMD 123 Q 124 CMPRXTYP(SUSDA) ; given suspense record SUSDA returns RX CMOP TYPE C - CS, N -Non-CS 125 ;used in compound index ^PS(52.5,"CMP",STAT,TYP,DIV,DATE,DFN,DA) 126 N RXDA,DRGDA,DEA,TYP 127 S RXDA=$P(^PS(52.5,SUSDA,0),U),DRGDA=$P(^PSRX(RXDA,0),U,6) 128 S TYP="N",DEA=$P(^PSDRUG(DRGDA,0),U,3) F I=3,4,5 I DEA[I S TYP="C" 129 Q TYP 130 NOW() D NOW^%DTC Q % 131 ; 132 PIECE(REC,DLM,VP) ; VP="Variable^Piece" 133 ; Set Variable V = piece P of REC using delimiter DLM 134 N V,P S V=$P(VP,U),P=$P(VP,U,2),@V=$P(REC,DLM,P) 135 Q 136 PUT(REC,DLM,VP) ; VP="Variable^Piece" 137 ; pass by reference D PUT^PSOCMOP(.REC,DLM,VP) 138 ; Set Variable V into piece P of REC using delimiter DLM 139 N V,P S V=$P(VP,U),P=$P(VP,U,2) 140 S $P(REC,DLM,P)=$G(@V) 141 Q 142 KCMPX(SUS,VAL) ; Kill ^PS(52.5,"CMP",VAL index given SUS 143 N SDT,TYP,DFN,DIV,RX,F,XX 144 S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS) 145 F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX) 146 K ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS) 147 Q 148 SCMPX(SUS,VAL) ; Set ^PS(52.5,"CMP",VAL index given SUS 149 N SDT,TYP,DFN,DIV,RX,F,XX 150 S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS) 151 F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX) 152 S ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)="" 153 Q
Note:
See TracChangeset
for help on using the changeset viewer.
