- PSOCAN ;BIR/JMB - Rx discontinue and reinstate ;12/03/18 10:47
- ;;7.0;OUTPATIENT PHARMACY;**11,21,24,27,32,37,88,117,131,185,253,251,375,379,390,413,372,416,508,477,617**;DEC 1997;Build 110
- ;External reference to File #55 supported by DBIA 2228
- ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
- START N PSOODOSP,PSOREINF,PSOONOFC S WARN=0,(DAYS360,SPCANC)=1 D KCAN1^PSOCAN3 W !! S DIR("A")="Discontinue/Reinstate by Rx# or patient name",DIR(0)="SBO^R:RX NUMBER;P:PATIENT NAME"
- S DIR("?")="Enter 'R' to discontinue/reinstate by Rx#. Enter 'P' to discontinue/reinstate by patient name." D ^DIR K DIR
- G:$G(DIRUT) KILL^PSOCAN1 K RP S RP=Y G:RP="P" PAT^PSOCAN1
- NUM D DCORD^PSONEW2
- K PSOTECCK,RXSP,PSINV,PSOWUN,PSOULRX,PSORX("DFLG") D KCAN1^PSOCAN3 S:'$D(PSOCLC) PSOCLC=DUZ S PS="Discontinue" W ! S DIR("A")="Discontinue/Reinstate Prescription(s)#"
- S DIR(0)="FO^1:245",DIR("?")="Wand/enter barcode or enter Rx number(s) to discontinued/reinstated. If more than one, separate with commas. Do not exceed 245 characters including commas"
- D ^DIR K DIR G:$G(DIRUT) START S OUT=0 I Y["-" D PSOINST^PSOSUPAT G:OUT NUM S (IN,X)=$P(^PSRX($P(Y,"-",2),0),"^") G NO
- S IN=Y G RX:Y[","
- NO I '$O(^PSRX("B",Y,0)) W " Rx Not Found!",! G NUM
- S PSPOP=0,DIC=52,DIC(0)="QEMZ" D ^DIC K DIC Q:$G(POERR)&(Y<0)
- G:Y<0 NUM S (DA,IFN,PSOULRX)=+Y,RXNUM=Y(0,0),PSODFN=+$P(^PSRX(DA,0),"^",2) I PSODFN'=$G(PSOODOSP) K PSORX("DOSING OFF"),PSOREINF S PSOODOSP=PSODFN
- S PSOWUN=1 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G NUM
- K PSOPLCK D PSOL^PSSLOCK(IFN) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.") K PSOMSG D ULP G NUM
- I $P($G(^PSRX(+$G(IFN),"STA")),"^")=12,$P($G(^("PKI")),"^")!$P($G(^("PKI")),"^",3) W !!,"Cannot be Reinstated - Digitally Signed" D ULP G NUM
- I $P($G(^PSRX(+$G(IFN),"STA")),"^")=12 S PSOCANRZ=1
- E S PSOCANRD=+$P($G(^PSRX(+$G(IFN),0)),"^",4)
- D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN)
- LMNO D CHK S:'$G(DA)&($G(IFN)) DA=IFN
- I DEAD S PSINV($P(^PSRX(DA,0),"^"))="" D:$G(PSOWUN) ULP,ULRX G EP1
- I $P(^PSRX(DA,"STA"),"^")'<13,$P(^("STA"),"^")'=16 S PSINV($P(^PSRX(DA,0),"^"))="" D:$G(PSOWUN) ULP,ULRX G EP1
- I $G(PSODIV),$P($G(^PSRX(DA,2)),"^",9),$P(^(2),"^",9)'=$G(PSOSITE) S RXREC=DA D DIV D:$G(POERR)&(PSPOP) ULP,ULRX Q:$G(POERR)&(PSPOP) D:$G(PSOWUN)&($G(PSPOP)) ULP,ULRX G:PSPOP NUM
- D ICN^PSODPT(PSODFN)
- N PSTS S PSTS=$S($P(^PSRX(DA,"STA"),"^")=12:1,$P(^PSRX(DA,"STA"),"^")=14:1,$P(^PSRX(DA,"STA"),"^")=15:1,1:0)
- S PS=$S($G(PSTS):"Reinstate",1:"Discontinue")
- I PS="Reinstate",$$CONJ^PSOUTL(DA) W !!,"Cannot be Reinstated - dosage contains an invalid Except conjunction",! D PAUSE^VALM1,ULP,ULRX G EP1
- ;S PS=$S($P(^PSRX(DA,"STA"),"^")=12:"Reinstate",1:"Discontinue")
- I '$G(POERR) N PKIR D
- .I $P(^PSRX(DA,"STA"),"^")=1,$P($G(^("PKI")),"^") S PKIR=""
- .D ^PSORXPR
- D:$G(PSORX("DFLG")) ULP,ULRX
- Q:$G(POERR)&($G(PSORX("DFLG")))
- G NUM:$G(PSORX("DFLG"))
- D YN S:PS="Reinstate" PS="Discontinue" Q:$G(POERR)&('%)
- I '% D ULP,ULRX G NUM
- D REA D:'$D(REA)&($G(PSOWUN)) ULP,ULRX Q:'$D(REA)
- D COM^PSOCAN1 Q:$G(POERR)&('$D(INCOM))!($D(DIRUT)) I '$D(INCOM)!($D(DIRUT)) D ULP,ULRX G NUM
- S RX=$P(^PSRX(DA,0),"^"),PSCAN(RX)=DA_"^"_REA
- D:REA="R" REINS^PSOCAN2 Q:$G(PSOQUIT)&($G(PSOREINS))
- I REA="R",'$G(PSORX("DFLG")) D DCORD^PSONEW2
- K PSOTECCK
- D:REA="C" CAN
- Q:$G(POERR)
- D ULP,ULRX G NUM
- YN D EN^PSOCMOPA I $G(XFLAG)]"" S %=0 K XFLAG Q
- ; PSO*7*508 - if this is an eRx auto DC, set the flag to prevent prompt and quit
- I $G(ERXDCIEN) S %=1 Q
- W ! S DIR("A")="Are you sure you want to "_PS,DIR(0)="Y",DIR("B")="NO" D ^DIR S %=Y K DIR,DUOUT,DTOUT I 'Y!$D(DIRUT) S VALMBCK="R"
- K DIRUT Q
- REA ;
- ;PSO*7*508 - if this is an eRx, we are cancelling only. Set REA and quit
- I $G(ERXDCIEN) D Q
- .I +$P(^PSRX(DA,"STA"),U)=12 Q
- .S REA="C"
- S REA=+$P(^PSRX(DA,"STA"),"^") I REA=12 S REA="R" Q
- I REA,REA'=11 W !?5,$C(7) D
- .W "Rx# "_RXNUM_" was"_$S(REA=1:" Non-Verified",REA=13:" Deleted",REA=11:" Expired",REA=5:" Suspended",REA=4:" Pending Due to Drug Interactions",REA=3:" On Hold",REA=14!(REA=15):" Discontinued",REA=16:" Provider Held",1:" In Fill Status")_"."
- I REA,REA'=1,REA'=3,REA'=5,REA'=11,REA'<13,REA'=16 D Q
- .K REA W !?10,"Rx Cannot Be Discontinued/Reinstated!" H 2
- .S VALMSG="Rx# "_RXNUM_" Cannot Be "_$S($G(PSTS):"Reinstated",1:"Discontinued")_"."
- S REA="C" Q
- CAN N PSODRUG D CAN1^PSOCAN3 Q
- DIV I '$P($G(PSOSYS),"^",2) W !?10,$C(7),"RX# ",$P(^PSRX(DA,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q
- I $P($G(PSOSYS),"^",3) W !?10,$C(7) S DIR("A")="RX# "_$P(^PSRX(DA,0),"^")_" is from another division. Continue",DIR(0)="Y",DIR("B")="Y" D ^DIR K DIR S:$G(DIRUT)!('Y) PSPOP=1
- Q
- CHK K VADM,DEAD S DFN=PSODFN D DEM^VADPT I $G(VADM(6))="" S DEAD=0 Q
- S (PSODEATH,DEAD)=1 W !!,?10,VADM(1)_" DIED "_$P($G(VADM(6)),"^",2) D CAN^PSOCAN3 K PSODEATH
- Q
- RX N PKI S RXCNT=0,RXSP=1 D TESTRP D COM^PSOCAN1 G:'$D(INCOM)!($D(DIRUT)) NUM K PSINV,PSCAN F II=1:1 S (EN,X)=$P(IN,",",II) Q:$P(IN,",",II)']"" S DIC=52,DIC(0)="QMZ" D ^DIC K DIC S:Y'>0 PSINV(X)="" D:Y>0
- .S YY=Y,YY(0,0)=Y(0,0),(PSODFN,DFN)=$P(Y(0),"^",2) D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN)
- .D:$G(DFN)>0 CHK I DEAD!($P(^PSRX(+YY,"STA"),"^")=13)!($P(^("STA"),"^")=14) S PSINV(EN)="" Q
- .I $P(^PSRX(+YY,"STA"),"^")=12,$P($G(^("PKI")),"^") S PKI=1,PSINV(EN)="" Q
- .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP
- .S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
- .;S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP Q
- .;E S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
- K YY G:'$D(PSCAN) INVALD^PSOCAN1 S RX="",RXCNT=0 F S RX=$O(PSCAN(RX)) Q:RX="" S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),RXCNT=RXCNT+1 D SHOW^PSOCAN1
- ASK Q:'$D(PSCAN) W ! S DIR("A")="OK to "_$S($G(RXCNT)>1:"Change Status",REA="C":"Discontinued",1:"Reinstate"),DIR(0)="Y",DIR("B")="N"
- N PSOCNRXV S PSOCNRXV=0
- D ^DIR K DIR Q:$G(DIRUT) I 'Y K PSCAN D INVALD^PSOCAN1 G NUM
- K PSOPLCKZ S RX="" F S RX=$O(PSCAN(RX)) Q:'RX D
- .S PSODFN=+$P($G(^PSRX(+PSCAN(RX),0)),"^",2)
- .S PSOPLCK=$$L^PSSLOCK(+$G(PSODFN),0) D:'$G(PSOPLCK)&('$D(PSOPLCKZ(PSODFN))) LOCK^PSOORCPY I '$G(PSOPLCK) S PSOPLCKZ(PSODFN)=PSODFN Q
- .D PSOL^PSSLOCK(+PSCAN(RX)) I '$G(PSOMSG) D D UL^PSSLOCK(PSODFN) Q
- ..I $P($G(PSOMSG),"^",2)'="" W !,$P($G(PSOMSG),"^",2),!,"Order "_$P($G(^PSRX(+PSCAN(RX),0)),"^")_"." Q
- ..W !,"Another person is editing order "_$P($G(^PSRX(+PSCAN(RX),0)),"^")_"."
- .D ACT D PSOUL^PSSLOCK(+PSCAN(RX)),UL^PSSLOCK(PSODFN)
- .S PSOCNRXV=1
- K PSOPLCKZ W:$G(PSOCNRXV) !,$S($G(RXCNT)>1:"Statuses Changed",REA="C":"Prescription Discontinued",1:"Prescription Reinstated") D INVALD^PSOCAN1 G NUM
- ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
- D CAN Q
- EXP ;S PSINV($P(^PSRX(DA,0),"^"))=""
- Q:$P(^PSRX(DA,"STA"),"^")=12
- S $P(^PSRX(DA,"STA"),"^")=11 D ECAN^PSOUTL(DA)
- S STAT="SC",PHARMST="ZE",COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,STAT,PHARMST,COMM) K COMM,STAT,PHARMST
- EP1 I '$G(RXSP) D INVALD^PSOCAN1 Q:$G(POERR) G NUM
- Q
- PSD ;Called from Controlled Subs, PSDRX is internal Rx number
- S PSDRFDEL=0
- I '$G(PSDRX)!('$D(^PSRX(+$G(PSDRX),0))) Q
- I $P($G(^PSRX(PSDRX,"STA")),"^")<12 Q
- N DA,NODE,RF,PSOPSDAL,PSODRX,PSODTE,PSODL,SFN,RIFN,PSOSXP,PSOFILDL
- S PSODRX=0 F PSODLP=0:0 S PSODLP=$O(^PSRX(PSDRX,1,PSODLP)) Q:'PSODLP S:$D(^PSRX(PSDRX,1,PSODLP,0)) PSODRX=PSODLP
- I 'PSODRX Q
- I $P($G(^PSRX(PSDRX,1,PSODRX,0)),"^",18) Q
- D PSDREF I $G(PSOFILDL) K PSOFILDL Q
- K PSOFILDL,DIE S NODE=0,PSOPSDAL=1,DA(1)=PSDRX,DA=PSODRX,DIE="^PSRX("_DA(1)_",1,",DR=".01///@" D ^DIE K DIE
- S PSDRFDEL=1
- Q
- PSDREF ;
- N PRDL,PSOCNODE
- S PSOFILDL=0
- F PRDL=0:0 S PRDL=$O(^PSRX(PSDRX,4,PRDL)) Q:'PRDL I $G(PSODRX)=$P($G(^PSRX(PSDRX,4,PRDL,0)),"^",3) S PSOCNODE=$G(^(0))
- I $G(PSOCNODE)="" Q
- I +$P(PSOCNODE,"^",4)<3 S PSOFILDL=1
- Q
- TESTRP ;
- N PIIN,PIINFLAG S PIINFLAG=0 F PIIN=1:1 S X=$P(IN,",",PIIN) Q:$P(IN,",",PIIN)']"" K DIC S DIC=52,DIC(0)="QMZ" D ^DIC K DIC I +$G(Y) D
- .I $P($G(^PSRX(+Y,"STA")),"^")'=12,'$G(PIINFLAG) S PSOCANRD=+$P($G(^PSRX(+Y,0)),"^",4) S PIINFLAG=1
- I '$G(PIINFLAG) S PSOCANRZ=1
- Q
- ULP ;
- D UL^PSSLOCK(+$G(PSODFN))
- Q
- ULRX ;
- I $G(PSOULRX) D PSOUL^PSSLOCK(PSOULRX)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN 8480 printed Jan 18, 2025@03:26:20 Page 2
- PSOCAN ;BIR/JMB - Rx discontinue and reinstate ;12/03/18 10:47
- +1 ;;7.0;OUTPATIENT PHARMACY;**11,21,24,27,32,37,88,117,131,185,253,251,375,379,390,413,372,416,508,477,617**;DEC 1997;Build 110
- +2 ;External reference to File #55 supported by DBIA 2228
- +3 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
- START NEW PSOODOSP,PSOREINF,PSOONOFC
- SET WARN=0
- SET (DAYS360,SPCANC)=1
- DO KCAN1^PSOCAN3
- WRITE !!
- SET DIR("A")="Discontinue/Reinstate by Rx# or patient name"
- SET DIR(0)="SBO^R:RX NUMBER;P:PATIENT NAME"
- +1 SET DIR("?")="Enter 'R' to discontinue/reinstate by Rx#. Enter 'P' to discontinue/reinstate by patient name."
- DO ^DIR
- KILL DIR
- +2 if $GET(DIRUT)
- GOTO KILL^PSOCAN1
- KILL RP
- SET RP=Y
- if RP="P"
- GOTO PAT^PSOCAN1
- NUM DO DCORD^PSONEW2
- +1 KILL PSOTECCK,RXSP,PSINV,PSOWUN,PSOULRX,PSORX("DFLG")
- DO KCAN1^PSOCAN3
- if '$DATA(PSOCLC)
- SET PSOCLC=DUZ
- SET PS="Discontinue"
- WRITE !
- SET DIR("A")="Discontinue/Reinstate Prescription(s)#"
- +2 SET DIR(0)="FO^1:245"
- SET DIR("?")="Wand/enter barcode or enter Rx number(s) to discontinued/reinstated. If more than one, separate with commas. Do not exceed 245 characters including commas"
- +3 DO ^DIR
- KILL DIR
- if $GET(DIRUT)
- GOTO START
- SET OUT=0
- IF Y["-"
- DO PSOINST^PSOSUPAT
- if OUT
- GOTO NUM
- SET (IN,X)=$PIECE(^PSRX($PIECE(Y,"-",2),0),"^")
- GOTO NO
- +4 SET IN=Y
- if Y[","
- GOTO RX
- NO IF '$ORDER(^PSRX("B",Y,0))
- WRITE " Rx Not Found!",!
- GOTO NUM
- +1 SET PSPOP=0
- SET DIC=52
- SET DIC(0)="QEMZ"
- DO ^DIC
- KILL DIC
- if $GET(POERR)&(Y<0)
- QUIT
- +2 if Y<0
- GOTO NUM
- SET (DA,IFN,PSOULRX)=+Y
- SET RXNUM=Y(0,0)
- SET PSODFN=+$PIECE(^PSRX(DA,0),"^",2)
- IF PSODFN'=$GET(PSOODOSP)
- KILL PSORX("DOSING OFF"),PSOREINF
- SET PSOODOSP=PSODFN
- +3 SET PSOWUN=1
- SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
- IF '$GET(PSOPLCK)
- DO LOCK^PSOORCPY
- KILL PSOPLCK
- GOTO NUM
- +4 KILL PSOPLCK
- DO PSOL^PSSLOCK(IFN)
- IF '$GET(PSOMSG)
- WRITE !!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
- KILL PSOMSG
- DO ULP
- GOTO NUM
- +5 IF $PIECE($GET(^PSRX(+$GET(IFN),"STA")),"^")=12
- IF $PIECE($GET(^("PKI")),"^")!$PIECE($GET(^("PKI")),"^",3)
- WRITE !!,"Cannot be Reinstated - Digitally Signed"
- DO ULP
- GOTO NUM
- +6 IF $PIECE($GET(^PSRX(+$GET(IFN),"STA")),"^")=12
- SET PSOCANRZ=1
- +7 IF '$TEST
- SET PSOCANRD=+$PIECE($GET(^PSRX(+$GET(IFN),0)),"^",4)
- +8 if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
- DO EN^PSOHLUP(PSODFN)
- LMNO DO CHK
- if '$GET(DA)&($GET(IFN))
- SET DA=IFN
- +1 IF DEAD
- SET PSINV($PIECE(^PSRX(DA,0),"^"))=""
- if $GET(PSOWUN)
- DO ULP
- DO ULRX
- GOTO EP1
- +2 IF $PIECE(^PSRX(DA,"STA"),"^")'<13
- IF $PIECE(^("STA"),"^")'=16
- SET PSINV($PIECE(^PSRX(DA,0),"^"))=""
- if $GET(PSOWUN)
- DO ULP
- DO ULRX
- GOTO EP1
- +3 IF $GET(PSODIV)
- IF $PIECE($GET(^PSRX(DA,2)),"^",9)
- IF $PIECE(^(2),"^",9)'=$GET(PSOSITE)
- SET RXREC=DA
- DO DIV
- if $GET(POERR)&(PSPOP)
- DO ULP
- DO ULRX
- if $GET(POERR)&(PSPOP)
- QUIT
- if $GET(PSOWUN)&($GET(PSPOP))
- DO ULP
- DO ULRX
- if PSPOP
- GOTO NUM
- +4 DO ICN^PSODPT(PSODFN)
- +5 NEW PSTS
- SET PSTS=$SELECT($PIECE(^PSRX(DA,"STA"),"^")=12:1,$PIECE(^PSRX(DA,"STA"),"^")=14:1,$PIECE(^PSRX(DA,"STA"),"^")=15:1,1:0)
- +6 SET PS=$SELECT($GET(PSTS):"Reinstate",1:"Discontinue")
- +7 IF PS="Reinstate"
- IF $$CONJ^PSOUTL(DA)
- WRITE !!,"Cannot be Reinstated - dosage contains an invalid Except conjunction",!
- DO PAUSE^VALM1
- DO ULP
- DO ULRX
- GOTO EP1
- +8 ;S PS=$S($P(^PSRX(DA,"STA"),"^")=12:"Reinstate",1:"Discontinue")
- +9 IF '$GET(POERR)
- NEW PKIR
- Begin DoDot:1
- +10 IF $PIECE(^PSRX(DA,"STA"),"^")=1
- IF $PIECE($GET(^("PKI")),"^")
- SET PKIR=""
- +11 DO ^PSORXPR
- End DoDot:1
- +12 if $GET(PSORX("DFLG"))
- DO ULP
- DO ULRX
- +13 if $GET(POERR)&($GET(PSORX("DFLG")))
- QUIT
- +14 if $GET(PSORX("DFLG"))
- GOTO NUM
- +15 DO YN
- if PS="Reinstate"
- SET PS="Discontinue"
- if $GET(POERR)&('%)
- QUIT
- +16 IF '%
- DO ULP
- DO ULRX
- GOTO NUM
- +17 DO REA
- if '$DATA(REA)&($GET(PSOWUN))
- DO ULP
- DO ULRX
- if '$DATA(REA)
- QUIT
- +18 DO COM^PSOCAN1
- if $GET(POERR)&('$DATA(INCOM))!($DATA(DIRUT))
- QUIT
- IF '$DATA(INCOM)!($DATA(DIRUT))
- DO ULP
- DO ULRX
- GOTO NUM
- +19 SET RX=$PIECE(^PSRX(DA,0),"^")
- SET PSCAN(RX)=DA_"^"_REA
- +20 if REA="R"
- DO REINS^PSOCAN2
- if $GET(PSOQUIT)&($GET(PSOREINS))
- QUIT
- +21 IF REA="R"
- IF '$GET(PSORX("DFLG"))
- DO DCORD^PSONEW2
- +22 KILL PSOTECCK
- +23 if REA="C"
- DO CAN
- +24 if $GET(POERR)
- QUIT
- +25 DO ULP
- DO ULRX
- GOTO NUM
- YN DO EN^PSOCMOPA
- IF $GET(XFLAG)]""
- SET %=0
- KILL XFLAG
- QUIT
- +1 ; PSO*7*508 - if this is an eRx auto DC, set the flag to prevent prompt and quit
- +2 IF $GET(ERXDCIEN)
- SET %=1
- QUIT
- +3 WRITE !
- SET DIR("A")="Are you sure you want to "_PS
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- DO ^DIR
- SET %=Y
- KILL DIR,DUOUT,DTOUT
- IF 'Y!$DATA(DIRUT)
- SET VALMBCK="R"
- +4 KILL DIRUT
- QUIT
- REA ;
- +1 ;PSO*7*508 - if this is an eRx, we are cancelling only. Set REA and quit
- +2 IF $GET(ERXDCIEN)
- Begin DoDot:1
- +3 IF +$PIECE(^PSRX(DA,"STA"),U)=12
- QUIT
- +4 SET REA="C"
- End DoDot:1
- QUIT
- +5 SET REA=+$PIECE(^PSRX(DA,"STA"),"^")
- IF REA=12
- SET REA="R"
- QUIT
- +6 IF REA
- IF REA'=11
- WRITE !?5,$CHAR(7)
- Begin DoDot:1
- +7 WRITE "Rx# "_RXNUM_" was"_$SELECT(REA=1:" Non-Verified",REA=13:" Deleted",REA=11:" Expired",REA=5:" Suspended",REA=4:" Pending Due to Drug Interactions",REA=3:" On Hold",REA=14!(REA=15):" Discontinued",REA=16:" Provider Held",1:" In
- Fill Status")_"."
- End DoDot:1
- +8 IF REA
- IF REA'=1
- IF REA'=3
- IF REA'=5
- IF REA'=11
- IF REA'<13
- IF REA'=16
- Begin DoDot:1
- +9 KILL REA
- WRITE !?10,"Rx Cannot Be Discontinued/Reinstated!"
- HANG 2
- +10 SET VALMSG="Rx# "_RXNUM_" Cannot Be "_$SELECT($GET(PSTS):"Reinstated",1:"Discontinued")_"."
- End DoDot:1
- QUIT
- +11 SET REA="C"
- QUIT
- CAN NEW PSODRUG
- DO CAN1^PSOCAN3
- QUIT
- DIV IF '$PIECE($GET(PSOSYS),"^",2)
- WRITE !?10,$CHAR(7),"RX# ",$PIECE(^PSRX(DA,0),"^")," is not a valid choice. (Different Division)"
- SET PSPOP=1
- QUIT
- +1 IF $PIECE($GET(PSOSYS),"^",3)
- WRITE !?10,$CHAR(7)
- SET DIR("A")="RX# "_$PIECE(^PSRX(DA,0),"^")_" is from another division. Continue"
- SET DIR(0)="Y"
- SET DIR("B")="Y"
- DO ^DIR
- KILL DIR
- if $GET(DIRUT)!('Y)
- SET PSPOP=1
- +2 QUIT
- CHK KILL VADM,DEAD
- SET DFN=PSODFN
- DO DEM^VADPT
- IF $GET(VADM(6))=""
- SET DEAD=0
- QUIT
- +1 SET (PSODEATH,DEAD)=1
- WRITE !!,?10,VADM(1)_" DIED "_$PIECE($GET(VADM(6)),"^",2)
- DO CAN^PSOCAN3
- KILL PSODEATH
- +2 QUIT
- RX NEW PKI
- SET RXCNT=0
- SET RXSP=1
- DO TESTRP
- DO COM^PSOCAN1
- if '$DATA(INCOM)!($DATA(DIRUT))
- GOTO NUM
- KILL PSINV,PSCAN
- FOR II=1:1
- SET (EN,X)=$PIECE(IN,",",II)
- if $PIECE(IN,",",II)']""
- QUIT
- SET DIC=52
- SET DIC(0)="QMZ"
- DO ^DIC
- KILL DIC
- if Y'>0
- SET PSINV(X)=""
- if Y>0
- Begin DoDot:1
- +1 SET YY=Y
- SET YY(0,0)=Y(0,0)
- SET (PSODFN,DFN)=$PIECE(Y(0),"^",2)
- if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
- DO EN^PSOHLUP(PSODFN)
- +2 if $GET(DFN)>0
- DO CHK
- IF DEAD!($PIECE(^PSRX(+YY,"STA"),"^")=13)!($PIECE(^("STA"),"^")=14)
- SET PSINV(EN)=""
- QUIT
- +3 IF $PIECE(^PSRX(+YY,"STA"),"^")=12
- IF $PIECE($GET(^("PKI")),"^")
- SET PKI=1
- SET PSINV(EN)=""
- QUIT
- +4 SET DA=+YY
- IF $PIECE($GET(^PSRX(DA,"STA")),"^")=11!($PIECE($GET(^(2)),"^",6)<DT)
- DO EXP
- +5 SET RX=YY(0,0)
- if $DATA(^PSRX(DA,0))
- DO SPEED1^PSOCAN1
- +6 ;S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP Q
- +7 ;E S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
- End DoDot:1
- +8 KILL YY
- if '$DATA(PSCAN)
- GOTO INVALD^PSOCAN1
- SET RX=""
- SET RXCNT=0
- FOR
- SET RX=$ORDER(PSCAN(RX))
- if RX=""
- QUIT
- SET DA=+PSCAN(RX)
- SET REA=$PIECE(PSCAN(RX),"^",2)
- SET RXCNT=RXCNT+1
- DO SHOW^PSOCAN1
- ASK if '$DATA(PSCAN)
- QUIT
- WRITE !
- SET DIR("A")="OK to "_$SELECT($GET(RXCNT)>1:"Change Status",REA="C":"Discontinued",1:"Reinstate")
- SET DIR(0)="Y"
- SET DIR("B")="N"
- +1 NEW PSOCNRXV
- SET PSOCNRXV=0
- +2 DO ^DIR
- KILL DIR
- if $GET(DIRUT)
- QUIT
- IF 'Y
- KILL PSCAN
- DO INVALD^PSOCAN1
- GOTO NUM
- +3 KILL PSOPLCKZ
- SET RX=""
- FOR
- SET RX=$ORDER(PSCAN(RX))
- if 'RX
- QUIT
- Begin DoDot:1
- +4 SET PSODFN=+$PIECE($GET(^PSRX(+PSCAN(RX),0)),"^",2)
- +5 SET PSOPLCK=$$L^PSSLOCK(+$GET(PSODFN),0)
- if '$GET(PSOPLCK)&('$DATA(PSOPLCKZ(PSODFN)))
- DO LOCK^PSOORCPY
- IF '$GET(PSOPLCK)
- SET PSOPLCKZ(PSODFN)=PSODFN
- QUIT
- +6 DO PSOL^PSSLOCK(+PSCAN(RX))
- IF '$GET(PSOMSG)
- Begin DoDot:2
- +7 IF $PIECE($GET(PSOMSG),"^",2)'=""
- WRITE !,$PIECE($GET(PSOMSG),"^",2),!,"Order "_$PIECE($GET(^PSRX(+PSCAN(RX),0)),"^")_"."
- QUIT
- +8 WRITE !,"Another person is editing order "_$PIECE($GET(^PSRX(+PSCAN(RX),0)),"^")_"."
- End DoDot:2
- DO UL^PSSLOCK(PSODFN)
- QUIT
- +9 DO ACT
- DO PSOUL^PSSLOCK(+PSCAN(RX))
- DO UL^PSSLOCK(PSODFN)
- +10 SET PSOCNRXV=1
- End DoDot:1
- +11 KILL PSOPLCKZ
- if $GET(PSOCNRXV)
- WRITE !,$SELECT($GET(RXCNT)>1:"Statuses Changed",REA="C":"Prescription Discontinued",1:"Prescription Reinstated")
- DO INVALD^PSOCAN1
- GOTO NUM
- ACT SET DA=+PSCAN(RX)
- SET REA=$PIECE(PSCAN(RX),"^",2)
- SET II=RX
- SET PSODFN=$PIECE(^PSRX(DA,0),"^",2)
- IF REA="R"
- DO REINS^PSOCAN2
- QUIT
- +1 DO CAN
- QUIT
- EXP ;S PSINV($P(^PSRX(DA,0),"^"))=""
- +1 if $PIECE(^PSRX(DA,"STA"),"^")=12
- QUIT
- +2 SET $PIECE(^PSRX(DA,"STA"),"^")=11
- DO ECAN^PSOUTL(DA)
- +3 SET STAT="SC"
- SET PHARMST="ZE"
- SET COMM="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"/"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"/"_$EXTRACT($PIECE(^(2),"^",6),2,3)
- DO EN^PSOHLSN1(DA,STAT,PHARMST,COMM)
- KILL COMM,STAT,PHARMST
- EP1 IF '$GET(RXSP)
- DO INVALD^PSOCAN1
- if $GET(POERR)
- QUIT
- GOTO NUM
- +1 QUIT
- PSD ;Called from Controlled Subs, PSDRX is internal Rx number
- +1 SET PSDRFDEL=0
- +2 IF '$GET(PSDRX)!('$DATA(^PSRX(+$GET(PSDRX),0)))
- QUIT
- +3 IF $PIECE($GET(^PSRX(PSDRX,"STA")),"^")<12
- QUIT
- +4 NEW DA,NODE,RF,PSOPSDAL,PSODRX,PSODTE,PSODL,SFN,RIFN,PSOSXP,PSOFILDL
- +5 SET PSODRX=0
- FOR PSODLP=0:0
- SET PSODLP=$ORDER(^PSRX(PSDRX,1,PSODLP))
- if 'PSODLP
- QUIT
- if $DATA(^PSRX(PSDRX,1,PSODLP,0))
- SET PSODRX=PSODLP
- +6 IF 'PSODRX
- QUIT
- +7 IF $PIECE($GET(^PSRX(PSDRX,1,PSODRX,0)),"^",18)
- QUIT
- +8 DO PSDREF
- IF $GET(PSOFILDL)
- KILL PSOFILDL
- QUIT
- +9 KILL PSOFILDL,DIE
- SET NODE=0
- SET PSOPSDAL=1
- SET DA(1)=PSDRX
- SET DA=PSODRX
- SET DIE="^PSRX("_DA(1)_",1,"
- SET DR=".01///@"
- DO ^DIE
- KILL DIE
- +10 SET PSDRFDEL=1
- +11 QUIT
- PSDREF ;
- +1 NEW PRDL,PSOCNODE
- +2 SET PSOFILDL=0
- +3 FOR PRDL=0:0
- SET PRDL=$ORDER(^PSRX(PSDRX,4,PRDL))
- if 'PRDL
- QUIT
- IF $GET(PSODRX)=$PIECE($GET(^PSRX(PSDRX,4,PRDL,0)),"^",3)
- SET PSOCNODE=$GET(^(0))
- +4 IF $GET(PSOCNODE)=""
- QUIT
- +5 IF +$PIECE(PSOCNODE,"^",4)<3
- SET PSOFILDL=1
- +6 QUIT
- TESTRP ;
- +1 NEW PIIN,PIINFLAG
- SET PIINFLAG=0
- FOR PIIN=1:1
- SET X=$PIECE(IN,",",PIIN)
- if $PIECE(IN,",",PIIN)']""
- QUIT
- KILL DIC
- SET DIC=52
- SET DIC(0)="QMZ"
- DO ^DIC
- KILL DIC
- IF +$GET(Y)
- Begin DoDot:1
- +2 IF $PIECE($GET(^PSRX(+Y,"STA")),"^")'=12
- IF '$GET(PIINFLAG)
- SET PSOCANRD=+$PIECE($GET(^PSRX(+Y,0)),"^",4)
- SET PIINFLAG=1
- End DoDot:1
- +3 IF '$GET(PIINFLAG)
- SET PSOCANRZ=1
- +4 QUIT
- ULP ;
- +1 DO UL^PSSLOCK(+$GET(PSODFN))
- +2 QUIT
- ULRX ;
- +1 IF $GET(PSOULRX)
- DO PSOUL^PSSLOCK(PSOULRX)
- +2 QUIT