PSOTPCUL ;BIR/RTR-Utility Routine for TBP Project ;08/09/03
;;7.0;OUTPATIENT PHARMACY;**145,160**;DEC 1997
;
EN(PSOTRXN) ;CPRS call to determine if an RX is a TPB Rx
;PSOTRXN = internal Rx number
;OUTPUT = 1 for TBP Rx, 0 for non-TPB Rx
Q:'$G(PSOTRXN) 0
Q $S($P($G(^PSRX(PSOTRXN,"TPB")),"^"):1,1:0)
;
ACTRX(DFN,TPB) ; Checks if Patient has at least one Active Rx on File
; Input: DFN: Patient IEN (#2)
; TPB: 0 - Looks for active VA prescriptions only (Default)
; 1 - Looks for active TPB prescriptions only
; 2 - Looks for active VA or TPB prescriptions
;Output: 1 - Active Rx found / 0 - None found
;
N SEQ,ACTRX,EXPDT
I '$G(DFN) Q 0
S TPB=+$G(TPB),(SEQ,ACTRX)=0
F S SEQ=$O(^PS(55,DFN,"P",SEQ)) Q:'SEQ D I ACTRX Q
. S RX=$G(^PS(55,DFN,"P",SEQ,0)),TPBRX=+$G(^PSRX(RX,"TPB"))
. I '$$ACTIVE(RX) Q
. I TPB=2 S ACTRX=1 Q
. I TPB=1,TPBRX S ACTRX=1 Q
. I TPB=0,'TPBRX S ACTRX=1 Q
;
Q ACTRX
;
ACTIVE(RX) ; Checks if Rx is Active or not
N RXSTS,TPBRX,EXPDT
S RXSTS=+$G(^PSRX(RX,"STA")) I RXSTS>9,(RXSTS'=16) Q 0
S EXPDT=$P($G(^PSRX(RX,2)),"^",6) I EXPDT,EXPDT<DT Q 0
Q 1
;
TPBSC(LOC) ; Checks if Location Stop Code is from TPB Clinic
;
N I,J,Z0,C1,C2,CODE
F I=322,323,350 F J="000",185,186,187 S CODE(I_J)=""
S Z0=$G(^SC(+LOC,0)) I Z0="" Q 0
S C1=$P($G(^DIC(40.7,+$P(Z0,U,7),0)),U,2)
S C2=$P($G(^DIC(40.7,+$P(Z0,U,18),0)),U,2)
S C1=$E(C1_"000",1,3),C2=$E(C2_"000",1,3)
I $D(CODE(C1_C2)) Q 1
Q 0
;
SXMY(GRP) ; Set XMY array with users from Mail Group GRP
N GRPIEN,MBRIEN,CDRIEN
;
I $G(GRP)="" Q
S GRPIEN=$O(^XMB(3.8,"B",GRP,"")) I 'GRPIEN Q
S CDRIEN=$$GET1^DIQ(3.8,GRPIEN,5.1,"I")
K XMY S MBRIEN="" I CDRIEN'="" S XMY(CDRIEN)=""
F S MBRIEN=$O(^XMB(3.8,GRPIEN,1,"B",MBRIEN)) Q:'MBRIEN D
. S XMY(MBRIEN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPCUL 1840 printed Dec 13, 2024@02:35:52 Page 2
PSOTPCUL ;BIR/RTR-Utility Routine for TBP Project ;08/09/03
+1 ;;7.0;OUTPATIENT PHARMACY;**145,160**;DEC 1997
+2 ;
EN(PSOTRXN) ;CPRS call to determine if an RX is a TPB Rx
+1 ;PSOTRXN = internal Rx number
+2 ;OUTPUT = 1 for TBP Rx, 0 for non-TPB Rx
+3 if '$GET(PSOTRXN)
QUIT 0
+4 QUIT $SELECT($PIECE($GET(^PSRX(PSOTRXN,"TPB")),"^"):1,1:0)
+5 ;
ACTRX(DFN,TPB) ; Checks if Patient has at least one Active Rx on File
+1 ; Input: DFN: Patient IEN (#2)
+2 ; TPB: 0 - Looks for active VA prescriptions only (Default)
+3 ; 1 - Looks for active TPB prescriptions only
+4 ; 2 - Looks for active VA or TPB prescriptions
+5 ;Output: 1 - Active Rx found / 0 - None found
+6 ;
+7 NEW SEQ,ACTRX,EXPDT
+8 IF '$GET(DFN)
QUIT 0
+9 SET TPB=+$GET(TPB)
SET (SEQ,ACTRX)=0
+10 FOR
SET SEQ=$ORDER(^PS(55,DFN,"P",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+11 SET RX=$GET(^PS(55,DFN,"P",SEQ,0))
SET TPBRX=+$GET(^PSRX(RX,"TPB"))
+12 IF '$$ACTIVE(RX)
QUIT
+13 IF TPB=2
SET ACTRX=1
QUIT
+14 IF TPB=1
IF TPBRX
SET ACTRX=1
QUIT
+15 IF TPB=0
IF 'TPBRX
SET ACTRX=1
QUIT
End DoDot:1
IF ACTRX
QUIT
+16 ;
+17 QUIT ACTRX
+18 ;
ACTIVE(RX) ; Checks if Rx is Active or not
+1 NEW RXSTS,TPBRX,EXPDT
+2 SET RXSTS=+$GET(^PSRX(RX,"STA"))
IF RXSTS>9
IF (RXSTS'=16)
QUIT 0
+3 SET EXPDT=$PIECE($GET(^PSRX(RX,2)),"^",6)
IF EXPDT
IF EXPDT<DT
QUIT 0
+4 QUIT 1
+5 ;
TPBSC(LOC) ; Checks if Location Stop Code is from TPB Clinic
+1 ;
+2 NEW I,J,Z0,C1,C2,CODE
+3 FOR I=322,323,350
FOR J="000",185,186,187
SET CODE(I_J)=""
+4 SET Z0=$GET(^SC(+LOC,0))
IF Z0=""
QUIT 0
+5 SET C1=$PIECE($GET(^DIC(40.7,+$PIECE(Z0,U,7),0)),U,2)
+6 SET C2=$PIECE($GET(^DIC(40.7,+$PIECE(Z0,U,18),0)),U,2)
+7 SET C1=$EXTRACT(C1_"000",1,3)
SET C2=$EXTRACT(C2_"000",1,3)
+8 IF $DATA(CODE(C1_C2))
QUIT 1
+9 QUIT 0
+10 ;
SXMY(GRP) ; Set XMY array with users from Mail Group GRP
+1 NEW GRPIEN,MBRIEN,CDRIEN
+2 ;
+3 IF $GET(GRP)=""
QUIT
+4 SET GRPIEN=$ORDER(^XMB(3.8,"B",GRP,""))
IF 'GRPIEN
QUIT
+5 SET CDRIEN=$$GET1^DIQ(3.8,GRPIEN,5.1,"I")
+6 KILL XMY
SET MBRIEN=""
IF CDRIEN'=""
SET XMY(CDRIEN)=""
+7 FOR
SET MBRIEN=$ORDER(^XMB(3.8,GRPIEN,1,"B",MBRIEN))
if 'MBRIEN
QUIT
Begin DoDot:1
+8 SET XMY(MBRIEN)=""
End DoDot:1
+9 QUIT
