source: WorldVistAEHR/trunk/r/CMOP-PSX/PSXEDIT.m@ 1080

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

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1PSXEDIT ;BIR/HTW-CMOP Edit Routine for Outpatient Pharmacy ; [ 03/30/98 12:03 PM ]
2 ;;2.0;CMOP;**4,14**;11 Apr 97
3EDITCK ; Called from PROCESS+9^PSORXED to prevent editing CMOP Rx's
4 N PPL
5 S ZRX=PSORXED("IRXN"),PSXFILL=0,PSXTN=$G(^PSRX(ZRX,"TN"))
6 S PSXFROM="EDIT"
7 ; IF CMOP drug PSXYES=1
8DRUG I $D(^PSDRUG("AQ",$P(^PSRX(ZRX,0),"^",6))) S (PSXOUT,PSXYES)=1
9 G:'$G(PSXYES) PSXDIEX
10GETCMOP ; Any CMOP nodes?
11 F PSX=0:0 S PSX=$O(^PSRX(ZRX,4,PSX)) Q:(+PSX<1) D
12 .S PSXSTAT=$P($G(^PSRX(ZRX,4,PSX,0)),"^",4)
13 .S:$G(PSXSTAT)]"" PSXFLAGG=1
14 .S ZFILL=$P($G(^PSRX(ZRX,4,PSX,0)),"^",3)
15 .S PSX(ZFILL)=PSXSTAT
16 I $G(PSXSTAT)=0!($G(PSXSTAT)=2) S PSXFLAG=1
17 Q:$G(PSXHLD)
18 ;Check if in suspense...
19 I $D(^PS(52.5,"B",ZRX)) S PSXST=$O(^(ZRX,"")) D
20 .S PSXSUSDT=$P(^PS(52.5,PSXST,0),"^",2),PSXST1=$P($G(^(0)),"^",7)
21 .I $G(PSXST1)="L" S PSXFLAG=1
22 .F ZZ=0:0 S ZZ=$O(^PSRX(ZRX,1,ZZ)) Q:(ZZ'>0) I $P(^(ZZ,0),"^")=PSXSUSDT S PSXFILL=ZZ,PSX(ZZ)=$G(PSX(ZZ))_PSXST1
23 .I '$O(^PSRX(ZRX,1,0)) S PSX(0)=$G(PSX(0))_$G(PSXST1)
24 .S PSXM=$S(PSXFILL=0:$P(^PSRX(ZRX,0),"^",11),1:$P(^PSRX(ZRX,1,PSXFILL,0),"^",2))
25PSXDIE ;
26 I $G(PSXFLAG) D S PSORXED("DFLG")=1 G PSXDIEX
27 .W !!,"This prescription cannot be edited during CMOP processing."
28 W !,"Now Editing Rx # ",$P(PSORXED("RX0"),"^")
29 K DIE,DIC,DR,MSG
30 S DIE="^PSRX(",DA=ZRX
31 S PSX50=$P(^PSRX(PSORXED("IRXN"),0),"^",6)
32 S MSG=$P($G(^PSDRUG(PSX50,5)),"^")
33 I $G(MSG)'="" S MSG=$TR(MSG,";",","),MSG=$TR(MSG,":",","),MSG=$TR(MSG,"^",",")
34 ; PSXIDT=ISSUE DT, PSXFDT=FILL DT
35 S PSXIDT=$P(^PSRX(ZRX,0),"^",13),Y=PSXIDT X ^DD("DD") S PSXIDT=Y
36 S PSXFDT=$P(^PSRX(ZRX,2),"^",2),Y=PSXFDT X ^DD("DD") S PSXFDT=Y
37 I $G(PSX(0))[1 W !,"ISSUE DATE: ",PSXIDT," (No editing)",!,"FILL DATE: ",PSXFDT," (No editing)"
38 I $G(PSXFLAGG)!('$P(PSOPAR,"^",3)) W !,"DRUG: ",$P(^PSDRUG($P(^PSRX(PSORXED("IRXN"),0),"^",6),0),"^")," (No editing)"
39 S DR=$S(+$G(PSX(0))'[1:"1;22R;",1:"")_"3;4;5"
40 S DR=DR_$S($G(PSXFLAGG):"",'$P(PSOPAR,"^",3):"",1:";6")_";6.5;7QTY ( "_MSG_" )"
41 S DR=DR_";8;17;9:11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20;23;24"
42 ;D ^DIE G:$D(Y)!($D(DTOUT)) UNLOCK
43REFILL I $G(RFD)>0 S DR=DR_";52"
44 I S DR(2,52.1)="D CHECK^PSXEDIT;.01;@1;1"_"QTY ("_MSG_" )"_";1.1:5;8;15"
45 D ^DIE K DIE,DR,X
46 G:$D(Y)!($G(PSXEXIT)) UNLOCK I $D(DTOUT) S PSORXED("QFLG")=1 G PSXDIEX
47UNLOCK K DRG,PSXRFL D EN1^PSONEW2(.PSORXED)
48 I PSORXED("DFLG") S PSORXED("QFLG")=1 G PSXDIEX
49 G:'PSORXED("QFLG") PSXDIE
50 S PSORXED("QFLG")=0
51TRADE ; Did tradename change?
52 I $G(PSXTN)'=$P($G(^PSRX(ZRX,"TN")),"^") S PSXTN1=1 D ACT D
53 .S $P(^PSRX(ZRX,"A",0),"^",3)=A,$P(^PSRX(ZRX,"A",0),"^",4)=A1
54 .S ^PSRX(ZRX,"A",PSXB,0)=DT_"^E^"_DUZ_"^0^ Trade Name "_$G(PSXTN)
55 .Q
56 S:'$D(^PSDRUG("AQ",$P(^PSRX(ZRX,0),"^",6))) PSXYES=0
57 I PSXFILL>0,('$D(^PSRX(ZRX,1,PSXFILL,0))) G PSXDIEX
58 S PSXM1=$S(PSXFILL=0:$P(^PSRX(ZRX,0),"^",11),1:$P(^PSRX(ZRX,1,PSXFILL,0),"^",2))
59 I '$G(PSXTN1),($G(PSXM)=$G(PSXM1)),($G(PSXYES))!('$G(PSXST)) G PSXDIEX
60 S PSXFROM="EDIT"
61 S PSXPPL=ZRX D TEST^PSXNEW
62SUS ; If Rx is suspended and checks out to be CMOP suspend as CMOP
63 N DA
64 Q:'$G(PSXSYS)
65 I '$G(PPL),($G(PSXST)) D ACT D G PSXDIEX
66 .K ^PS(52.5,"AC",$P(^PSRX(ZRX,0),"^",2),$P(^PS(52.5,PSXST,0),"^",2),PSXST)
67 .S DIE="^PS(52.5,",DR="3////Q",DA=PSXST D ^DIE K DIE
68 .S T=$P(^PSRX(ZRX,3),"^")
69 .S T1=$E(T,4,5)_"-"_$E(T,6,7)_"-"_$E(T,2,3)
70 .S $P(^PSRX(ZRX,"A",0),"^",3)=A,$P(^PSRX(ZRX,"A",0),"^",4)=A1
71 .D NOW^%DTC
72 .I $G(PSXFILL)>5 S PSXFILL=PSXFILL+1 ; Accomodating 1 yr patch
73 .S ^PSRX(ZRX,"A",PSXB,0)=%_"^S^"_DUZ_"^"_$G(PSXFILL)_"^ Suspended for CMOP "_T1
74 .K T,T1,%
75UNSUS ; If Rx is suspended and is not CMOP, ensure is not suspended as CMOP
76 I $G(PSXST) D
77 .S DIE="^PS(52.5,",DR="3////@",DA=PSXST D ^DIE K DIE
78 .S ^PS(52.5,"AC",$P(^PSRX(ZRX,0),"^",2),$P(^PS(52.5,PSXST,0),"^",2),PSXST)=""
79PSXDIEX ;
80 K PSX,PSXA,PSXB,PSXREL,PSXST,PSXST1,ZRX,PSXIDT,PSXFROM,PSXTN1,PSX50
81 K PSXFDT,PSXRXF,PSXFILL,PSXFLAG,PSXM,PSXM1,PSXSTAT,PSXSUSDT,PSXTN,ZZ
82 K PSXHLD,PSXREL1,PSXSTAT,ZZ1,A,A1,ACT,PSXYES,PSXFLAGG,DIE,DR,ZPPL,MSG
83 Q
84ACT ; If no act node, make one .... determine last entry
85 S:'$D(^PSRX(ZRX,"A",0)) ^(0)="^52.3DA^^"
86 S PSXA="" F S PSXA=$O(^PSRX(ZRX,"A",PSXA)) Q:PSXA']"" S PSXB=PSXA+1
87 S A=$P(^PSRX(ZRX,"A",0),"^",3),A1=$P(^PSRX(ZRX,"A",0),"^",4),A=A+1,A1=A1+1
88 K PSXA
89 Q
90CHECK ;
91 I $G(PSX(D1))[1 S Y="@1"
92 Q
Note: See TracBrowser for help on using the repository browser.