- 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)
