- PSOEXDT ;BHAM ISC/SAB - set exp. date and determine rx status ; 10/24/92 13:24
- ;;7.0;OUTPATIENT PHARMACY;**23,73,222,486,574,621,649**;DEC 1997;Build 1
- ;
- ;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).
- ;
- A ;
- S CS=0,RFLS=$P(RX0,"^",9),DYS=$P(RX0,"^",8),(ISSDT,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
- I $G(CLOZPAT) G DT
- S X2=$S(DYS=X2:X2,CS:184,1:366)
- I X2<30 D
- . N % S %=$P(RX0,"^",3),X2=30
- . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
- DT I X1']"" S X1=DT,X2=-1 ;486 End
- D C^%DTC S EX=$P(X,".") I +$G(PSORXED("RX1")),+$G(PSORXED("RX1"))>EX S EX=+$G(PSORXED("RX1"))
- ;
- ;If Calculated Rx Exp. Date is before Rx Fill Date (No Clozapine/No refills), reset to Fill Date + Days Supply
- I '$D(CLOZPAT),'RFLS,$$RXFLDT^PSOBPSUT(J,0)>EX D
- . S EX=$$FMADD^XLFDT($$RXFLDT^PSOBPSUT(J,0),DYS)
- . I $$FMDIFF^XLFDT(EX,ISSDT)>$S($G(CS):184,1:366) D
- . . S EX=$$FMADD^XLFDT(ISSDT,$S($G(CS):184,1:366))
- . I (EX<$$RXFLDT^PSOBPSUT(J,0)) D
- . . S EX=$$RXFLDT^PSOBPSUT(J,0)
- ;
- ; Updating calculated Expiration Date field on file #52 and "P"/"A" x-ref on file #55 (if different)
- I $G(EX)'="",EX'=$P($G(^PSRX(J,2)),"^",6) D
- . N PATIEN,OLDEXDT
- . S PATIEN=+$$GET1^DIQ(52,J,2,"I")
- . S OLDEXDT=$$GET1^DIQ(52,J,26,"I")
- . I OLDEXDT'="" K ^PS(55,PATIEN,"P","A",OLDEXDT,J)
- . S $P(^PSRX(J,2),"^",6)=EX
- . S ^PS(55,PATIEN,"P","A",EX,J)=""
- ;
- S RX2=$G(^PSRX(J,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,ISSDT 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOEXDT 2736 printed Feb 18, 2025@23:55:46 Page 2
- PSOEXDT ;BHAM ISC/SAB - set exp. date and determine rx status ; 10/24/92 13:24
- +1 ;;7.0;OUTPATIENT PHARMACY;**23,73,222,486,574,621,649**;DEC 1997;Build 1
- +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 ;
- A ;
- +1 SET CS=0
- SET RFLS=$PIECE(RX0,"^",9)
- SET DYS=$PIECE(RX0,"^",8)
- SET (ISSDT,X1)=$PIECE(RX0,"^",13)
- SET X2=DYS*(RFLS+1)\1
- SET PSODEA=$PIECE(^PSDRUG($PIECE(RX0,"^",6),0),"^",3)
- +2 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
- +3 IF $GET(CLOZPAT)
- GOTO DT
- +4 SET X2=$SELECT(DYS=X2:X2,CS:184,1:366)
- +5 IF X2<30
- Begin DoDot:1
- +6 NEW %
- SET %=$PIECE(RX0,"^",3)
- SET X2=30
- +7 if %?.N
- SET %=$PIECE($GET(^PS(53,+%,0)),"^")
- IF %["AUTH ABS"
- SET X2=5
- End DoDot:1
- DT ;486 End
- IF X1']""
- SET X1=DT
- SET X2=-1
- +1 DO C^%DTC
- SET EX=$PIECE(X,".")
- IF +$GET(PSORXED("RX1"))
- IF +$GET(PSORXED("RX1"))>EX
- SET EX=+$GET(PSORXED("RX1"))
- +2 ;
- +3 ;If Calculated Rx Exp. Date is before Rx Fill Date (No Clozapine/No refills), reset to Fill Date + Days Supply
- +4 IF '$DATA(CLOZPAT)
- IF 'RFLS
- IF $$RXFLDT^PSOBPSUT(J,0)>EX
- Begin DoDot:1
- +5 SET EX=$$FMADD^XLFDT($$RXFLDT^PSOBPSUT(J,0),DYS)
- +6 IF $$FMDIFF^XLFDT(EX,ISSDT)>$SELECT($GET(CS):184,1:366)
- Begin DoDot:2
- +7 SET EX=$$FMADD^XLFDT(ISSDT,$SELECT($GET(CS):184,1:366))
- End DoDot:2
- +8 IF (EX<$$RXFLDT^PSOBPSUT(J,0))
- Begin DoDot:2
- +9 SET EX=$$RXFLDT^PSOBPSUT(J,0)
- End DoDot:2
- End DoDot:1
- +10 ;
- +11 ; Updating calculated Expiration Date field on file #52 and "P"/"A" x-ref on file #55 (if different)
- +12 IF $GET(EX)'=""
- IF EX'=$PIECE($GET(^PSRX(J,2)),"^",6)
- Begin DoDot:1
- +13 NEW PATIEN,OLDEXDT
- +14 SET PATIEN=+$$GET1^DIQ(52,J,2,"I")
- +15 SET OLDEXDT=$$GET1^DIQ(52,J,26,"I")
- +16 IF OLDEXDT'=""
- KILL ^PS(55,PATIEN,"P","A",OLDEXDT,J)
- +17 SET $PIECE(^PSRX(J,2),"^",6)=EX
- +18 SET ^PS(55,PATIEN,"P","A",EX,J)=""
- End DoDot:1
- +19 ;
- +20 SET RX2=$GET(^PSRX(J,2))
- +21 SET Y=$SELECT($DATA(^PSRX(J,2)):^(2),1:"")
- SET X=""
- FOR ZII=1:1:10
- SET X=X_$PIECE(Y,"^",ZII)_"^"
- +22 KILL EX,X1,X2,DYS,RFLS,CS,PSODEA,DEA,ISSDT
- 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