source: WorldVistAEHR/trunk/r/CMOP-PSX/PSXNEW.m@ 1211

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PSXNEW ;BIR/HTW/PWC-Rx Order Entry Screen for CMOP ;11 Mar 2002 4:38 PM
2 ;;2.0;CMOP;**41**;11 Apr 97
3 ; reference to ^PS(52.5 supported by DBIA #1978
4 ; reference to ^PSRX supported by DBIA #1977
5 ; reference to EN^PSOHLSN1 supported by DBIA #2385
6 ; reference to ^XTMP("ORLK-" supported by DBIA #4001
7RESET(PSXRX,PSXFILL,PSXREAS) ;
8OERR ;clear ^XTMP("ORLK" if it is CPRS/CMOP
9 N ORD S ORD=+$P($G(^PSRX(+$G(PSXRX),"OR1")),"^",2)
10 I ORD,$D(^XTMP("ORLK-"_ORD,0)),^XTMP("ORLK-"_ORD,0)["CPRS/CMOP" K ^XTMP("ORLK-"_ORD)
11 ; Remove and test individual RX's
12 N PSXRFD,PSXEDREL,PSOSITE,PSXSD,PSXLFD,PSXDFN,PSX525,PSXD,PSXZ,PSXRXF,PSXFDA
13 ; Q:If tradename
14 Q:$G(^PSRX(PSXRX,"TN"))]""
15 ; Q: If Cancelled, Expired, Deleted, Drug Interactions, Hold
16 Q:$P(^PSRX(PSXRX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3)
17 ; Find last fill
18 S PSXRFD=+$O(^PSRX(PSXRX,1,"A"),-1)
19 S PSXEDREL=$S(PSXRFD=0:$P($G(^PSRX(PSXRX,2)),"^",13),1:$P($G(^PSRX(PSXRX,1,PSXRFD,0)),"^",18))
20 I PSXEDREL K DA,DIE,DR D
21 . I PSXRFD=0 S DA=PSXRX L +^PSRX(DA):600 S DIE="^PSRX(",DR="31///@" D ^DIE L -^PSRX(DA)
22 . I PSXRFD>0 S DA=PSXRFD,DA(1)=PSXRX L +^PSRX(DA(1),1,DA):600 S DIE="^PSRX(DA(1),1,",DR="17///@" D ^DIE L -^PSRX(DA(1),1,DA)
23SUS ; Auto-Suspend CMOPS
24 N DA,Y
25 S DA=PSXRX
26 ;D NOW^%DTC ; need to reset back to original suspended date
27 I PSXRFD=0 S %=$P(^PSRX(PSXRX,2),"^",2)
28 I PSXRFD>0 S %=$P(^PSRX(PSXRX,1,PSXRFD,0),"^",1)
29 S PSXSD=$P(%,".",1),PSXLFD=$E(%,4,5)_"-"_$E(%,6,7)_"-"_$E(%,2,3)
30 S PSXRXS=$O(^PS(52.5,"B",PSXRX,0))
31 I PSXRXS S DA=PSXRXS,DIK="^PS(52.5," D ^DIK S DA=PSXRX
32 I $G(PSXRFD)>0 S PSOSITE=$P(^PSRX(PSXRX,1,PSXRFD,0),"^",9)
33 I $G(PSXRFD)=0 S PSOSITE=$P(^PSRX(PSXRX,2),"^",9)
34 S DIC="^PS(52.5,",DIC(0)="Z"
35 K DD,DO S X=PSXRX,PSXDFN=$P(^PSRX(PSXRX,0),"^",2)
36 S DIC("DR")=".02////"_PSXSD_";.03////"_PSXDFN_";.04////M;.05////0;.06////"_PSOSITE_";2////0;3////Q;9////"_PSXRFD
37 D FILE^DICN K DIC,DIK,DD,DO
38 I +Y>0 S PSX525=+Y
39 E D EXIT Q
40LOCK525 ;
41 L +^PS(52.5,PSX525):600 G:'$T LOCK525
42 K ^PS(52.5,"AC",PSXDFN,PSXSD,PSX525),PSXDFN
43 L -^PS(52.5,PSX525)
44 D SETRX
45 D ACT
46 S COMM="Rx# "_$P(^PSRX(PSXRX,0),"^")_" Has Been Suspended for CMOP Until "_PSXLFD_"."
47 D EN^PSOHLSN1(PSXRX,"SC","ZS",COMM) K COMM
48EXIT K PSXRXS,PSXLFD,PSXRXF,PSXFDA,PSXIR,PSXRX,PSXSD,PSXRXDA,PSXRFD,PSX
49 K PSXEDREL,PSOSITE,PSX525,PSXDFN,PSXFIEN,PSXD,DIC,DIE,Y,X,%,%H,%I,%T,I
50 Q
51SETRX ; Check if last fill has been transmitted (0) or retransmitted (2) -
52 ; edit node and set to not dispensed (3).
53 ; If already dispensed (1) or not dispensed (3), create new entry
54 ; and set to not dispensed (3) with cancelled reason.
55 S $P(^PSRX(PSXRX,"STA"),"^")=5
56 K PSX S PSXZ=0
57 F S PSXZ=$O(^PSRX(PSXRX,4,PSXZ)) Q:'PSXZ D
58 . S PSXD=$G(^PSRX(PSXRX,4,PSXZ,0))
59 . S FILL=$P(PSXD,U,3)
60 . S:FILL'="" PSX($P(PSXD,U,3))=$P(PSXD,U,4)_"^"_PSXZ ; PSX(FILL)=STATUS^IEN
61 Q:'$D(PSX(PSXRFD)) ;last fill does not have entry in multiple
62 S PSXST=$P(PSX(PSXRFD),U,1),PSXFIEN=$P(PSX(PSXRFD),U,2)
63 I PSXST=0!(PSXST=2) D Q
64 . K DA,DIE,DIC,DR S DIE="^PSRX(DA(1),4,",DA(1)=PSXRX,DA=PSXFIEN
65 . S DR="3////3;5////"_PSXSD_";8////"_$G(PSXREAS)
66 . L +^PSRX(DA(1),4,DA):600
67 . D ^DIE L -^PSRX(DA(1),4,DA) K DIC,DIK,DD,DO
68 I PSXST=1!(PSXST=3) D
69 . K DD,DO S X="",DIC="^PSRX("_PSXRX_",4,",DIC(0)="Z"
70 . S DIC("DR")=".01////"_$P(PSXD,U,1)_";1////"_$P(PSXD,U,2)_";2////"_$P(PSXD,U,3)_";3////3;5////"_PSXSD_";8////"_$G(PSXREAS)
71 . D FILE^DICN K DIC,DIK,DD,DO
72 Q
73ACT ; adds activity info for CMOP Rx placed on suspense
74 I '$D(PSXRXF) S PSXRXF=0 F I=0:0 S I=$O(^PSRX(PSXRX,1,I)) Q:'I S PSXRXF=I
75 S PSXIR=0 F PSXFDA=0:0 S PSXFDA=$O(^PSRX(PSXRX,"A",PSXFDA)) Q:'PSXFDA S PSXIR=PSXFDA
76 S PSXIR=PSXIR+1,^PSRX(PSXRX,"A",0)="^52.3DA^"_PSXIR_"^"_PSXIR
77 D NOW^%DTC
78 I $G(PSXRXF)>5 S PSXRXF=PSXRXF+1
79 ;S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP Disaster Recovery until "_PSXLFD
80 S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP "_$G(PSXREAS)_" until "_PSXLFD
81 Q
Note: See TracBrowser for help on using the repository browser.