PSODISP ;BIR/SAB-MANUAL BARCODE RELEASE FUNCTION ;16-Oct-2017 09:32;du
;;7.0;OUTPATIENT PHARMACY;**15,71,131,1006,1013,156,185,148,247,200,1015,1022**;DEC 1997;Build 20
;Reference to $$SERV^IBARX1 supported by DBIA 2245
;Reference to ^PSD(58.8 supported by DBIA 1036
;Reference to ^PS(55 supported by DBIA 2228
;Reference to ^PSDRUG supported by DBIA 221
;Reference to ^PSDRUG("AQ" supported by DBIA 3165
;Reference to ^XTMP("PSA" supported by DBIA 1036
;Reference to ^PS(59.7 supported by DBIA 694
;Reference to ^DIC(19.2 supported by DBIA 1064
; Modified - IHS/CIA/PLS - 08/26/04 - BATCH+11
; IHS/MSC/PLS - 10/13/11 - UPDATE+3
; 10/16/17 - UPDATE+6
AC K CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID
K ^UTILITY($J,"PSOHL") S PSOPID=1
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! G EXIT
S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D G EXIT
.W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
AC1 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y
;check for Drug Acct background job K8 & K7.1
S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC
I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC
S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC
K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC
I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
K PSA,DIC,DA,X,Y,DIQ
BC ;
K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
Q:$G(POERR) W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR
I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1
I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1
I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7)," INVALID STATION NUMBER !!",$C(7),$C(7),! G BC
I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G BC
I $D(^PSRX(RXP,0)) D G BC1
.S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD
W !?7,$C(7),$C(7),$C(7)," IMPROPER BARCODE FORMAT" G BC
BC1 ;
D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2))
I +$P($G(^PSRX(+RXP,"PKI")),"^") D Q:$G(POERR) G BC
.I $G(SPEED) W !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4
.W !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU"
I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR) D DCHK G BC
I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR) D DCHK G BC
;drug stocked in Drug Acct Location?
S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0)
I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D K OUT Q:$G(POERR) D DCHK G BC
.W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF
BATCH ;
I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15) W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF
;flag to determine if site is running HL7 v.2.4 Dispense Machines
N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I")
S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6)
;original
I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'<PSIN S RXFD=$P(^(2),"^",2) D D:$G(LBLP) UPDATE I $G(ISUF) D UPDATE G REF
.S SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,'$P($G(^(0)),"^",5) S ISUF=1 Q
.I $D(^PSDRUG("AQ",QDRUG)) K CMOP D OREL^PSOCMOPB(RXP) K CMOP I $G(ISUF) K ISUF,CMOP Q
.;
.F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL I '+$P(^PSRX(RXP,"L",LBL,0),"^",2),'$P(^(0),"^",5),$P(^(0),"^",3)'["INTERACTION" S LBLP=1
.; IHS/MSC/PLS - 10/22/07 - suppress inventory mgmt if autofinished Rx.
.D CHKADDR^PSODISPS(RXP)
.Q:'$G(LBLP)
.;
.; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
.I $$MANREL^PSOBPSUT(RXP,0,$G(PSOPID))="^" K LBLP Q
.;
.;S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
.S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-$S($P($G(^PSRX(RXP,999999921)),U,3):0,1:QTY)
.D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@",PSODT=% D ^DIE K DIE,DR,DA,LBL
.;
.; - Notifying IB through ECME of the Rx has been released
.D IBSEND^PSOBPSUT(RXP,0)
.;
.D EN^PSOHLSN1(RXP,"ZD")
.D CALLPOS^APSPFUNC(RXP,+$O(^PSRX(RXP,1,$C(1)),-1),"A") ;IHS/CIA/PLS - 08/26/04 - Call Point Of Sale
.;if appropriate update ^XTMP("PSA", for Drug Acct
.I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,0)) S ^XTMP("PSA",+PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,+DT))+QTY
REF ;release refills and partials
K LBLP,IFN F XTYPE=1,"P" K IFN D QTY^PSODISPS
Q:+$G(OUT)!($G(POERR)) D DCHK
G BC
UPDATE I $G(ISUF) W $C(7),!!?7,"Prescription "_$P(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$C(7) Q
N BFILL S BFILL=0
S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
;IHS/MSC/PLS - 10/13/2011
I 1 D
.N APSPEXPD,DIE,DA,DR,RDT
.S RDT=$P(+$P($G(^PSRX(RXP,2)),U,13),".") ;IHS/MSC/PLS - 10/16/2017
.;S APSPEXPD=$$EXPDT^APSPAUTO(RXP)
.S APSPEXPD=$$EXPDT^APSPAUTO(RXP,1,RDT) ;IHS/MSC/PLS - 10/16/2017
.I APSPEXPD,APSPEXPD<$P($G(^PSRX(RXP,2)),U,6) D
..S DIE="^PSRX(",DA=RXP,DR="26///"_APSPEXPD D ^DIE
W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released"
;initialize bingo board variables
I $G(LBLP),$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
I $G(PSODISP)=2.4 D ;HL7 v2.4 dispensing machines
. F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D XMIT ;only send release dt/time transmission for dispensed orders
Q
EXIT ;
K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,MAN,PSODISP,SUB
Q
GETFILL ; get the fill number
S NFLD=0,UU="" F S UU=$O(^PSRX(+RXP,1,UU)) Q:UU="" S:$D(^PSRX(+RXP,1,UU,0)) NFLD=NFLD+1
Q
HELP W !!,"Wand the barcode number of the prescription or manually key in",!,"the number below the barcode or the prescription number.",!,"The barcode number should be of the format - 'NNN-NNNNNNN'"
Q
BCI S RXP=0
RXP S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
Q
DCHK ;checks for duplicate
Q:'$G(MAN)
I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
S RXP=$O(^PSRX("B",$P(^PSRX(RXP,0),"^"),RXP)) I 'RXP K POERR,MAN Q
I $P($G(^PSRX(RXP,"STA")),"^")=13 G DCHK
I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
W !!,"Duplicate Rx # "_$P(^PSRX(RXP,0),"^")_" found."
S POERR=1 D BC1^PSODISP
I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
G DCHK
Q
XMIT D NOW^%DTC S PSODTM=%
S IDGN=$P(^PSRX(+RXP,0),"^",6)
K ^UTILITY($J,"PSOHL")
S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_FPN
S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="",ZTSAVE("PSOLAP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
Q
PSODISP ;BIR/SAB-MANUAL BARCODE RELEASE FUNCTION ;16-Oct-2017 09:32;du
+1 ;;7.0;OUTPATIENT PHARMACY;**15,71,131,1006,1013,156,185,148,247,200,1015,1022**;DEC 1997;Build 20
+2 ;Reference to $$SERV^IBARX1 supported by DBIA 2245
+3 ;Reference to ^PSD(58.8 supported by DBIA 1036
+4 ;Reference to ^PS(55 supported by DBIA 2228
+5 ;Reference to ^PSDRUG supported by DBIA 221
+6 ;Reference to ^PSDRUG("AQ" supported by DBIA 3165
+7 ;Reference to ^XTMP("PSA" supported by DBIA 1036
+8 ;Reference to ^PS(59.7 supported by DBIA 694
+9 ;Reference to ^DIC(19.2 supported by DBIA 1064
+10 ; Modified - IHS/CIA/PLS - 08/26/04 - BATCH+11
+11 ; IHS/MSC/PLS - 10/13/11 - UPDATE+3
+12 ; 10/16/17 - UPDATE+6
AC KILL CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID
+1 KILL ^UTILITY($JOB,"PSOHL")
SET PSOPID=1
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,?5,"Site Parameters must be defined to use the Release option!",!
GOTO EXIT
+3 SET Y=$GET(^PS(59,PSOSITE,"IB"))
SET PSOIBSS=$$SERV^IBARX1(+Y)
IF 'PSOIBSS
DO IBSSR^PSOUTL
IF 'PSOIBFL
Begin DoDot:1
+4 WRITE $CHAR(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
End DoDot:1
GOTO EXIT
AC1 WRITE !!
SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
+1 SET DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
SET DIC("A")="Enter PHARMACIST: "
SET DIC="^VA(200,"
SET DIC(0)="QEAM"
DO ^DIC
IF "^"[X
GOTO EXIT
KILL DIC
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(Y=-1)
GOTO EXIT
SET PSRH=+Y
+2 ;check for Drug Acct background job K8 & K7.1
+3 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19.2
DO ^DIC
IF Y=-1
KILL DIC,X,Y
GOTO BC
+4 IF $PIECE($GET(Y(0)),U,2)>DT
SET PSODA=1
IF '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
GOTO BC
+5 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19
DO ^DIC
KILL DIC,X
IF Y=-1
GOTO BC
+6 KILL DIQ,PSA
SET DA=+Y
SET DIC=19
SET DIQ="PSA"
SET DR=200
SET DIQ(0)="IN"
DO EN^DIQ1
+7 IF '$DATA(PSA(19,DA,200,"I"))
KILL DIC,DA,X,Y,DIQ
GOTO BC
+8 IF PSA(19,DA,200,"I")>DT
SET PSODA=1
IF '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
+9 KILL PSA,DIC,DA,X,Y,DIQ
BC ;
+1 KILL MAN
IF $GET(RXP)
IF $DATA(DISGROUP)
IF $DATA(BINGNAM)
IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
IF ($DATA(BINGRO)!$DATA(BINGRPR))
DO REL^PSOBING1
KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
+2 IF $GET(POERR)
QUIT
WRITE !!
KILL CMOP,ISUF,DIR,LBL,LBLP
SET DIR("A")="Enter/Wand PRESCRIPTION number"
SET DIR("?")="^D HELP^PSODISP"
SET DIR(0)="FO"
DO ^DIR
+3 IF $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
KILL DIRUT,DTOUT,DUOUT
GOTO AC1
+4 IF X'["-"
DO BCI
IF '$GET(RXP)
WRITE !,"INVALID PRESCRIPTION NUMBER"
IF '$GET(RXP)
GOTO BC
SET MAN=1
GOTO BC1
+5 IF X["-"
IF $PIECE(X,"-")'=$PIECE($$SITE^VASITE(),"^",3)
WRITE !?7,$CHAR(7),$CHAR(7)," INVALID STATION NUMBER !!",$CHAR(7),$CHAR(7),!
GOTO BC
+6 IF X["-"
SET RXP=$PIECE(X,"-",2)
IF '$DATA(^PSRX(+$GET(RXP),0))!($GET(RXP)']"")
WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7)," NON-EXISTENT PRESCRIPTION"
GOTO BC
+7 IF $DATA(^PSRX(RXP,0))
Begin DoDot:1
+8 SET PSOLOUD=1
IF $PIECE($GET(^PS(55,+$PIECE(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2
DO EN^PSOHLUP($PIECE(^PSRX(+RXP,0),"^",2))
KILL PSOLOUD
End DoDot:1
GOTO BC1
+9 WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7)," IMPROPER BARCODE FORMAT"
GOTO BC
BC1 ;
+1 DO ICN^PSODPT(+$PIECE(^PSRX(RXP,0),"^",2))
+2 IF +$PIECE($GET(^PSRX(+RXP,"PKI")),"^")
Begin DoDot:1
+3 IF $GET(SPEED)
WRITE !!?7,$CHAR(7),$CHAR(7),"Rx# "_$PIECE(^PSRX(RXP,0),"^")
SET PSOLIST=4
+4 WRITE !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU"
End DoDot:1
IF $GET(POERR)
QUIT
GOTO BC
+5 IF +$PIECE($GET(^PSRX(+RXP,"STA")),"^")=13!(+$PIECE($GET(^PSRX(+RXP,0)),"^",2)=0)
WRITE !?7,$CHAR(7),$CHAR(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER"
IF $GET(POERR)
QUIT
DO DCHK
GOTO BC
+6 IF +$PIECE($GET(^PSRX(+RXP,"STA")),"^")
IF $SELECT($PIECE(^("STA"),"^")=2:0,$PIECE(^("STA"),"^")=5:0,$PIECE(^("STA"),"^")=11:0,$PIECE(^("STA"),"^")=12:0,$PIECE(^("STA"),"^")=14:0,$PIECE(^("STA"),"^")=15:0,1:1)
DO STAT^PSODISPS
IF $GET(POERR)
QUIT
DO DCHK
GOTO BC
+7 ;drug stocked in Drug Acct Location?
+8 SET PSODA(1)=$SELECT($DATA(^PSD(58.8,+$ORDER(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$PIECE(^PSRX(RXP,0),U,6))):1,1:0)
+9 IF $PIECE(^PSRX(RXP,2),"^",13)
SET Y=$PIECE(^PSRX(RXP,2),"^",13)
XECUTE ^DD("DD")
SET OUT=1
Begin DoDot:1
+10 WRITE !!?7,$CHAR(7),$CHAR(7),$SELECT($GET(SPEED):"Rx# "_$PIECE(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials "
DO REF
End DoDot:1
KILL OUT
IF $GET(POERR)
QUIT
DO DCHK
GOTO BC
BATCH ;
+1 IF $PIECE(^PSRX(RXP,2),"^",15)
IF '$PIECE(^(2),"^",14)
SET RESK=$PIECE(^(2),"^",15)
WRITE !!?5,"Rx# "_$PIECE(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$EXTRACT(RESK,4,5)_"/"_$EXTRACT(RESK,6,7)_"/"_$EXTRACT(RESK,2,3),!
GOTO REF
+2 ;flag to determine if site is running HL7 v.2.4 Dispense Machines
+3 NEW PSODISP
SET PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I")
+4 SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
SET QTY=$PIECE($GET(^PSRX(RXP,0)),"^",7)
SET QDRUG=$PIECE(^PSRX(RXP,0),"^",6)
+5 ;original
+6 IF '$PIECE($GET(^PSRX(RXP,2)),"^",13)
IF +$PIECE($GET(^(2)),"^",2)'<PSIN
SET RXFD=$PIECE(^(2),"^",2)
Begin DoDot:1
+7 SET SUPN=$ORDER(^PS(52.5,"B",RXP,0))
IF SUPN
IF $DATA(^PS(52.5,"C",RXFD,SUPN))
IF $GET(^PS(52.5,SUPN,"P"))'=1
IF '$PIECE($GET(^(0)),"^",5)
SET ISUF=1
QUIT
+8 IF $DATA(^PSDRUG("AQ",QDRUG))
KILL CMOP
DO OREL^PSOCMOPB(RXP)
KILL CMOP
IF $GET(ISUF)
KILL ISUF,CMOP
QUIT
+9 ;
+10 FOR LBL=0:0
SET LBL=$ORDER(^PSRX(RXP,"L",LBL))
IF 'LBL
QUIT
IF '+$PIECE(^PSRX(RXP,"L",LBL,0),"^",2)
IF '$PIECE(^(0),"^",5)
IF $PIECE(^(0),"^",3)'["INTERACTION"
SET LBLP=1
+11 ; IHS/MSC/PLS - 10/22/07 - suppress inventory mgmt if autofinished Rx.
+12 DO CHKADDR^PSODISPS(RXP)
+13 IF '$GET(LBLP)
QUIT
+14 ;
+15 ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
+16 IF $$MANREL^PSOBPSUT(RXP,0,$GET(PSOPID))="^"
KILL LBLP
QUIT
+17 ;
+18 ;S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
+19 IF $DATA(^PSDRUG(QDRUG,660.1))
SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-$SELECT($PIECE($GET(^PSRX(RXP,999999921)),U,3):0,1:QTY)
+20 DO NOW^%DTC
SET DIE="^PSRX("
SET DA=RXP
SET DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@"
SET PSODT=%
DO ^DIE
KILL DIE,DR,DA,LBL
+21 ;
+22 ; - Notifying IB through ECME of the Rx has been released
+23 DO IBSEND^PSOBPSUT(RXP,0)
+24 ;
+25 DO EN^PSOHLSN1(RXP,"ZD")
+26 ;IHS/CIA/PLS - 08/26/04 - Call Point Of Sale
DO CALLPOS^APSPFUNC(RXP,+$ORDER(^PSRX(RXP,1,$CHAR(1)),-1),"A")
+27 ;if appropriate update ^XTMP("PSA", for Drug Acct
+28 IF $GET(PSODA)
IF $GET(PSODA(1))
IF '$DATA(^PSRX("AR",+PSODT,+RXP,0))
SET ^XTMP("PSA",+PSOSITE,+QDRUG,+DT)=$GET(^XTMP("PSA",+PSOSITE,+QDRUG,+DT))+QTY
End DoDot:1
IF $GET(LBLP)
DO UPDATE
IF $GET(ISUF)
DO UPDATE
GOTO REF
REF ;release refills and partials
+1 KILL LBLP,IFN
FOR XTYPE=1,"P"
KILL IFN
DO QTY^PSODISPS
+2 IF +$GET(OUT)!($GET(POERR))
QUIT
DO DCHK
+3 GOTO BC
UPDATE IF $GET(ISUF)
WRITE $CHAR(7),!!?7,"Prescription "_$PIECE(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$CHAR(7)
QUIT
+1 NEW BFILL
SET BFILL=0
+2 SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
DO CP^PSOCP
+3 ;IHS/MSC/PLS - 10/13/2011
+4 IF 1
Begin DoDot:1
+5 NEW APSPEXPD,DIE,DA,DR,RDT
+6 ;IHS/MSC/PLS - 10/16/2017
SET RDT=$PIECE(+$PIECE($GET(^PSRX(RXP,2)),U,13),".")
+7 ;S APSPEXPD=$$EXPDT^APSPAUTO(RXP)
+8 ;IHS/MSC/PLS - 10/16/2017
SET APSPEXPD=$$EXPDT^APSPAUTO(RXP,1,RDT)
+9 IF APSPEXPD
IF APSPEXPD<$PIECE($GET(^PSRX(RXP,2)),U,6)
Begin DoDot:2
+10 SET DIE="^PSRX("
SET DA=RXP
SET DR="26///"_APSPEXPD
DO ^DIE
End DoDot:2
End DoDot:1
+11 WRITE !?7,"Prescription Number "_$PIECE(^PSRX(RXP,0),"^")_" Released"
+12 ;initialize bingo board variables
+13 IF $GET(LBLP)
IF $PIECE(^PSRX(RXP,0),"^",11)["W"
SET BINGRO="W"
SET BINGNAM=$PIECE(^PSRX(RXP,0),"^",2)
SET BINGDIV=$PIECE(^PSRX(RXP,2),"^",9)
+14 ;HL7 v2.4 dispensing machines
IF $GET(PSODISP)=2.4
Begin DoDot:1
+15 ;only send release dt/time transmission for dispensed orders
FOR I=0:0
SET SUB=$ORDER(^PSRX(RXP,"A",I))
IF 'I
QUIT
IF $PIECE(^PSRX(RXP,"A",I,0),"^",2)="N"
DO XMIT
End DoDot:1
+16 QUIT
EXIT ;
+1 KILL OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,MAN,PSODISP,SUB
+2 QUIT
GETFILL ; get the fill number
+1 SET NFLD=0
SET UU=""
FOR
SET UU=$ORDER(^PSRX(+RXP,1,UU))
IF UU=""
QUIT
IF $DATA(^PSRX(+RXP,1,UU,0))
SET NFLD=NFLD+1
+2 QUIT
HELP WRITE !!,"Wand the barcode number of the prescription or manually key in",!,"the number below the barcode or the prescription number.",!,"The barcode number should be of the format - 'NNN-NNNNNNN'"
+1 QUIT
BCI SET RXP=0
RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
SET RXP=$ORDER(^PSRX("B",X,RXP))
IF $PIECE($GET(^PSRX(+RXP,"STA")),"^")=13
GOTO RXP
+1 QUIT
DCHK ;checks for duplicate
+1 IF '$GET(MAN)
QUIT
+2 IF $DATA(DISGROUP)
IF $DATA(BINGNAM)
IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
IF ($DATA(BINGRO)!$DATA(BINGRPR))
DO REL^PSOBING1
KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
+3 SET RXP=$ORDER(^PSRX("B",$PIECE(^PSRX(RXP,0),"^"),RXP))
IF 'RXP
KILL POERR,MAN
QUIT
+4 IF $PIECE($GET(^PSRX(RXP,"STA")),"^")=13
GOTO DCHK
+5 IF $DATA(DISGROUP)
IF $DATA(BINGNAM)
IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
IF ($DATA(BINGRO)!$DATA(BINGRPR))
DO REL^PSOBING1
KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
+6 WRITE !!,"Duplicate Rx # "_$PIECE(^PSRX(RXP,0),"^")_" found."
+7 SET POERR=1
DO BC1^PSODISP
+8 IF $DATA(DISGROUP)
IF $DATA(BINGNAM)
IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
IF ($DATA(BINGRO)!$DATA(BINGRPR))
DO REL^PSOBING1
KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
+9 GOTO DCHK
+10 QUIT
XMIT DO NOW^%DTC
SET PSODTM=%
+1 SET IDGN=$PIECE(^PSRX(+RXP,0),"^",6)
+2 KILL ^UTILITY($JOB,"PSOHL")
+3 SET ^UTILITY($JOB,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$GET(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_FPN
+4 SET ZTRTN="INIT^PSORELDT"
SET ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTSAVE("^UTILITY($J,""PSOHL"",")=""
SET ZTSAVE("PSOSITE")=""
SET ZTSAVE("RXP")=""
SET ZTSAVE("PSOLAP")=""
DO ^%ZTLOAD
KILL ^UTILITY($JOB,"PSOHL")
+5 QUIT
