APSPDR3 ;IHS/OHPRD/JCM - PHARMACY DRUG RECALL;10-Oct-2017 11:35;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1009,1022**;Sep 23, 2004;Build 20
;THIS ROUTINE BUILDS THE PHARMACY DRUG RECALL LIST
; IHS/MSC/PLS - 01/02/09 - Routine updated
; 12/16/09 - Modified GETIEN1 call to GETIEN for File 50
; 10/10/17 - Removed trailing Q at SET+4
EN ;
N APSPBD,APSPED,APSPBDF,APSPEDF,APSPDIV,APSPDRG,APSPDARY
N QFLG,DCNT
S (QFLG,DCNT)=0
K ^TMP($J,"PSODR")
W @IOF
W !,"Pharmacy Drug Recall List",!!
D ASKDATES^APSPUTIL(.APSPBD,.APSPED,.APSPQ,DT,DT)
Q:APSPQ
S APSPBDF=$P($TR($$FMTE^XLFDT(APSPBD,"5Z"),"@"," "),":",1,2)
S APSPEDF=$P($TR($$FMTE^XLFDT(APSPED,"5Z"),"@"," "),":",1,2)
S APSPBD=APSPBD-.01,APSPED=APSPED+.99
;SELECT DIVISION
S APSPDIV=$$DIR^APSPUTIL("Y","Would you like all pharmacy divisions","Yes",,.APSPQ)
Q:APSPQ
I APSPDIV D
.S APSPDIV="*"
E D Q:APSPQ
.S APSPDIV=$$GETIEN^APSPUTIL(59,"Select Pharmacy Division: ",.APSPQ)
F D Q:QFLG
.S APSPDRG=$$GETIEN^APSPUTIL(50,"Select Drug Name: ",,"QM")
.I APSPDRG<1 S QFLG=1 Q
.S APSPDARY(APSPDRG)=""
.S DCNT=DCNT+1
.S QFLG='$$DIR^APSPUTIL("Y","Want to Select Another Drug","No",,.APSPQ)
.S:'QFLG QFLG=APSPQ
Q:'DCNT
D DEV
Q
DEV ;
N XBRP,XBNS
S XBRP="OUT^APSPDR3"
S XBNS="APS*"
D ^XBDBQUE
Q
OUT ;
N APSPDT,RXIEN,APSPNOD,FTYPE,DRG
S APSPDT=APSPBD F S APSPDT=$O(^PSRX("ZAL",APSPDT)) Q:'APSPDT!(APSPDT>APSPED) D
.S RXIEN=0 F S RXIEN=$O(^PSRX("ZAL",APSPDT,RXIEN)) Q:'RXIEN D
..S APSPNOD=0 F S APSPNOD=$O(^PSRX("ZAL",APSPDT,RXIEN,APSPNOD)) Q:'APSPNOD D
...S FTYPE="" F S FTYPE=$O(^PSRX("ZAL",APSPDT,RXIEN,APSPNOD,FTYPE)) Q:FTYPE="" D CHECK
D EN^APSPDR4
Q
CHECK ;EP
N DIV
Q:'$D(^PSRX(RXIEN,0))
S DRG=$P($G(^PSRX(RXIEN,0)),U,6)
Q:'DRG ; Must have a drug
Q:'$D(^PSDRUG(DRG,0))
Q:'$D(APSPDARY(DRG)) ; Not a selected drug
S DIV=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:APSPNOD_","_RXIEN_",",1:RXIEN),$S(FTYPE="P":.09,FTYPE="R":8,1:20),"I") ; Pharmacy Division IEN
Q:'$$DIVVRY(DIV,APSPDIV) ; Check Division
D SET(RXIEN,DRG,DIV)
Q
; Return boolean flag indicating valid pharmacy division
DIVVRY(RXDIV,RPTDIV) ;EP
Q:RPTDIV="*" 1
Q RXDIV=RPTDIV
;
SET(RX,DRG,DIV) ;EP
N STA,RXN,DFN,QTY,DRGNM,NXT
S STA=$P($G(^PSRX(RX,"STA")),U)
Q:STA=13 ; Prescription marked as deleted
;IHS/MSC/PLS - 10/10/2017
;Q:FTYPE="N"&($P($G(^PSRX(RX,2)),U,15)) Q ; Prescription has been returned to stock
Q:FTYPE="N"&($P($G(^PSRX(RX,2)),U,15)) ; Prescription has been returned to stock
S NXT=$O(^TMP($J,"DATA",$C(1)),-1)
S NXT=NXT+1
S RXN=$P(^PSRX(RX,0),U) ;PRESCRIPTION NUMBER ON FILE
S DFN=$P(^PSRX(RX,0),U,2) ;PATIENT NUMBER FOR THE PERSON FILE
S QTY=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:APSPNOD_","_RX_",",1:RX),$S(FTYPE="P":.04,FTYPE="R":1,1:7))
S DRGNM=$P(^PSDRUG(DRG,0),U) ;DRUG NAME
S ^TMP($J,"PSODR",DIV,DFN,APSPDT,RX,NXT)=""
S ^TMP($J,"DATA",NXT)=DIV_U_APSPDT_U_DRGNM_U_QTY_U_RXN
Q
APSPDR3 ;IHS/OHPRD/JCM - PHARMACY DRUG RECALL;10-Oct-2017 11:35;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1009,1022**;Sep 23, 2004;Build 20
+2 ;THIS ROUTINE BUILDS THE PHARMACY DRUG RECALL LIST
+3 ; IHS/MSC/PLS - 01/02/09 - Routine updated
+4 ; 12/16/09 - Modified GETIEN1 call to GETIEN for File 50
+5 ; 10/10/17 - Removed trailing Q at SET+4
EN ;
+1 NEW APSPBD,APSPED,APSPBDF,APSPEDF,APSPDIV,APSPDRG,APSPDARY
+2 NEW QFLG,DCNT
+3 SET (QFLG,DCNT)=0
+4 KILL ^TMP($JOB,"PSODR")
+5 WRITE @IOF
+6 WRITE !,"Pharmacy Drug Recall List",!!
+7 DO ASKDATES^APSPUTIL(.APSPBD,.APSPED,.APSPQ,DT,DT)
+8 IF APSPQ
QUIT
+9 SET APSPBDF=$PIECE($TRANSLATE($$FMTE^XLFDT(APSPBD,"5Z"),"@"," "),":",1,2)
+10 SET APSPEDF=$PIECE($TRANSLATE($$FMTE^XLFDT(APSPED,"5Z"),"@"," "),":",1,2)
+11 SET APSPBD=APSPBD-.01
SET APSPED=APSPED+.99
+12 ;SELECT DIVISION
+13 SET APSPDIV=$$DIR^APSPUTIL("Y","Would you like all pharmacy divisions","Yes",,.APSPQ)
+14 IF APSPQ
QUIT
+15 IF APSPDIV
Begin DoDot:1
+16 SET APSPDIV="*"
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET APSPDIV=$$GETIEN^APSPUTIL(59,"Select Pharmacy Division: ",.APSPQ)
End DoDot:1
IF APSPQ
QUIT
+19 FOR
Begin DoDot:1
+20 SET APSPDRG=$$GETIEN^APSPUTIL(50,"Select Drug Name: ",,"QM")
+21 IF APSPDRG<1
SET QFLG=1
QUIT
+22 SET APSPDARY(APSPDRG)=""
+23 SET DCNT=DCNT+1
+24 SET QFLG='$$DIR^APSPUTIL("Y","Want to Select Another Drug","No",,.APSPQ)
+25 IF 'QFLG
SET QFLG=APSPQ
End DoDot:1
IF QFLG
QUIT
+26 IF 'DCNT
QUIT
+27 DO DEV
+28 QUIT
DEV ;
+1 NEW XBRP,XBNS
+2 SET XBRP="OUT^APSPDR3"
+3 SET XBNS="APS*"
+4 DO ^XBDBQUE
+5 QUIT
OUT ;
+1 NEW APSPDT,RXIEN,APSPNOD,FTYPE,DRG
+2 SET APSPDT=APSPBD
FOR
SET APSPDT=$ORDER(^PSRX("ZAL",APSPDT))
IF 'APSPDT!(APSPDT>APSPED)
QUIT
Begin DoDot:1
+3 SET RXIEN=0
FOR
SET RXIEN=$ORDER(^PSRX("ZAL",APSPDT,RXIEN))
IF 'RXIEN
QUIT
Begin DoDot:2
+4 SET APSPNOD=0
FOR
SET APSPNOD=$ORDER(^PSRX("ZAL",APSPDT,RXIEN,APSPNOD))
IF 'APSPNOD
QUIT
Begin DoDot:3
+5 SET FTYPE=""
FOR
SET FTYPE=$ORDER(^PSRX("ZAL",APSPDT,RXIEN,APSPNOD,FTYPE))
IF FTYPE=""
QUIT
DO CHECK
End DoDot:3
End DoDot:2
End DoDot:1
+6 DO EN^APSPDR4
+7 QUIT
CHECK ;EP
+1 NEW DIV
+2 IF '$DATA(^PSRX(RXIEN,0))
QUIT
+3 SET DRG=$PIECE($GET(^PSRX(RXIEN,0)),U,6)
+4 ; Must have a drug
IF 'DRG
QUIT
+5 IF '$DATA(^PSDRUG(DRG,0))
QUIT
+6 ; Not a selected drug
IF '$DATA(APSPDARY(DRG))
QUIT
+7 ; Pharmacy Division IEN
SET DIV=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:APSPNOD_","_RXIEN_",",1:RXIEN),$SELECT(FTYPE="P":.09,FTYPE="R":8,1:20),"I")
+8 ; Check Division
IF '$$DIVVRY(DIV,APSPDIV)
QUIT
+9 DO SET(RXIEN,DRG,DIV)
+10 QUIT
+11 ; Return boolean flag indicating valid pharmacy division
DIVVRY(RXDIV,RPTDIV) ;EP
+1 IF RPTDIV="*"
QUIT 1
+2 QUIT RXDIV=RPTDIV
+3 ;
SET(RX,DRG,DIV) ;EP
+1 NEW STA,RXN,DFN,QTY,DRGNM,NXT
+2 SET STA=$PIECE($GET(^PSRX(RX,"STA")),U)
+3 ; Prescription marked as deleted
IF STA=13
QUIT
+4 ;IHS/MSC/PLS - 10/10/2017
+5 ;Q:FTYPE="N"&($P($G(^PSRX(RX,2)),U,15)) Q ; Prescription has been returned to stock
+6 ; Prescription has been returned to stock
IF FTYPE="N"&($PIECE($GET(^PSRX(RX,2)),U,15))
QUIT
+7 SET NXT=$ORDER(^TMP($JOB,"DATA",$CHAR(1)),-1)
+8 SET NXT=NXT+1
+9 ;PRESCRIPTION NUMBER ON FILE
SET RXN=$PIECE(^PSRX(RX,0),U)
+10 ;PATIENT NUMBER FOR THE PERSON FILE
SET DFN=$PIECE(^PSRX(RX,0),U,2)
+11 SET QTY=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:APSPNOD_","_RX_",",1:RX),$SELECT(FTYPE="P":.04,FTYPE="R":1,1:7))
+12 ;DRUG NAME
SET DRGNM=$PIECE(^PSDRUG(DRG,0),U)
+13 SET ^TMP($JOB,"PSODR",DIV,DFN,APSPDT,RX,NXT)=""
+14 SET ^TMP($JOB,"DATA",NXT)=DIV_U_APSPDT_U_DRGNM_U_QTY_U_RXN
+15 QUIT
