PSOUTIL ;IHS/DSD/JCM - outpatient pharmacy utility routine ;29-May-2012 15:16;PLS
;;7.0;OUTPATIENT PHARMACY;**64,1013,1015**;DEC 1997;Build 62
; Modified - IHS/MSC/PLS - 11/07/2011 - Line PROV+17
W !!,$C(7),"This routine not callable from PSOUTIL.."
Q
;
NPSOSD(PSORX) ; Entry point to add newly added rx to patients PSOSD array
S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
S STAT=$P(STA,"^",$P(^PSRX(PSORX("IRXN"),"STA"),"^")+1)
I $D(PSOSD(STAT,PSODRUG("NAME"))),$P(PSOSD(STAT,PSODRUG("NAME")),"^",2)<10 D
. S PSOSD(STAT,PSODRUG("NAME")_"^"_PSORX("IRXN"))=PSORX("IRXN")_"^"_$P($G(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",8)_"^1"
E S PSOSD(STAT,PSODRUG("NAME"))=PSORX("IRXN")_"^"_$P($G(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",8)_"^1"
S PSOSD=$S($G(PSOSD)]"":PSOSD+1,1:1),^TMP("PS",$J,STAT,PSODRUG("NAME"))=1
Q
;
RNPSOSD ;update PSOSD array for renewals
S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
S STAT=$P(STA,"^",$P(^PSRX(PSORENW("OIRXN"),"STA"),"^")+1)
I $D(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN"))) D
. S PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN"))=PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN")),$P(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",2)=$P($G(^PSRX(PSORENW("IRXN"),"STA")),"^")
. S $P(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",6)=$P(^PSRX(PSORENW("IRXN"),0),"^",9)
. K PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN")) Q
E D
.S $P(PSOSD(STAT,PSODRUG("NAME")),"^")=PSORENW("IRXN"),$P(PSOSD(STAT,PSODRUG("NAME")),"^",2)=$P($G(^PSRX(PSORENW("IRXN"),"STA")),"^")
.S $P(PSOSD(STAT,PSODRUG("NAME")),"^",6)=$P(^PSRX(PSORENW("IRXN"),0),"^",9)
.S ^TMP("PS",$J,STAT,PSODRUG("NAME"))=1
Q
;
PROV(PSORENW) ;called from psoornew
CHKPRV ;check inactive providers and cosinging providers called from PSORENW (renew rx)
I '$D(^VA(200,PSORENW("PROVIDER"),0)) D G:PSORENW("DFLG") CHKPRVX
.W !,$C(7),"Provider not in New Person File .. You must select a new provider"
.S PSODIR("FIELD")=0 K PSORENW("PROVIDER") D PROV^PSODIR(.PSORENW)
.S:$G(PSORENW("PROVIDER"))']"" PSORENW("DFLG")=1
;
I '$G(^VA(200,PSORENW("PROVIDER"),"PS")) D G:PSORENW("DFLG") CHKPRVX
.W !,$C(7),$P(^VA(200,PSORENW("PROVIDER"),0),"^")_" is not a Valid provider .. You must select a new provider"
.S PSODIR("FIELD")=0 K PSORENW("PROVIDER") D PROV^PSODIR(.PSORENW)
.S:$G(PSORENW("PROVIDER"))']"" PSORENW("DFLG")=1
;
K PSOX S PSOX=$P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",4)
I PSOX,PSOX<DT D G:PSORENW("DFLG") CHKPRVX
.W !,$C(7),$P(^VA(200,PSORENW("PROVIDER"),0),"^")_" is inactive as a provider .. You must select a new provider"
.S PSODIR("FIELD")=0 K PSORENW("PROVIDER") D PROV^PSODIR(.PSORENW)
.I $G(PSORENW("PROVIDER"))']"" S PSORENW("DFLG")=1
;IHS/MSC/PLS - 11/07/2011
N CLOZPAT,APSPDIEN
S APSPDIEN=$S($G(PSORENW("DRUG IEN")):PSORENW("DRUG IEN"),$G(PSODRUG("IEN")):PSODRUG("IEN"),1:0)
S CLOZPAT=$S($P($G(^PSDRUG(APSPDIEN,"CLOZ1")),"^")="PSOCLO1":1,1:0)
I APSPDIEN,$$ISSCH^APSPFNC2(APSPDIEN,"2345")!($G(CLOZPAT)) D G:PSORENW("DFLG") CHKPRVX
.I '$L($P($G(^VA(200,+PSORENW("PROVIDER"),"PS")),U,2)),'$L($P($G(^VA(200,+PSORENW("PROVIDER"),"PS")),U,3)) D
..W $C(7),!!,"Provider must have a DEA# or VA#"_$S($G(CLOZPAT):" to write prescriptions for clozapine.",1:"."),!
..S PSODIR("FIELD")=0 K PSORENW("PROVIDER") D PROV^PSODIR(.PSORENW)
..I $G(PSORENW("PROVIDER"))']"" S PSORENW("DFLG")=1
;
I '$D(PSORENW("COSIGNING PROVIDER")),$D(PSORENW("COSIGNER")) K PSOX S PSOX=$P(^VA(200,PSORENW("COSIGNER"),"PS"),"^",4) I PSOX,PSOX<DT D
.W !,$C(7),"Inactive Cosigning Provider .. You must select a new cosigner"
.S PSODIR("FIELD")=0,PSODIR("PROVIDER")=$S($D(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:PSORENW("PROVIDER"))
.D COSIGN^PSODIR I '$D(PSODIR("COSIGNING PROVIDER")) S PSORENW("DFLG")=1
.S PSORENW("COSIGNING PROVIDER")=PSODIR("COSIGNING PROVIDER")
;
CHKPRVX K PSODIR,PSOX
Q
;
NEXT(PSOX) ;
S PSOX("RX0")=^PSRX(PSOX("IRXN"),0)
S PSOX("RX2")=^PSRX(PSOX("IRXN"),2)
S PSOX("RX3")=^PSRX(PSOX("IRXN"),3)
S PSOX1=$P(PSOX("RX2"),"^",2)
I '$O(^PSRX(PSOX("IRXN"),1,0)) D G NEXTX
. S $P(PSOX("RX3"),"^")=PSOX1,X1=PSOX1
. S X2=$P(PSOX("RX0"),"^",8)-10\1
. D C^%DTC
. S:'$P(PSOX("RX3"),"^",8) $P(PSOX("RX3"),"^",2)=X
. K X Q
;
S PSOY2=0
F PSOY=0:0 S PSOY=$O(^PSRX(PSOX("IRXN"),1,PSOY)) Q:'PSOY S PSOY1=PSOY,PSOY2=PSOY2+1
S PSOY=^PSRX(PSOX("IRXN"),1,PSOY1,0)
S PSOX2=$P(PSOY,"^")
S $P(PSOX("RX3"),"^")=PSOX2,X1=PSOX2
S X2=$P(PSOX("RX0"),"^",8)-10\1
D C^%DTC S PSOY3=X
S X1=PSOX1,X2=(PSOY2+1)*$P(PSOX("RX0"),"^",8)-10\1
D C^%DTC S PSOY4=X
S $P(PSOX("RX3"),"^",2)=$S(PSOY3<PSOY4:PSOY4,1:PSOY3)
NEXTX ;
K X,PSOX1,PSOX2,PSOY,PSOY1,PSOY2,PSOY3,PSOY4
Q
;
SUSDATE(PSOX) ;
S PSOX("OLD FILL DATE")=PSOX("FILL DATE")
S PSORX("OLD FILL DATE")=PSORX("FILL DATE")
S PSOX("FILL DATE")=$P(PSOX("RX3"),"^",2)
I $O(^PS(52.5,"B",PSOX("IRXN"),0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSOX("IRXN"),0)),"P")) S PSOX("FILL DATE")=$P(PSOX("RX3"),"^")
S Y=PSOX("FILL DATE")
X ^DD("DD") S PSORX("FILL DATE")=Y K Y
Q
;
SUSDATEK(PSOX) ;
S PSOX("FILL DATE")=PSOX("OLD FILL DATE")
I $G(PSORX("OLD FILL DATE"))="",$G(PSORENW("OLD FILL DATE")) S Y=PSORENW("OLD FILL DATE") D DD^%DT S PSORX("OLD FILL DATE")=Y K Y
S PSORX("FILL DATE")=PSORX("OLD FILL DATE")
K PSOX("OLD FILL DATE"),PSORX("OLD FILL DATE")
Q
;
STATUS(PSOREA,PSOSTAT) ;
S DSMSG="Cannot "_$S($G(PSOOPT)=3:"renew",1:"refill")_" Rx. " S:$G(OR0) ACOM=DSMSG
I PSOREA["A" W:$G(SPEED) ", Inactive Drug.",! D
.S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Inactive Drug.",VALMBCK="R" W:'$G(POERR) !," Inactive Drug"
.S:$G(OR0) ACOM=ACOM_" Inactive Drug."
I PSOREA["M" W:$G(SPEED) ", Drug no longer used by Outpatient.",! D
.S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Drug no longer used by Outpatient.",VALMBCK="R" W:'$G(POERR) !," Drug no longer used by Outpatient."
.S:$G(OR0) ACOM=ACOM_" Drug no longer used by Outpatient."
;
I PSOREA["B" W:$G(SPEED) ", Narcotic Drug." D
.W:'$G(POERR) !,"Narcotic Drug" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Narcotic Drug.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Narcotic Drug."
;
I PSOREA["C" W:$G(SPEED) ", Non-Renewable Drug." D
.W:'$G(POERR) !,"Non-Renewable Drug" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Non-Renewable Drug.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Non-Renewable Drug."
;
I PSOREA["D" W:$G(SPEED) ", Non-Renewable Patient Status." D
.W:'$G(POERR) !,"Non-Renewable Patient Status" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Non-Renewable Patient Status.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Non-Renewable Patient Status."
;
I PSOREA["E" W:$G(SPEED) ", Non-Verified Rx." D
.W:'$G(POERR) !,"Non-Verified Rx" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Non-Verified Rx.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Non-Verified Rx."
;
I PSOREA["F" W:$G(SPEED) ", Maximum of 26 Renewals." D
.W:'$G(POERR) !,"Maximum of 26 Renewals" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Maximum of 26 Renewals.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Maximum of 26 Renewals."
;
I PSOREA["G",PSOREA'["B" W:$G(SPEED) ", No more refills left." W:'$G(POERR) !,"No more refills left" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"No more refills left.",VALMBCK="R"
;
I PSOREA["Z" D
. S:PSOSTAT=4 PSOSTAT=1
. S PSOA=";"_PSOSTAT,PSOB=$P(^DD(52,100,0),"^",3),PSOA=$F(PSOB,PSOA),PSOA=$P($E(PSOB,PSOA,999),";",1)
. W:$G(SPEED) ", Rx is in "_$P(PSOA,":",2)_" status."
. W:'$G(POERR)&('$G(SPEED)) !,"Rx is in "_$P(PSOA,":",2)_" status"
.S:$G(POERR)&($G(VALMSG)']"")&('$G(SPEED)) VALMSG=DSMSG_"Rx is in "_$P(PSOA,":",2)_" status.",VALMBCK="R"
. K PSOA,PSOB
. Q
I $G(SPEED) K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIRUT,DUOUT,DTOUT,DIR
Q
ACP I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PSRX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))=""
Q
;
RENFDT(PSOX) ;gets the correct fill date
S PSOX("OLD FILL DATE")=PSOX("FILL DATE")
S PSORX("OLD FILL DATE")=PSORX("FILL DATE")
S PSOX("FILL DATE")=$P(PSOX("RX3"),"^",2)
N RXY,LBL,SUPN,LBP,RF,RFN,RFD
S RXY=PSOX("IRXN"),RFN=0
I '$O(^PSRX(RXY,1,0)) D GFDT G SDTX
F RF=0:0 S RF=$O(^PSRX(RXY,1,RF)) Q:'RF S RFN=RF
S RF=^PSRX(RXY,1,RFN,0) D GFDT
I PSOX("FILL DATE")<DT,PSOX("FILL DATE")<PSORNW("FILL DATE") S PSOX("FILL DATE")=DT
SDTX ;
S Y=PSOX("FILL DATE")
X ^DD("DD") S PSORX("FILL DATE")=Y K Y
Q
GFDT ;
I 'RFN,$P(^PSRX(RXY,2),"^",13) Q
I RFN,$P(RF,"^",18) Q
F LBL=0:0 S LBL=$O(^PSRX(RXY,"L",LBL)) Q:'LBL I $P(^PSRX(RXY,"L",LBL,0),"^",2)=RFN S LBP=1 Q
Q:$G(LBP)
S SUPN=$O(^PS(52.5,"B",RXY,0))
I SUPN,$P($G(^PS(52.5,SUPN,0)),"^",7)="L"!($P($G(^(0)),"^",7)="X") Q
S:RFN RFD=$E($P(RF,"^"),1,7) S:'RFN RFD=$P(PSOX("RX3"),"^")
I SUPN,RFD,$D(^PS(52.5,"C",RFD,SUPN)),$G(^PS(52.5,SUPN,"P"))=1 Q
S PSOX("FILL DATE")=$P(PSOX("RX3"),"^")
Q
;
PSOUTIL ;IHS/DSD/JCM - outpatient pharmacy utility routine ;29-May-2012 15:16;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**64,1013,1015**;DEC 1997;Build 62
+2 ; Modified - IHS/MSC/PLS - 11/07/2011 - Line PROV+17
+3 WRITE !!,$CHAR(7),"This routine not callable from PSOUTIL.."
+4 QUIT
+5 ;
NPSOSD(PSORX) ; Entry point to add newly added rx to patients PSOSD array
+1 SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
+2 SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(PSORX("IRXN"),"STA"),"^")+1)
+3 IF $DATA(PSOSD(STAT,PSODRUG("NAME")))
IF $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^",2)<10
Begin DoDot:1
+4 SET PSOSD(STAT,PSODRUG("NAME")_"^"_PSORX("IRXN"))=PSORX("IRXN")_"^"_$PIECE($GET(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0)
,"^",8)_"^1"
End DoDot:1
+5 IF '$TEST
SET PSOSD(STAT,PSODRUG("NAME"))=PSORX("IRXN")_"^"_$PIECE($GET(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0),"^",8)_"^1"
+6 SET PSOSD=$SELECT($GET(PSOSD)]"":PSOSD+1,1:1)
SET ^TMP("PS",$JOB,STAT,PSODRUG("NAME"))=1
+7 QUIT
+8 ;
RNPSOSD ;update PSOSD array for renewals
+1 SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
+2 SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(PSORENW("OIRXN"),"STA"),"^")+1)
+3 IF $DATA(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN")))
Begin DoDot:1
+4 SET PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN"))=PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN"))
SET $PIECE(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",2)=$PIECE($GET(^PSRX(PSORENW("IRXN"),"STA")),"^")
+5 SET $PIECE(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",6)=$PIECE(^PSRX(PSORENW("IRXN"),0),"^",9)
+6 KILL PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN"))
QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^")=PSORENW("IRXN")
SET $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^",2)=$PIECE($GET(^PSRX(PSORENW("IRXN"),"STA")),"^")
+9 SET $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^",6)=$PIECE(^PSRX(PSORENW("IRXN"),0),"^",9)
+10 SET ^TMP("PS",$JOB,STAT,PSODRUG("NAME"))=1
End DoDot:1
+11 QUIT
+12 ;
PROV(PSORENW) ;called from psoornew
CHKPRV ;check inactive providers and cosinging providers called from PSORENW (renew rx)
+1 IF '$DATA(^VA(200,PSORENW("PROVIDER"),0))
Begin DoDot:1
+2 WRITE !,$CHAR(7),"Provider not in New Person File .. You must select a new provider"
+3 SET PSODIR("FIELD")=0
KILL PSORENW("PROVIDER")
DO PROV^PSODIR(.PSORENW)
+4 IF $GET(PSORENW("PROVIDER"))']""
SET PSORENW("DFLG")=1
End DoDot:1
IF PSORENW("DFLG")
GOTO CHKPRVX
+5 ;
+6 IF '$GET(^VA(200,PSORENW("PROVIDER"),"PS"))
Begin DoDot:1
+7 WRITE !,$CHAR(7),$PIECE(^VA(200,PSORENW("PROVIDER"),0),"^")_" is not a Valid provider .. You must select a new provider"
+8 SET PSODIR("FIELD")=0
KILL PSORENW("PROVIDER")
DO PROV^PSODIR(.PSORENW)
+9 IF $GET(PSORENW("PROVIDER"))']""
SET PSORENW("DFLG")=1
End DoDot:1
IF PSORENW("DFLG")
GOTO CHKPRVX
+10 ;
+11 KILL PSOX
SET PSOX=$PIECE($GET(^VA(200,PSORENW("PROVIDER"),"PS")),"^",4)
+12 IF PSOX
IF PSOX<DT
Begin DoDot:1
+13 WRITE !,$CHAR(7),$PIECE(^VA(200,PSORENW("PROVIDER"),0),"^")_" is inactive as a provider .. You must select a new provider"
+14 SET PSODIR("FIELD")=0
KILL PSORENW("PROVIDER")
DO PROV^PSODIR(.PSORENW)
+15 IF $GET(PSORENW("PROVIDER"))']""
SET PSORENW("DFLG")=1
End DoDot:1
IF PSORENW("DFLG")
GOTO CHKPRVX
+16 ;IHS/MSC/PLS - 11/07/2011
+17 NEW CLOZPAT,APSPDIEN
+18 SET APSPDIEN=$SELECT($GET(PSORENW("DRUG IEN")):PSORENW("DRUG IEN"),$GET(PSODRUG("IEN")):PSODRUG("IEN"),1:0)
+19 SET CLOZPAT=$SELECT($PIECE($GET(^PSDRUG(APSPDIEN,"CLOZ1")),"^")="PSOCLO1":1,1:0)
+20 IF APSPDIEN
IF $$ISSCH^APSPFNC2(APSPDIEN,"2345")!($GET(CLOZPAT))
Begin DoDot:1
+21 IF '$LENGTH($PIECE($GET(^VA(200,+PSORENW("PROVIDER"),"PS")),U,2))
IF '$LENGTH($PIECE($GET(^VA(200,+PSORENW("PROVIDER"),"PS")),U,3))
Begin DoDot:2
+22 WRITE $CHAR(7),!!,"Provider must have a DEA# or VA#"_$SELECT($GET(CLOZPAT):" to write prescriptions for clozapine.",1:"."),!
+23 SET PSODIR("FIELD")=0
KILL PSORENW("PROVIDER")
DO PROV^PSODIR(.PSORENW)
+24 IF $GET(PSORENW("PROVIDER"))']""
SET PSORENW("DFLG")=1
End DoDot:2
End DoDot:1
IF PSORENW("DFLG")
GOTO CHKPRVX
+25 ;
+26 IF '$DATA(PSORENW("COSIGNING PROVIDER"))
IF $DATA(PSORENW("COSIGNER"))
KILL PSOX
SET PSOX=$PIECE(^VA(200,PSORENW("COSIGNER"),"PS"),"^",4)
IF PSOX
IF PSOX<DT
Begin DoDot:1
+27 WRITE !,$CHAR(7),"Inactive Cosigning Provider .. You must select a new cosigner"
+28 SET PSODIR("FIELD")=0
SET PSODIR("PROVIDER")=$SELECT($DATA(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:PSORENW("PROVIDER"))
+29 DO COSIGN^PSODIR
IF '$DATA(PSODIR("COSIGNING PROVIDER"))
SET PSORENW("DFLG")=1
+30 SET PSORENW("COSIGNING PROVIDER")=PSODIR("COSIGNING PROVIDER")
End DoDot:1
+31 ;
CHKPRVX KILL PSODIR,PSOX
+1 QUIT
+2 ;
NEXT(PSOX) ;
+1 SET PSOX("RX0")=^PSRX(PSOX("IRXN"),0)
+2 SET PSOX("RX2")=^PSRX(PSOX("IRXN"),2)
+3 SET PSOX("RX3")=^PSRX(PSOX("IRXN"),3)
+4 SET PSOX1=$PIECE(PSOX("RX2"),"^",2)
+5 IF '$ORDER(^PSRX(PSOX("IRXN"),1,0))
Begin DoDot:1
+6 SET $PIECE(PSOX("RX3"),"^")=PSOX1
SET X1=PSOX1
+7 SET X2=$PIECE(PSOX("RX0"),"^",8)-10\1
+8 DO C^%DTC
+9 IF '$PIECE(PSOX("RX3"),"^",8)
SET $PIECE(PSOX("RX3"),"^",2)=X
+10 KILL X
QUIT
End DoDot:1
GOTO NEXTX
+11 ;
+12 SET PSOY2=0
+13 FOR PSOY=0:0
SET PSOY=$ORDER(^PSRX(PSOX("IRXN"),1,PSOY))
IF 'PSOY
QUIT
SET PSOY1=PSOY
SET PSOY2=PSOY2+1
+14 SET PSOY=^PSRX(PSOX("IRXN"),1,PSOY1,0)
+15 SET PSOX2=$PIECE(PSOY,"^")
+16 SET $PIECE(PSOX("RX3"),"^")=PSOX2
SET X1=PSOX2
+17 SET X2=$PIECE(PSOX("RX0"),"^",8)-10\1
+18 DO C^%DTC
SET PSOY3=X
+19 SET X1=PSOX1
SET X2=(PSOY2+1)*$PIECE(PSOX("RX0"),"^",8)-10\1
+20 DO C^%DTC
SET PSOY4=X
+21 SET $PIECE(PSOX("RX3"),"^",2)=$SELECT(PSOY3<PSOY4:PSOY4,1:PSOY3)
NEXTX ;
+1 KILL X,PSOX1,PSOX2,PSOY,PSOY1,PSOY2,PSOY3,PSOY4
+2 QUIT
+3 ;
SUSDATE(PSOX) ;
+1 SET PSOX("OLD FILL DATE")=PSOX("FILL DATE")
+2 SET PSORX("OLD FILL DATE")=PSORX("FILL DATE")
+3 SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^",2)
+4 IF $ORDER(^PS(52.5,"B",PSOX("IRXN"),0))
IF '$GET(^PS(52.5,+$ORDER(^PS(52.5,"B",PSOX("IRXN"),0)),"P"))
SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^")
+5 SET Y=PSOX("FILL DATE")
+6 XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
KILL Y
+7 QUIT
+8 ;
SUSDATEK(PSOX) ;
+1 SET PSOX("FILL DATE")=PSOX("OLD FILL DATE")
+2 IF $GET(PSORX("OLD FILL DATE"))=""
IF $GET(PSORENW("OLD FILL DATE"))
SET Y=PSORENW("OLD FILL DATE")
DO DD^%DT
SET PSORX("OLD FILL DATE")=Y
KILL Y
+3 SET PSORX("FILL DATE")=PSORX("OLD FILL DATE")
+4 KILL PSOX("OLD FILL DATE"),PSORX("OLD FILL DATE")
+5 QUIT
+6 ;
STATUS(PSOREA,PSOSTAT) ;
+1 SET DSMSG="Cannot "_$SELECT($GET(PSOOPT)=3:"renew",1:"refill")_" Rx. "
IF $GET(OR0)
SET ACOM=DSMSG
+2 IF PSOREA["A"
IF $GET(SPEED)
WRITE ", Inactive Drug.",!
Begin DoDot:1
+3 IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Inactive Drug."
SET VALMBCK="R"
IF '$GET(POERR)
WRITE !," Inactive Drug"
+4 IF $GET(OR0)
SET ACOM=ACOM_" Inactive Drug."
End DoDot:1
+5 IF PSOREA["M"
IF $GET(SPEED)
WRITE ", Drug no longer used by Outpatient.",!
Begin DoDot:1
+6 IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Drug no longer used by Outpatient."
SET VALMBCK="R"
IF '$GET(POERR)
WRITE !," Drug no longer used by Outpatient."
+7 IF $GET(OR0)
SET ACOM=ACOM_" Drug no longer used by Outpatient."
End DoDot:1
+8 ;
+9 IF PSOREA["B"
IF $GET(SPEED)
WRITE ", Narcotic Drug."
Begin DoDot:1
+10 IF '$GET(POERR)
WRITE !,"Narcotic Drug"
IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Narcotic Drug."
SET VALMBCK="R"
+11 IF $GET(OR0)
SET ACOM=ACOM_" Narcotic Drug."
End DoDot:1
+12 ;
+13 IF PSOREA["C"
IF $GET(SPEED)
WRITE ", Non-Renewable Drug."
Begin DoDot:1
+14 IF '$GET(POERR)
WRITE !,"Non-Renewable Drug"
IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Non-Renewable Drug."
SET VALMBCK="R"
+15 IF $GET(OR0)
SET ACOM=ACOM_" Non-Renewable Drug."
End DoDot:1
+16 ;
+17 IF PSOREA["D"
IF $GET(SPEED)
WRITE ", Non-Renewable Patient Status."
Begin DoDot:1
+18 IF '$GET(POERR)
WRITE !,"Non-Renewable Patient Status"
IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Non-Renewable Patient Status."
SET VALMBCK="R"
+19 IF $GET(OR0)
SET ACOM=ACOM_" Non-Renewable Patient Status."
End DoDot:1
+20 ;
+21 IF PSOREA["E"
IF $GET(SPEED)
WRITE ", Non-Verified Rx."
Begin DoDot:1
+22 IF '$GET(POERR)
WRITE !,"Non-Verified Rx"
IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Non-Verified Rx."
SET VALMBCK="R"
+23 IF $GET(OR0)
SET ACOM=ACOM_" Non-Verified Rx."
End DoDot:1
+24 ;
+25 IF PSOREA["F"
IF $GET(SPEED)
WRITE ", Maximum of 26 Renewals."
Begin DoDot:1
+26 IF '$GET(POERR)
WRITE !,"Maximum of 26 Renewals"
IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Maximum of 26 Renewals."
SET VALMBCK="R"
+27 IF $GET(OR0)
SET ACOM=ACOM_" Maximum of 26 Renewals."
End DoDot:1
+28 ;
+29 IF PSOREA["G"
IF PSOREA'["B"
IF $GET(SPEED)
WRITE ", No more refills left."
IF '$GET(POERR)
WRITE !,"No more refills left"
IF $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"No more refills left."
SET VALMBCK="R"
+30 ;
+31 IF PSOREA["Z"
Begin DoDot:1
+32 IF PSOSTAT=4
SET PSOSTAT=1
+33 SET PSOA=";"_PSOSTAT
SET PSOB=$PIECE(^DD(52,100,0),"^",3)
SET PSOA=$FIND(PSOB,PSOA)
SET PSOA=$PIECE($EXTRACT(PSOB,PSOA,999),";",1)
+34 IF $GET(SPEED)
WRITE ", Rx is in "_$PIECE(PSOA,":",2)_" status."
+35 IF '$GET(POERR)&('$GET(SPEED))
WRITE !,"Rx is in "_$PIECE(PSOA,":",2)_" status"
+36 IF $GET(POERR)&($GET(VALMSG)']"")&('$GET(SPEED))
SET VALMSG=DSMSG_"Rx is in "_$PIECE(PSOA,":",2)_" status."
SET VALMBCK="R"
+37 KILL PSOA,PSOB
+38 QUIT
End DoDot:1
+39 IF $GET(SPEED)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIRUT,DUOUT,DTOUT,DIR
+40 QUIT
ACP IF $PIECE(^PSRX(PSOX("IRXN"),0),"^",11)="W"
IF $GET(^("IB"))
SET ^PSRX("ACP",$PIECE(^PSRX(PSOX("IRXN"),0),"^",2),$PIECE(^(2),"^",2),0,PSOX("IRXN"))=""
+1 QUIT
+2 ;
RENFDT(PSOX) ;gets the correct fill date
+1 SET PSOX("OLD FILL DATE")=PSOX("FILL DATE")
+2 SET PSORX("OLD FILL DATE")=PSORX("FILL DATE")
+3 SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^",2)
+4 NEW RXY,LBL,SUPN,LBP,RF,RFN,RFD
+5 SET RXY=PSOX("IRXN")
SET RFN=0
+6 IF '$ORDER(^PSRX(RXY,1,0))
DO GFDT
GOTO SDTX
+7 FOR RF=0:0
SET RF=$ORDER(^PSRX(RXY,1,RF))
IF 'RF
QUIT
SET RFN=RF
+8 SET RF=^PSRX(RXY,1,RFN,0)
DO GFDT
+9 IF PSOX("FILL DATE")<DT
IF PSOX("FILL DATE")<PSORNW("FILL DATE")
SET PSOX("FILL DATE")=DT
SDTX ;
+1 SET Y=PSOX("FILL DATE")
+2 XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
KILL Y
+3 QUIT
GFDT ;
+1 IF 'RFN
IF $PIECE(^PSRX(RXY,2),"^",13)
QUIT
+2 IF RFN
IF $PIECE(RF,"^",18)
QUIT
+3 FOR LBL=0:0
SET LBL=$ORDER(^PSRX(RXY,"L",LBL))
IF 'LBL
QUIT
IF $PIECE(^PSRX(RXY,"L",LBL,0),"^",2)=RFN
SET LBP=1
QUIT
+4 IF $GET(LBP)
QUIT
+5 SET SUPN=$ORDER(^PS(52.5,"B",RXY,0))
+6 IF SUPN
IF $PIECE($GET(^PS(52.5,SUPN,0)),"^",7)="L"!($PIECE($GET(^(0)),"^",7)="X")
QUIT
+7 IF RFN
SET RFD=$EXTRACT($PIECE(RF,"^"),1,7)
IF 'RFN
SET RFD=$PIECE(PSOX("RX3"),"^")
+8 IF SUPN
IF RFD
IF $DATA(^PS(52.5,"C",RFD,SUPN))
IF $GET(^PS(52.5,SUPN,"P"))=1
QUIT
+9 SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^")
+10 QUIT
+11 ;