Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOTPCUL

PSOTPCUL.m

Go to the documentation of this file.
  1. PSOTPCUL ;BIR/RTR-Utility Routine for TBP Project ;08/09/03
  1. ;;7.0;OUTPATIENT PHARMACY;**145,160**;DEC 1997
  1. ;
  1. EN(PSOTRXN) ;CPRS call to determine if an RX is a TPB Rx
  1. ;PSOTRXN = internal Rx number
  1. ;OUTPUT = 1 for TBP Rx, 0 for non-TPB Rx
  1. Q:'$G(PSOTRXN) 0
  1. Q $S($P($G(^PSRX(PSOTRXN,"TPB")),"^"):1,1:0)
  1. ;
  1. ACTRX(DFN,TPB) ; Checks if Patient has at least one Active Rx on File
  1. ; Input: DFN: Patient IEN (#2)
  1. ; TPB: 0 - Looks for active VA prescriptions only (Default)
  1. ; 1 - Looks for active TPB prescriptions only
  1. ; 2 - Looks for active VA or TPB prescriptions
  1. ;Output: 1 - Active Rx found / 0 - None found
  1. ;
  1. N SEQ,ACTRX,EXPDT
  1. I '$G(DFN) Q 0
  1. S TPB=+$G(TPB),(SEQ,ACTRX)=0
  1. F S SEQ=$O(^PS(55,DFN,"P",SEQ)) Q:'SEQ D I ACTRX Q
  1. . S RX=$G(^PS(55,DFN,"P",SEQ,0)),TPBRX=+$G(^PSRX(RX,"TPB"))
  1. . I '$$ACTIVE(RX) Q
  1. . I TPB=2 S ACTRX=1 Q
  1. . I TPB=1,TPBRX S ACTRX=1 Q
  1. . I TPB=0,'TPBRX S ACTRX=1 Q
  1. ;
  1. Q ACTRX
  1. ;
  1. ACTIVE(RX) ; Checks if Rx is Active or not
  1. N RXSTS,TPBRX,EXPDT
  1. S RXSTS=+$G(^PSRX(RX,"STA")) I RXSTS>9,(RXSTS'=16) Q 0
  1. S EXPDT=$P($G(^PSRX(RX,2)),"^",6) I EXPDT,EXPDT<DT Q 0
  1. Q 1
  1. ;
  1. TPBSC(LOC) ; Checks if Location Stop Code is from TPB Clinic
  1. ;
  1. N I,J,Z0,C1,C2,CODE
  1. F I=322,323,350 F J="000",185,186,187 S CODE(I_J)=""
  1. S Z0=$G(^SC(+LOC,0)) I Z0="" Q 0
  1. S C1=$P($G(^DIC(40.7,+$P(Z0,U,7),0)),U,2)
  1. S C2=$P($G(^DIC(40.7,+$P(Z0,U,18),0)),U,2)
  1. S C1=$E(C1_"000",1,3),C2=$E(C2_"000",1,3)
  1. I $D(CODE(C1_C2)) Q 1
  1. Q 0
  1. ;
  1. SXMY(GRP) ; Set XMY array with users from Mail Group GRP
  1. N GRPIEN,MBRIEN,CDRIEN
  1. ;
  1. I $G(GRP)="" Q
  1. S GRPIEN=$O(^XMB(3.8,"B",GRP,"")) I 'GRPIEN Q
  1. S CDRIEN=$$GET1^DIQ(3.8,GRPIEN,5.1,"I")
  1. K XMY S MBRIEN="" I CDRIEN'="" S XMY(CDRIEN)=""
  1. F S MBRIEN=$O(^XMB(3.8,GRPIEN,1,"B",MBRIEN)) Q:'MBRIEN D
  1. . S XMY(MBRIEN)=""
  1. Q