- 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
