APSPAUTO ;IHS/CIA/PLS - Auto Release Prescription ;25-Mar-2016 14:20;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1002,1006,1008,1013,1014,1015,1017,1018,1021**;Sep 23, 2004;Build 14
; This routine contains code from PSODISP and PSODISPS.
; Call to OREL^PSOCMOPB was changed to include one parameter.
AUTOREL ; EP
N APSPZRP,APSP1,PSRH,PSIN,APSPRXP,POERR,APSPREL
S APSPREL=$$GET1^DIQ(9009033,+PSOSITE,314,"I")
;S APSPZRP=$G(PSORX("PSOL",1))
;I $G(VEXRX)
S APSPZRP=$G(PPL)
;IHS/MSC/PLS - 6/15/09 - Added PSOPULL for suspense processing
; 7/07/09 - Added PSOSUSPR for suspense processing
I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="FAST")!($D(PCOMH))!($G(PSOPULL))!($G(PSOSUSPR))!($G(PSOFROM)="PARTIAL")&($D(^XUSEC("PSORPH",DUZ))) D
.Q:$G(APSPZRP)']""
.F APSP1=1:1 Q:$P(APSPZRP,",",APSP1)="" S RXP=$P(APSPZRP,",",APSP1) D
..S PSRH=DUZ,PSIN=$P($G(^PS(59.7,1,49.99)),"^",2)
..S APSPRXP=RXP
..D:APSPREL AC(1) ; 1=Don't Print info lines ; Call conditional on AUTORELEASE Flag set to YES
..I $G(PSOFROM)'="PARTIAL" D
...; IHS/CIA/PLS - 02/02/05 - Added check for prescription status
...;IHS/MSC/PLS - 04/01/2014 - Added check for existing POS entry
...D
....N REF
....S REF=$O(^PSRX(APSPRXP,1,$C(1)),-1)
....Q:$$STATCHK^APSPLBL(APSPRXP)
....;Q:$$EXISTPOS(APSPRXP,REF) ;IHS/MSC/PLS - 03/25/2016
....D CALLPOS^APSPFUNC(APSPRXP,REF,"A")
Q
; Returns presence of Prescription/Refill in Point Of Sale
EXISTPOS(RXIEN,RFIEN) ;EP-
N RES
S RES=0
I '$$TEST^APSQBRES("ABSPOSRX") D
.S RES=$$STATUS59^ABSPOSRX(RXIEN,$G(RFIEN,0))'=""
Q RES
AC(APSPNOP) ; EP - Autorelease prescription
N DA,DR,DIE,X,X1,X2,Y,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY
N QDRUG,QTY,TYPE,XTYPE,DUOUT,OUT
AC1 W:'$G(APSPNOP) ! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
BC ;
K MAN I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D
.D REL^PSOBING1
.K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
Q:$G(POERR)
K ISUF,DIR,LBL,LBLP
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
BC1 ;
I +$P($G(^PSRX(+RXP,"PKI")),"^") D Q:$G(POERR) G BC
.I $G(SPEED) W:'$G(APSPNOP) !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4
.W:'$G(APSPNOP) !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU"
;IHS/MSC/PLS - 10/23/07 - Suppress Delete Prescription prompt.
;I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W:$G(APSPNOP) !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q
I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) Q
;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
.W:'$G(APSPNOP) !!?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:'$G(APSPNOP) !!?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
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 Q:+$G(OUT) 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.
.;Q:'$G(LBLP) S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
.Q:'$G(LBLP) 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
.D EN^PSOHLSN1(RXP,"ZD")
.;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
S:'XTYPE $P(^PSRX(RXP,"TYPE"),"^")=0
D:$G(OUT) ADJEXPDT ;IHS/MSC/PLS - 07/15/2013
Q:+$G(OUT)!($G(POERR))
UPDATE I $G(ISUF) W:'$G(APSPNOP) $C(7),!!?7,"Prescription "_$P(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$C(7) Q
; I +$G(^PSRX(RXP,"IB")) S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
;IHS/MSC/PLS - 10/13/2011
;IHS/MSC/PLS - 07/15/2013 - Changed to new EP
;I 1 D
;.N APSPEXPD,DIE,DA,DR
;.S APSPEXPD=$$EXPDT(RXP,1)
;.I APSPEXPD D
;..S DIE="^PSRX(",DA=RXP,DR="26///"_APSPEXPD D ^DIE
D ADJEXPDT
W:'$G(APSPNOP) !?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)
S OUT=1
Q
RXP S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
Q
;
QTY S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP
F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY D:$P($G(^PSRX(RXP,XTYPE,YY,0)),"^")'<PSIN K ISUF,LBLP
.S RXFD=$E($P(^PSRX(RXP,XTYPE,YY,0),"^"),1,7),SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,$G(XTYPE) S ISUF=1 Q
.I XTYPE=1,($D(^PSDRUG("AQ",QDRUG))) K CMOP D RREL^PSOCMOPB(RXP,YY) K CMOP Q:$G(ISUF)
.I $P(^PSRX(RXP,XTYPE,YY,0),"^",$S($G(XTYPE):18,1:19))]""!($P(^(0),"^",16)) K IFN Q
.F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL I $P(^PSRX(RXP,"L",LBL,0),"^",2)=$S('XTYPE:(99-YY),1:YY) S LBLP=1
.Q:'$G(LBLP) S IFN=YY S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,XTYPE,YY,0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
.D NOW^%DTC I XTYPE=1 S DIE="^PSRX("_RXP_","_XTYPE_",",DA(1)=RXP,DA=YY,DR=17_"///"_%,^PSRX($S($G(XTYPE):"AL",1:"AM"),%,RXP,YY)="",$P(^PSRX(RXP,XTYPE,YY,0),"^",5)=PSRH
.I XTYPE="P" S DA(1)=RXP,DIE="^PSRX("_DA(1)_",""P"",",DA=YY,DR=8_"///"_%,^PSRX($S($G(XTYPE):"AL",1:"AM"),%,RXP,YY)="",$P(^PSRX(RXP,XTYPE,YY,0),"^",5)=PSRH
.L +^PSRX(RXP):20 D ^DIE K DIE,DR L -^PSRX(RXP) K DA
.K PSODISPP S:$G(XTYPE)="P" PSODISPP=1 D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
.K:XTYPE ^PSRX("ACP",$P($G(^PSRX(RXP,0)),"^",2),$P($G(^PSRX(RXP,1,YY,0)),"^"),YY,RXP)
.I XTYPE,$G(IFN),'$G(ISUF) S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
.;if appropriate update ^XTMP("PSA", for Drug Acct.
.I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,YY)) D
..S ^XTMP("PSA",+PSOSITE,+QDRUG,DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,DT))+$P($G(^PSRX(RXP,XTYPE,YY,0)),"^",4)
.;initialize bingo board variables
.I $G(IFN),$P($G(^PSRX(RXP,XTYPE,IFN,0)),"^",2)["W" S BINGRPR="W",BNGPDV=$P(^PSRX(RXP,XTYPE,IFN,0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
K IFN
Q
ADJEXPDT ;EP-
;IHS/MSC/PLS - 10/13/2011
N APSPEXPD,DIE,DA,DR
S APSPEXPD=$$EXPDT(RXP,1)
I APSPEXPD D
.S DIE="^PSRX(",DA=RXP,DR="26///"_APSPEXPD D ^DIE
Q
; Return updated expiration date
EXPDT(RX,AUTO,RDT) ;EP-
;CHECK FOR CALCULATED EXPIRATION DATE < CURRENT EXPIRATION DATE.
N RES,NREF,RX0,DS,RFCNT,EXTEXP,DE,CS,OEXPDT,ISSDT
S CS=0
S AUTO=$G(AUTO,0)
S RDT=+$G(RDT) ;Release date
S:'RDT RDT=DT ;Default to today
S RX0=^PSRX(RX,0)
; Quit if not autorelease, prescription has been released and no remaining dispenses
I 'AUTO,$P($G(^PSRX(RX,2)),U,13),'$$RMNRFL^APSPFUNC(RX) Q 0
S ISSDT=$P(RX0,U,13)
S DE=+$$GET1^DIQ(50,$P(RX0,U,6),3)
I DE>1,DE<6 S CS=1 S:DE=2 $P(CS,U,2)=1
S RES=0
S NREF=+$P(RX0,U,9)
S DS=+$P(RX0,U,8)
S EXTEXP=$$GET1^DIQ(50,$P(RX0,U,6),9999999.08)
S X2=$S(EXTEXP:EXTEXP,$P(CS,U,2):184,CS:184,1:366)
S OEXPDT=$$FMADD^XLFDT(ISSDT,X2)
S DS=$S(EXTEXP:EXTEXP,1:DS)
I $$FMADD^XLFDT(RDT,DS)'<OEXPDT S RES=0
E I 'NREF S RES=1
E D
.S RFCNT=$O(^PSRX(RX,1,$C(1)),-1)
.S RES=$S(RFCNT=NREF:1,1:0) ; not eligible for change in expiration date
Q $S(RES:$$FMADD^XLFDT(RDT,DS),1:0)
APSPAUTO ;IHS/CIA/PLS - Auto Release Prescription ;25-Mar-2016 14:20;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1002,1006,1008,1013,1014,1015,1017,1018,1021**;Sep 23, 2004;Build 14
+2 ; This routine contains code from PSODISP and PSODISPS.
+3 ; Call to OREL^PSOCMOPB was changed to include one parameter.
AUTOREL ; EP
+1 NEW APSPZRP,APSP1,PSRH,PSIN,APSPRXP,POERR,APSPREL
+2 SET APSPREL=$$GET1^DIQ(9009033,+PSOSITE,314,"I")
+3 ;S APSPZRP=$G(PSORX("PSOL",1))
+4 ;I $G(VEXRX)
+5 SET APSPZRP=$GET(PPL)
+6 ;IHS/MSC/PLS - 6/15/09 - Added PSOPULL for suspense processing
+7 ; 7/07/09 - Added PSOSUSPR for suspense processing
+8 IF $GET(PSOFROM)="NEW"!($GET(PSOFROM)="REFILL")!($GET(PSOFROM)="FAST")!($DATA(PCOMH))!($GET(PSOPULL))!($GET(PSOSUSPR))!($GET(PSOFROM)="PARTIAL")&($DATA(^XUSEC("PSORPH",DUZ)))
Begin DoDot:1
+9 IF $GET(APSPZRP)']""
QUIT
+10 FOR APSP1=1:1
IF $PIECE(APSPZRP,",",APSP1)=""
QUIT
SET RXP=$PIECE(APSPZRP,",",APSP1)
Begin DoDot:2
+11 SET PSRH=DUZ
SET PSIN=$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
+12 SET APSPRXP=RXP
+13 ; 1=Don't Print info lines ; Call conditional on AUTORELEASE Flag set to YES
IF APSPREL
DO AC(1)
+14 IF $GET(PSOFROM)'="PARTIAL"
Begin DoDot:3
+15 ; IHS/CIA/PLS - 02/02/05 - Added check for prescription status
+16 ;IHS/MSC/PLS - 04/01/2014 - Added check for existing POS entry
+17 Begin DoDot:4
+18 NEW REF
+19 SET REF=$ORDER(^PSRX(APSPRXP,1,$CHAR(1)),-1)
+20 IF $$STATCHK^APSPLBL(APSPRXP)
QUIT
+21 ;Q:$$EXISTPOS(APSPRXP,REF) ;IHS/MSC/PLS - 03/25/2016
+22 DO CALLPOS^APSPFUNC(APSPRXP,REF,"A")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ; Returns presence of Prescription/Refill in Point Of Sale
EXISTPOS(RXIEN,RFIEN) ;EP-
+1 NEW RES
+2 SET RES=0
+3 IF '$$TEST^APSQBRES("ABSPOSRX")
Begin DoDot:1
+4 SET RES=$$STATUS59^ABSPOSRX(RXIEN,$GET(RFIEN,0))'=""
End DoDot:1
+5 QUIT RES
AC(APSPNOP) ; EP - Autorelease prescription
+1 NEW DA,DR,DIE,X,X1,X2,Y,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY
+2 NEW QDRUG,QTY,TYPE,XTYPE,DUOUT,OUT
AC1 IF '$GET(APSPNOP)
WRITE !
SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
BC ;
+1 KILL MAN
IF $DATA(DISGROUP)
IF $DATA(BINGNAM)
IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
IF ($DATA(BINGRO)!$DATA(BINGRPR))
Begin DoDot:1
+2 DO REL^PSOBING1
+3 KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
End DoDot:1
+4 IF $GET(POERR)
QUIT
+5 KILL ISUF,DIR,LBL,LBLP
+6 IF $DATA(^PSRX(RXP,0))
Begin DoDot:1
+7 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
BC1 ;
+1 IF +$PIECE($GET(^PSRX(+RXP,"PKI")),"^")
Begin DoDot:1
+2 IF $GET(SPEED)
IF '$GET(APSPNOP)
WRITE !!?7,$CHAR(7),$CHAR(7),"Rx# "_$PIECE(^PSRX(RXP,0),"^")
SET PSOLIST=4
+3 IF '$GET(APSPNOP)
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
+4 ;IHS/MSC/PLS - 10/23/07 - Suppress Delete Prescription prompt.
+5 ;I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W:$G(APSPNOP) !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q
+6 IF +$PIECE($GET(^PSRX(+RXP,"STA")),"^")=13!(+$PIECE($GET(^PSRX(+RXP,0)),"^",2)=0)
QUIT
+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 IF '$GET(APSPNOP)
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
QUIT
BATCH ;
+1 IF $PIECE(^PSRX(RXP,2),"^",15)
IF '$PIECE(^(2),"^",14)
SET RESK=$PIECE(^(2),"^",15)
IF '$GET(APSPNOP)
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 SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
SET QTY=$PIECE($GET(^PSRX(RXP,0)),"^",7)
SET QDRUG=$PIECE(^PSRX(RXP,0),"^",6)
+3 ;original
+4 IF '$PIECE($GET(^PSRX(RXP,2)),"^",13)
IF +$PIECE($GET(^(2)),"^",2)'<PSIN
SET RXFD=$PIECE(^(2),"^",2)
Begin DoDot:1
+5 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
+6 IF $DATA(^PSDRUG("AQ",QDRUG))
KILL CMOP
DO OREL^PSOCMOPB(RXP)
KILL CMOP
IF $GET(ISUF)
KILL ISUF,CMOP
QUIT
+7 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
+8 ; IHS/MSC/PLS - 10/22/07 - suppress inventory mgmt if autofinished Rx.
+9 ;Q:'$G(LBLP) S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
+10 IF '$GET(LBLP)
QUIT
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)
+11 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
+12 DO EN^PSOHLSN1(RXP,"ZD")
+13 ;if appropriate update ^XTMP("PSA", for Drug Acct
+14 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(OUT)
QUIT
IF $GET(ISUF)
DO UPDATE
GOTO REF
REF ;release refills and partials
+1 KILL LBLP,IFN
FOR XTYPE=1,"P"
KILL IFN
DO QTY
+2 IF 'XTYPE
SET $PIECE(^PSRX(RXP,"TYPE"),"^")=0
+3 ;IHS/MSC/PLS - 07/15/2013
IF $GET(OUT)
DO ADJEXPDT
+4 IF +$GET(OUT)!($GET(POERR))
QUIT
UPDATE IF $GET(ISUF)
IF '$GET(APSPNOP)
WRITE $CHAR(7),!!?7,"Prescription "_$PIECE(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$CHAR(7)
QUIT
+1 ; I +$G(^PSRX(RXP,"IB")) S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
+2 SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
DO CP^PSOCP
+3 ;IHS/MSC/PLS - 10/13/2011
+4 ;IHS/MSC/PLS - 07/15/2013 - Changed to new EP
+5 ;I 1 D
+6 ;.N APSPEXPD,DIE,DA,DR
+7 ;.S APSPEXPD=$$EXPDT(RXP,1)
+8 ;.I APSPEXPD D
+9 ;..S DIE="^PSRX(",DA=RXP,DR="26///"_APSPEXPD D ^DIE
+10 DO ADJEXPDT
+11 IF '$GET(APSPNOP)
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 SET OUT=1
+15 QUIT
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
+2 ;
QTY SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
SET QDRUG=$PIECE(^PSRX(RXP,0),"^",6)
KILL LBLP
+1 FOR YY=0:0
SET YY=$ORDER(^PSRX(RXP,XTYPE,YY))
IF 'YY
QUIT
IF $PIECE($GET(^PSRX(RXP,XTYPE,YY,0)),"^")'<PSIN
Begin DoDot:1
+2 SET RXFD=$EXTRACT($PIECE(^PSRX(RXP,XTYPE,YY,0),"^"),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 $GET(XTYPE)
SET ISUF=1
QUIT
+3 IF XTYPE=1
IF ($DATA(^PSDRUG("AQ",QDRUG)))
KILL CMOP
DO RREL^PSOCMOPB(RXP,YY)
KILL CMOP
IF $GET(ISUF)
QUIT
+4 IF $PIECE(^PSRX(RXP,XTYPE,YY,0),"^",$SELECT($GET(XTYPE):18,1:19))]""!($PIECE(^(0),"^",16))
KILL IFN
QUIT
+5 FOR LBL=0:0
SET LBL=$ORDER(^PSRX(RXP,"L",LBL))
IF 'LBL
QUIT
IF $PIECE(^PSRX(RXP,"L",LBL,0),"^",2)=$SELECT('XTYPE:(99-YY),1:YY)
SET LBLP=1
+6 IF '$GET(LBLP)
QUIT
SET IFN=YY
IF $GET(^PSDRUG(QDRUG,660.1))]""
SET QTY=$PIECE(^PSRX(RXP,XTYPE,YY,0),"^",4)
SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
+7 DO NOW^%DTC
IF XTYPE=1
SET DIE="^PSRX("_RXP_","_XTYPE_","
SET DA(1)=RXP
SET DA=YY
SET DR=17_"///"_%
SET ^PSRX($SELECT($GET(XTYPE):"AL",1:"AM"),%,RXP,YY)=""
SET $PIECE(^PSRX(RXP,XTYPE,YY,0),"^",5)=PSRH
+8 IF XTYPE="P"
SET DA(1)=RXP
SET DIE="^PSRX("_DA(1)_",""P"","
SET DA=YY
SET DR=8_"///"_%
SET ^PSRX($SELECT($GET(XTYPE):"AL",1:"AM"),%,RXP,YY)=""
SET $PIECE(^PSRX(RXP,XTYPE,YY,0),"^",5)=PSRH
+9 LOCK +^PSRX(RXP):20
DO ^DIE
KILL DIE,DR
LOCK -^PSRX(RXP)
KILL DA
+10 KILL PSODISPP
IF $GET(XTYPE)="P"
SET PSODISPP=1
DO EN^PSOHLSN1(RXP,"ZD")
KILL PSODISPP
+11 IF XTYPE
KILL ^PSRX("ACP",$PIECE($GET(^PSRX(RXP,0)),"^",2),$PIECE($GET(^PSRX(RXP,1,YY,0)),"^"),YY,RXP)
+12 IF XTYPE
IF $GET(IFN)
IF '$GET(ISUF)
SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
DO CP^PSOCP
+13 ;if appropriate update ^XTMP("PSA", for Drug Acct.
+14 IF $GET(PSODA)
IF $GET(PSODA(1))
IF '$DATA(^PSRX("AR",+PSODT,+RXP,YY))
Begin DoDot:2
+15 SET ^XTMP("PSA",+PSOSITE,+QDRUG,DT)=$GET(^XTMP("PSA",+PSOSITE,+QDRUG,DT))+$PIECE($GET(^PSRX(RXP,XTYPE,YY,0)),"^",4)
End DoDot:2
+16 ;initialize bingo board variables
+17 IF $GET(IFN)
IF $PIECE($GET(^PSRX(RXP,XTYPE,IFN,0)),"^",2)["W"
SET BINGRPR="W"
SET BNGPDV=$PIECE(^PSRX(RXP,XTYPE,IFN,0),"^",9)
SET BINGNAM=$PIECE($GET(^PSRX(RXP,0)),"^",2)
End DoDot:1
KILL ISUF,LBLP
+18 KILL IFN
+19 QUIT
ADJEXPDT ;EP-
+1 ;IHS/MSC/PLS - 10/13/2011
+2 NEW APSPEXPD,DIE,DA,DR
+3 SET APSPEXPD=$$EXPDT(RXP,1)
+4 IF APSPEXPD
Begin DoDot:1
+5 SET DIE="^PSRX("
SET DA=RXP
SET DR="26///"_APSPEXPD
DO ^DIE
End DoDot:1
+6 QUIT
+7 ; Return updated expiration date
EXPDT(RX,AUTO,RDT) ;EP-
+1 ;CHECK FOR CALCULATED EXPIRATION DATE < CURRENT EXPIRATION DATE.
+2 NEW RES,NREF,RX0,DS,RFCNT,EXTEXP,DE,CS,OEXPDT,ISSDT
+3 SET CS=0
+4 SET AUTO=$GET(AUTO,0)
+5 ;Release date
SET RDT=+$GET(RDT)
+6 ;Default to today
IF 'RDT
SET RDT=DT
+7 SET RX0=^PSRX(RX,0)
+8 ; Quit if not autorelease, prescription has been released and no remaining dispenses
+9 IF 'AUTO
IF $PIECE($GET(^PSRX(RX,2)),U,13)
IF '$$RMNRFL^APSPFUNC(RX)
QUIT 0
+10 SET ISSDT=$PIECE(RX0,U,13)
+11 SET DE=+$$GET1^DIQ(50,$PIECE(RX0,U,6),3)
+12 IF DE>1
IF DE<6
SET CS=1
IF DE=2
SET $PIECE(CS,U,2)=1
+13 SET RES=0
+14 SET NREF=+$PIECE(RX0,U,9)
+15 SET DS=+$PIECE(RX0,U,8)
+16 SET EXTEXP=$$GET1^DIQ(50,$PIECE(RX0,U,6),9999999.08)
+17 SET X2=$SELECT(EXTEXP:EXTEXP,$PIECE(CS,U,2):184,CS:184,1:366)
+18 SET OEXPDT=$$FMADD^XLFDT(ISSDT,X2)
+19 SET DS=$SELECT(EXTEXP:EXTEXP,1:DS)
+20 IF $$FMADD^XLFDT(RDT,DS)'<OEXPDT
SET RES=0
+21 IF '$TEST
IF 'NREF
SET RES=1
+22 IF '$TEST
Begin DoDot:1
+23 SET RFCNT=$ORDER(^PSRX(RX,1,$CHAR(1)),-1)
+24 ; not eligible for change in expiration date
SET RES=$SELECT(RFCNT=NREF:1,1:0)
End DoDot:1
+25 QUIT $SELECT(RES:$$FMADD^XLFDT(RDT,DS),1:0)
