source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m@ 1080

Last change on this file since 1080 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 6.8 KB
Line 
1PSOCMOP ;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
7TOP ;
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
12START ; Establish CMOP PPL
13TEST 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
20LOOP 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
56RESET ;
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
60S ; 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
65SUS ;
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
70LOCK 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
81ACT 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
87D1 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
90RXL 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
93SUS1 ;
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
99A S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
100 G TEST
101UNMARK ;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
111FILTRAN(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
118COMM(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
124CMPRXTYP(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
130NOW() D NOW^%DTC Q %
131 ;
132PIECE(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
136PUT(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
142KCMPX(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
148SCMPX(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 TracBrowser for help on using the repository browser.