- 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 ;
