APSPHLD ;IHS/MSC/PLS- Support for speed unhold ;24-May-2013 09:10;PLS
;;7.0;OUTPATIENT PHARMACY;**1013,1015**;DEC 1997;Build 62
SPEED ;speed UNHOLD
K LST,PSORX("FILL DATE")
N APSPVAL,PSONOOR
N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
K PSOHLD,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D G:$G(PSOHLD("DFLG"))!($G(PSOHLD("QFLG"))) SPEEDX
.D ASKVAL(.APSPVAL)
.Q:$G(APSPVAL("DFLG"))
.F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOHLD("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D D ULK Q
...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
...D:$G(PSOHLD("QFLG")) ULK
..S PSONOOR=APSPVAL("NOOR")
..D UHLD($P(PSOLST(ORN),U,2)),ULK
S:'$G(PSOOELSE) VALMBCK=""
S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
SPEEDX D EX K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE S:'$D(VALMBCK) VALMBCK="R"
K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
Q
;
ULK D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
Q
;
ULP D ULP^PSOHLD
Q
UHLD(DA) ;EP-
S Y(0)=^PSRX(DA,0),STA=+$G(^("STA"))
I STA=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q
I STA'=3!('$D(^XUSEC("PSORPH",DUZ))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT ;D NOOR^PSOHLD I $D(DIRUT) Q
I DT>$P(^PSRX(DA,2),"^",6) D Q
.S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11
.S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM
EN S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(0),"^")
I RXF D I $D(Y) Q
.S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,"
.S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
.S DR=$S('RLDT:".01R;2;",1:"")_"3COMMENTS"_";8///"_PSOSITE
.S PSOUNHLD=1 D ^DIE K PSOUNHLD
.S ZD(PSDA)=$P(^PSRX(DA(1),1,DA,0),U)
.Q:$D(Y) S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),DA=PSDA K DA(1)
S ACT=1,DIE="^PSRX(",FDT=$S($P(^PSRX(DA,2),U,2):$P(^PSRX(DA,2),U,2),1:DT)
S RLDT=$P(^PSRX(DA,2),U,13)
S DR="",RLDTP1=$P(RLDT,".",1)
;I 'RXF&'RLDT S DR="22//^S X=FDT;11;Q;"
I 'RXF&'RLDT S DR="22///^S X=APSPVAL(""FILL DATE"");11///^S X=APSPVAL(""MAIL/WINDOW"");Q;"
;I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22//^S X=RLDTP1;11;Q;"
I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22///^S X=RLDTP1;11///^S X=APSPVAL(""MAIL/WINDOW"");Q;"
S DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(DA)),1:$P(^PSRX(DA,2),""^"",2))"
;
S:'RXF DR=DR_";20///"_PSOSITE
D ^DIE K FDT ;I $D(Y) S VALMBCK="R" Q
S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(DA,"OE","",COMM,PSONOOR) K COMM ;,PSONOOR
S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(DA,2),U,2),1:ZD(DA))
K ^PSRX("AH",$P(^PSRX(DA,"H"),U),DA) S ^PSRX(DA,"H")=""
D ACT^PSOHLDA S (NEW1,NEW11)="^^"
S (RXF,RXFL(DA))=0 F JJ=0:0 S JJ=$O(^PSRX(DA,1,JJ)) Q:'JJ S (RXFL(DA),RXF)=JJ
I $G(PSXSYS) D UNHOLD^PSOCMOPA Q:$G(XFLAG)
I $G(DA) D RELC^PSOHLD Q:$G(PSOHRL)
I PSORX("FILL DATE")>DT,$P(PSOPAR,U,6) D S^PSORXL Q
S PCOMH(DA)="Medication Removed from Hold by Pharmacy"
I $G(DA) S RXRH(DA)=DA
I $P($G(^PSRX(DA,2)),U,15)'="" S $P(^PSRX(DA,2),U,14)=1,RXRP(DA)=1,$P(RXRP(DA),U,2)=$P($G(^PSRX(DA,0)),U,18) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO STOCK PRESCRIPTION
I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q
F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
E S PSORX("PSOL",PSOX2+1)=DA_","
D PSOUL^PSSLOCK($P(PSOLST(ORN),U,2))
Q
EX D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD
K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q
K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
;
; Ask user for values to stuff.
ASKVAL(APSPVAL) ;EP-
N DATAARY,DIR
S (DATAARY("DFLG"),DATAARY("QFLG"))=0
S DATAARY("FIELD")=0
D NOOR^PSOHLD
I $D(DIRUT) S APSPVAL("DFLG")=1 Q
S APSPVAL("NOOR")=PSONOOR
S APSPVAL("DFLG")=0
D FILLDT^PSODIR2(.DATAARY)
I $G(DATAARY("DFLG")) S APSPVAL("DFLG")=1 Q
S APSPVAL("FILL DATE")=DATAARY("FILL DATE")
K DIR
S DIR("B")="WINDOW"
S DIR(0)="52,11" D ^DIR
I $D(DIRUT) S APSPVAL("DFLG")=1
S APSPVAL("MAIL/WINDOW")=Y
Q
APSPHLD ;IHS/MSC/PLS- Support for speed unhold ;24-May-2013 09:10;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**1013,1015**;DEC 1997;Build 62
SPEED ;speed UNHOLD
+1 KILL LST,PSORX("FILL DATE")
+2 NEW APSPVAL,PSONOOR
+3 NEW VALMCNT
IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
+4 KILL PSOHLD,PSOFDR,DIR,DUOUT,DIRUT
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
IF $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
KILL DIR,DIRUT,DTOUT,DUOUT
SET VALMBCK=""
QUIT
+5 KILL DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
IF +Y
SET (SPEED,PSOOELSE)=1
DO FULL^VALM1
SET LST=Y
Begin DoDot:1
+6 DO ASKVAL(.APSPVAL)
+7 IF $GET(APSPVAL("DFLG"))
QUIT
+8 FOR ORD=1:1:$LENGTH(LST,",")
IF $PIECE(LST,",",ORD)']""!($GET(PSOHLD("QFLG")))
QUIT
SET ORN=$PIECE(LST,",",ORD)
IF +PSOLST(ORN)=52
Begin DoDot:2
+9 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
WRITE $CHAR(7),!!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")),!
DO PAUSE^VALM1
KILL PSOMSG
QUIT
+10 IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")=11
Begin DoDot:3
+11 WRITE $CHAR(7),!!?5,"RX "_$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status."
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
QUIT
+12 IF $GET(PSOHLD("QFLG"))
DO ULK
End DoDot:3
DO ULK
QUIT
+13 SET PSONOOR=APSPVAL("NOOR")
+14 DO UHLD($PIECE(PSOLST(ORN),U,2))
DO ULK
End DoDot:2
End DoDot:1
IF $GET(PSOHLD("DFLG"))!($GET(PSOHLD("QFLG")))
GOTO SPEEDX
+15 IF '$GET(PSOOELSE)
SET VALMBCK=""
+16 SET PSORXED=1
DO ^PSOBUILD
DO BLD^PSOORUT1
SPEEDX DO EX
KILL PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
+1 KILL LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE
IF '$DATA(VALMBCK)
SET VALMBCK="R"
+2 KILL PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+3 QUIT
+4 ;
ULK DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+1 QUIT
+2 ;
ULP DO ULP^PSOHLD
+1 QUIT
UHLD(DA) ;EP-
+1 SET Y(0)=^PSRX(DA,0)
SET STA=+$GET(^("STA"))
+2 IF STA=16
SET VALMSG="Placed on HOLD by Provider!"
KILL Y,STA
DO PSOUL^PSSLOCK(DA)
DO ULP
SET VALMBCK=""
QUIT
+3 IF STA'=3!('$DATA(^XUSEC("PSORPH",DUZ)))
SET VALMSG="Invalid Action Selection!"
SET VALMBCK=""
KILL Y,STA
DO PSOUL^PSSLOCK(DA)
DO ULP
QUIT
+4 ;D NOOR^PSOHLD I $D(DIRUT) Q
DO FULL^VALM1
KILL DIR,DTOUT,DUOUT,DIRUT
+5 IF DT>$PIECE(^PSRX(DA,2),"^",6)
Begin DoDot:1
+6 SET VALMSG="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
IF $PIECE(^PSRX(DA,"STA"),"^")<11
SET $PIECE(^PSRX(DA,"STA"),"^")=11
+7 SET ^PSRX(DA,"H")=""
SET COMM="Medication Expired on "_$EXTRACT($PIECE(^(2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
DO EN^PSOHLSN1(DA,"SC","ZE",COMM,"")
KILL COMM
End DoDot:1
QUIT
EN SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
IF 'I
QUIT
SET RXF=I
SET RSDT=$PIECE(^(0),"^")
+1 IF RXF
Begin DoDot:1
+2 SET (PSDA,DA(1))=DA
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
+3 SET RLDT=$PIECE(^PSRX(DA(1),1,DA,0),"^",18)
+4 SET DR=$SELECT('RLDT:".01R;2;",1:"")_"3COMMENTS"_";8///"_PSOSITE
+5 SET PSOUNHLD=1
DO ^DIE
KILL PSOUNHLD
+6 SET ZD(PSDA)=$PIECE(^PSRX(DA(1),1,DA,0),U)
+7 IF $DATA(Y)
QUIT
SET PSORX("FILL DATE")=$PIECE(^PSRX(DA(1),1,DA,0),"^")
SET DA=PSDA
KILL DA(1)
End DoDot:1
IF $DATA(Y)
QUIT
+8 SET ACT=1
SET DIE="^PSRX("
SET FDT=$SELECT($PIECE(^PSRX(DA,2),U,2):$PIECE(^PSRX(DA,2),U,2),1:DT)
+9 SET RLDT=$PIECE(^PSRX(DA,2),U,13)
+10 SET DR=""
SET RLDTP1=$PIECE(RLDT,".",1)
+11 ;I 'RXF&'RLDT S DR="22//^S X=FDT;11;Q;"
+12 IF 'RXF&'RLDT
SET DR="22///^S X=APSPVAL(""FILL DATE"");11///^S X=APSPVAL(""MAIL/WINDOW"");Q;"
+13 ;I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22//^S X=RLDTP1;11;Q;"
+14 IF RLDT&($PIECE(^PSRX(DA,2),"^",2)="")
SET DR="22///^S X=RLDTP1;11///^S X=APSPVAL(""MAIL/WINDOW"");Q;"
+15 SET DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(DA)),1:$P(^PSRX(DA,2),""^"",2))"
+16 ;
+17 IF 'RXF
SET DR=DR_";20///"_PSOSITE
+18 ;I $D(Y) S VALMBCK="R" Q
DO ^DIE
KILL FDT
+19 ;,PSONOOR
SET COMM="Medication Removed from Hold by Pharmacy"
DO EN^PSOHLSN1(DA,"OE","",COMM,PSONOOR)
KILL COMM
+20 SET PSORX("FILL DATE")=$SELECT('RXF:$PIECE(^PSRX(DA,2),U,2),1:ZD(DA))
+21 KILL ^PSRX("AH",$PIECE(^PSRX(DA,"H"),U),DA)
SET ^PSRX(DA,"H")=""
+22 DO ACT^PSOHLDA
SET (NEW1,NEW11)="^^"
+23 SET (RXF,RXFL(DA))=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(DA,1,JJ))
IF 'JJ
QUIT
SET (RXFL(DA),RXF)=JJ
+24 IF $GET(PSXSYS)
DO UNHOLD^PSOCMOPA
IF $GET(XFLAG)
QUIT
+25 IF $GET(DA)
DO RELC^PSOHLD
IF $GET(PSOHRL)
QUIT
+26 IF PSORX("FILL DATE")>DT
IF $PIECE(PSOPAR,U,6)
DO S^PSORXL
QUIT
+27 SET PCOMH(DA)="Medication Removed from Hold by Pharmacy"
+28 IF $GET(DA)
SET RXRH(DA)=DA
+29 ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO STOCK PRESCRIPTION
IF $PIECE($GET(^PSRX(DA,2)),U,15)'=""
SET $PIECE(^PSRX(DA,2),U,14)=1
SET RXRP(DA)=1
SET $PIECE(RXRP(DA),U,2)=$PIECE($GET(^PSRX(DA,0)),U,18)
+30 IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=DA_","
QUIT
+31 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+32 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(DA)<220
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
+33 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=DA_","
+34 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),U,2))
+35 QUIT
EX DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
DO ^PSOBUILD
+1 KILL PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
+2 KILL HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ
QUIT
+3 KILL PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+4 ;
+5 ; Ask user for values to stuff.
ASKVAL(APSPVAL) ;EP-
+1 NEW DATAARY,DIR
+2 SET (DATAARY("DFLG"),DATAARY("QFLG"))=0
+3 SET DATAARY("FIELD")=0
+4 DO NOOR^PSOHLD
+5 IF $DATA(DIRUT)
SET APSPVAL("DFLG")=1
QUIT
+6 SET APSPVAL("NOOR")=PSONOOR
+7 SET APSPVAL("DFLG")=0
+8 DO FILLDT^PSODIR2(.DATAARY)
+9 IF $GET(DATAARY("DFLG"))
SET APSPVAL("DFLG")=1
QUIT
+10 SET APSPVAL("FILL DATE")=DATAARY("FILL DATE")
+11 KILL DIR
+12 SET DIR("B")="WINDOW"
+13 SET DIR(0)="52,11"
DO ^DIR
+14 IF $DATA(DIRUT)
SET APSPVAL("DFLG")=1
+15 SET APSPVAL("MAIL/WINDOW")=Y
+16 QUIT
