| 1 | PSOTPCUL ;BIR/RTR-Utility Routine for TBP Project ;08/09/03
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;**145,160**;DEC 1997
|
|---|
| 3 | ;
|
|---|
| 4 | EN(PSOTRXN) ;CPRS call to determine if an RX is a TPB Rx
|
|---|
| 5 | ;PSOTRXN = internal Rx number
|
|---|
| 6 | ;OUTPUT = 1 for TBP Rx, 0 for non-TPB Rx
|
|---|
| 7 | Q:'$G(PSOTRXN) 0
|
|---|
| 8 | Q $S($P($G(^PSRX(PSOTRXN,"TPB")),"^"):1,1:0)
|
|---|
| 9 | ;
|
|---|
| 10 | ACTRX(DFN,TPB) ; Checks if Patient has at least one Active Rx on File
|
|---|
| 11 | ; Input: DFN: Patient IEN (#2)
|
|---|
| 12 | ; TPB: 0 - Looks for active VA prescriptions only (Default)
|
|---|
| 13 | ; 1 - Looks for active TPB prescriptions only
|
|---|
| 14 | ; 2 - Looks for active VA or TPB prescriptions
|
|---|
| 15 | ;Output: 1 - Active Rx found / 0 - None found
|
|---|
| 16 | ;
|
|---|
| 17 | N SEQ,ACTRX,EXPDT
|
|---|
| 18 | I '$G(DFN) Q 0
|
|---|
| 19 | S TPB=+$G(TPB),(SEQ,ACTRX)=0
|
|---|
| 20 | F S SEQ=$O(^PS(55,DFN,"P",SEQ)) Q:'SEQ D I ACTRX Q
|
|---|
| 21 | . S RX=$G(^PS(55,DFN,"P",SEQ,0)),TPBRX=+$G(^PSRX(RX,"TPB"))
|
|---|
| 22 | . I '$$ACTIVE(RX) Q
|
|---|
| 23 | . I TPB=2 S ACTRX=1 Q
|
|---|
| 24 | . I TPB=1,TPBRX S ACTRX=1 Q
|
|---|
| 25 | . I TPB=0,'TPBRX S ACTRX=1 Q
|
|---|
| 26 | ;
|
|---|
| 27 | Q ACTRX
|
|---|
| 28 | ;
|
|---|
| 29 | ACTIVE(RX) ; Checks if Rx is Active or not
|
|---|
| 30 | N RXSTS,TPBRX,EXPDT
|
|---|
| 31 | S RXSTS=+$G(^PSRX(RX,"STA")) I RXSTS>9,(RXSTS'=16) Q 0
|
|---|
| 32 | S EXPDT=$P($G(^PSRX(RX,2)),"^",6) I EXPDT,EXPDT<DT Q 0
|
|---|
| 33 | Q 1
|
|---|
| 34 | ;
|
|---|
| 35 | TPBSC(LOC) ; Checks if Location Stop Code is from TPB Clinic
|
|---|
| 36 | ;
|
|---|
| 37 | N I,J,Z0,C1,C2,CODE
|
|---|
| 38 | F I=322,323,350 F J="000",185,186,187 S CODE(I_J)=""
|
|---|
| 39 | S Z0=$G(^SC(+LOC,0)) I Z0="" Q 0
|
|---|
| 40 | S C1=$P($G(^DIC(40.7,+$P(Z0,U,7),0)),U,2)
|
|---|
| 41 | S C2=$P($G(^DIC(40.7,+$P(Z0,U,18),0)),U,2)
|
|---|
| 42 | S C1=$E(C1_"000",1,3),C2=$E(C2_"000",1,3)
|
|---|
| 43 | I $D(CODE(C1_C2)) Q 1
|
|---|
| 44 | Q 0
|
|---|
| 45 | ;
|
|---|
| 46 | SXMY(GRP) ; Set XMY array with users from Mail Group GRP
|
|---|
| 47 | N GRPIEN,MBRIEN,CDRIEN
|
|---|
| 48 | ;
|
|---|
| 49 | I $G(GRP)="" Q
|
|---|
| 50 | S GRPIEN=$O(^XMB(3.8,"B",GRP,"")) I 'GRPIEN Q
|
|---|
| 51 | S CDRIEN=$$GET1^DIQ(3.8,GRPIEN,5.1,"I")
|
|---|
| 52 | K XMY S MBRIEN="" I CDRIEN'="" S XMY(CDRIEN)=""
|
|---|
| 53 | F S MBRIEN=$O(^XMB(3.8,GRPIEN,1,"B",MBRIEN)) Q:'MBRIEN D
|
|---|
| 54 | . S XMY(MBRIEN)=""
|
|---|
| 55 | Q
|
|---|
