PSOTPCUL.m

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

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