PSOEXDT.m

PSOEXDT ;BHAM ISC/SAB - set exp. date and determine rx status ;29-May-2012 14:49;PLS

 ;;7.0;OUTPATIENT PHARMACY;**23,73,1011,1013,222,1015**;DEC 1997;Build 62

 ;

 ;External reference ^PS(55 supported by DBIA 2228

 ;External reference ^PSDRUG( supported by DBIA 221

 ; this program sets the expiration date of an rx.  the zeroeth node is

 ; held in rx0, and the second node is held in rx2.  the variable 'j' is

 ; the internal number in the prescription file (^psrx).

 ;

 ; Modified - IHS/MSC/PLS - 05/19/2011 - Line A+3

 ;                          02/13/2012 - Line A+5,A+10

A S CS=0,RFLS=$P(RX0,"^",9),DYS=$P(RX0,"^",8),X1=$P(RX0,"^",13),X2=DYS*(RFLS+1)\1,PSODEA=$P(^PSDRUG($P(RX0,"^",6),0),"^",3)

 F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S $P(CS,"^")=1 S:$E(+PSODEA,DEA)=2 $P(CS,"^",2)=1

 S X2=$S($G(CLOZPAT)=2&(RFLS):28,$G(CLOZPAT)=1&(RFLS):14,DYS=X2:X2,CS:184,1:366) I X1']"" S X1=DT,X2=-1

 ;IHS/MSC/PLS - 05/19/2011 - added next three lines

 N EXTEXP

 S X2=$S(CS:184,1:366)  ;IHS/MSC/PLS - 02/13/2012

 S EXTEXP=$$GET1^DIQ(50,$P(RX0,U,6),9999999.08)

 S X2=$S(EXTEXP:EXTEXP,1:X2)

 D C^%DTC S EX=$P(X,".") I +$G(PSORXED("RX1")),+$G(PSORXED("RX1"))>EX S EX=+$G(PSORXED("RX1"))

 ;K ^PSRX("AG",$P(^PSRX(J,2),"^",6),J)

 S EX=$$EXPDT^APSPAUTO(J) Q:'EX  ;IHS/MSC/PLS - 02/13/2012

 S $P(^PSRX(J,2),"^",6)=EX,RX2=^(2)

 S Y=$S($D(^PSRX(J,2)):^(2),1:""),X="" F ZII=1:1:10 S X=X_$P(Y,"^",ZII)_"^"

 K EX,X1,X2,DYS,RFLS,CS,PSODEA,DEA Q

STAT ;

 ;this entry point is call from dd(55.03,2,0).  this field is a computed

 ;field that helps determine the status of rxs found in the pharmacy

 ;patient file.  the status will be returned in the variable st.

 Q:'$D(^PSRX(J,0))!('$P($G(^PSRX(J,0)),"^",2))

 S PSOJ=J,DFN=+$P($G(^PSRX(J,0)),"^",2)

 D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) S J=PSOJ

B S ST0=+^PSRX(J,"STA") I ST0<12,$D(^PS(52.5,"B",J)) S ZII=$O(^(J,0)) I 'ZII,$D(^PS(52.5,ZII,0)),'$G(^("P")) S ST0=5

 D A:'$P(RX2,"^",6) I DT>$P(RX2,"^",6),((ST0<12)!(ST0>13)) S ST0=11

 S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUE (EDIT)^PROVIDER HOLD^","^",ST0+2)

 S RX0=$P(RX0_"^^^^^^^","^",1,14)_"^"_ST0_"^"_$P(RX0,"^",16,99)

 K PSOJ,DFN Q

PSOEXDT   ;BHAM ISC/SAB - set exp. date and determine rx status ;29-May-2012 14:49;PLS

 +1       ;;7.0;OUTPATIENT PHARMACY;**23,73,1011,1013,222,1015**;DEC 1997;Build 62

 +2       ;

 +3       ;External reference ^PS(55 supported by DBIA 2228

 +4       ;External reference ^PSDRUG( supported by DBIA 221

 +5       ; this program sets the expiration date of an rx.  the zeroeth node is

 +6       ; held in rx0, and the second node is held in rx2.  the variable 'j' is

 +7       ; the internal number in the prescription file (^psrx).

 +8       ;

 +9       ; Modified - IHS/MSC/PLS - 05/19/2011 - Line A+3

 +10      ;                          02/13/2012 - Line A+5,A+10

A          SET CS=0

           SET RFLS=$PIECE(RX0,"^",9)

           SET DYS=$PIECE(RX0,"^",8)

           SET X1=$PIECE(RX0,"^",13)

           SET X2=DYS*(RFLS+1)\1

           SET PSODEA=$PIECE(^PSDRUG($PIECE(RX0,"^",6),0),"^",3)

 +1        FOR DEA=1:1

               IF $EXTRACT(PSODEA,DEA)=""

                   QUIT 

               IF $EXTRACT(+PSODEA,DEA)>1

                   IF $EXTRACT(+PSODEA,DEA)<6

                       SET $PIECE(CS,"^")=1

                       IF $EXTRACT(+PSODEA,DEA)=2

                           SET $PIECE(CS,"^",2)=1

 +2        SET X2=$SELECT($GET(CLOZPAT)=2&(RFLS):28,$GET(CLOZPAT)=1&(RFLS):14,DYS=X2:X2,CS:184,1:366)

           IF X1']""

               SET X1=DT

               SET X2=-1

 +3       ;IHS/MSC/PLS - 05/19/2011 - added next three lines

 +4        NEW EXTEXP

 +5       ;IHS/MSC/PLS - 02/13/2012

           SET X2=$SELECT(CS:184,1:366)

 +6        SET EXTEXP=$$GET1^DIQ(50,$PIECE(RX0,U,6),9999999.08)

 +7        SET X2=$SELECT(EXTEXP:EXTEXP,1:X2)

 +8        DO C^%DTC

           SET EX=$PIECE(X,".")

           IF +$GET(PSORXED("RX1"))

               IF +$GET(PSORXED("RX1"))>EX

                   SET EX=+$GET(PSORXED("RX1"))

 +9       ;K ^PSRX("AG",$P(^PSRX(J,2),"^",6),J)

 +10      ;IHS/MSC/PLS - 02/13/2012

           SET EX=$$EXPDT^APSPAUTO(J)

           IF 'EX

               QUIT 

 +11       SET $PIECE(^PSRX(J,2),"^",6)=EX

           SET RX2=^(2)

 +12       SET Y=$SELECT($DATA(^PSRX(J,2)):^(2),1:"")

           SET X=""

           FOR ZII=1:1:10

               SET X=X_$PIECE(Y,"^",ZII)_"^"

 +13       KILL EX,X1,X2,DYS,RFLS,CS,PSODEA,DEA

           QUIT 

STAT      ;

 +1       ;this entry point is call from dd(55.03,2,0).  this field is a computed

 +2       ;field that helps determine the status of rxs found in the pharmacy

 +3       ;patient file.  the status will be returned in the variable st.

 +4        IF '$DATA(^PSRX(J,0))!('$PIECE($GET(^PSRX(J,0)),"^",2))

               QUIT 

 +5        SET PSOJ=J

           SET DFN=+$PIECE($GET(^PSRX(J,0)),"^",2)

 +6        IF $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2

               DO EN^PSOHLUP(DFN)

           SET J=PSOJ

B          SET ST0=+^PSRX(J,"STA")

           IF ST0<12

               IF $DATA(^PS(52.5,"B",J))

                   SET ZII=$ORDER(^(J,0))

                   IF 'ZII

                       IF $DATA(^PS(52.5,ZII,0))

                           IF '$GET(^("P"))

                               SET ST0=5

 +1        IF '$PIECE(RX2,"^",6)

               DO A

           IF DT>$PIECE(RX2,"^",6)

               IF ((ST0<12)!(ST0>13))

                   SET ST0=11

 +2        SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUE (EDIT)^PROVIDER HOLD^","^",ST0+2)

 +3        SET RX0=$PIECE(RX0_"^^^^^^^","^",1,14)_"^"_ST0_"^"_$PIECE(RX0,"^",16,99)

 +4        KILL PSOJ,DFN

           QUIT