Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSPDR3

APSPDR3.m

Go to the documentation of this file. 
  1. 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
  1.  ;THIS ROUTINE BUILDS THE PHARMACY DRUG RECALL LIST
  1.  ; IHS/MSC/PLS - 01/02/09 - Routine updated
  1.  ;               12/16/09 - Modified GETIEN1 call to GETIEN for File 50
  1.  ;               10/10/17 - Removed trailing Q at SET+4
  1. EN ;
  1.  N APSPBD,APSPED,APSPBDF,APSPEDF,APSPDIV,APSPDRG,APSPDARY
  1.  N QFLG,DCNT
  1.  S (QFLG,DCNT)=0
  1.  K ^TMP($J,"PSODR")
  1.  W @IOF
  1.  W !,"Pharmacy Drug Recall List",!!
  1.  D ASKDATES^APSPUTIL(.APSPBD,.APSPED,.APSPQ,DT,DT)
  1.  Q:APSPQ
  1.  S APSPBDF=$P($TR($$FMTE^XLFDT(APSPBD,"5Z"),"@"," "),":",1,2)
  1.  S APSPEDF=$P($TR($$FMTE^XLFDT(APSPED,"5Z"),"@"," "),":",1,2)
  1.  S APSPBD=APSPBD-.01,APSPED=APSPED+.99
  1.  ;SELECT DIVISION
  1.  S APSPDIV=$$DIR^APSPUTIL("Y","Would you like all pharmacy divisions","Yes",,.APSPQ)
  1.  Q:APSPQ
  1.  I APSPDIV D
  1.  .S APSPDIV="*"
  1.  E  D  Q:APSPQ
  1.  .S APSPDIV=$$GETIEN^APSPUTIL(59,"Select Pharmacy Division: ",.APSPQ)
  1.  F  D  Q:QFLG
  1.  .S APSPDRG=$$GETIEN^APSPUTIL(50,"Select Drug Name: ",,"QM")
  1.  .I APSPDRG<1 S QFLG=1 Q
  1.  .S APSPDARY(APSPDRG)=""
  1.  .S DCNT=DCNT+1
  1.  .S QFLG='$$DIR^APSPUTIL("Y","Want to Select Another Drug","No",,.APSPQ)
  1.  .S:'QFLG QFLG=APSPQ
  1.  Q:'DCNT
  1.  D DEV
  1.  Q
  1. DEV ;
  1.  N XBRP,XBNS
  1.  S XBRP="OUT^APSPDR3"
  1.  S XBNS="APS*"
  1.  D ^XBDBQUE
  1.  Q
  1. OUT ;
  1.  N APSPDT,RXIEN,APSPNOD,FTYPE,DRG
  1.  S APSPDT=APSPBD F  S APSPDT=$O(^PSRX("ZAL",APSPDT)) Q:'APSPDT!(APSPDT>APSPED)  D
  1.  .S RXIEN=0 F  S RXIEN=$O(^PSRX("ZAL",APSPDT,RXIEN)) Q:'RXIEN  D
  1.  ..S APSPNOD=0 F  S APSPNOD=$O(^PSRX("ZAL",APSPDT,RXIEN,APSPNOD)) Q:'APSPNOD  D
  1.  ...S FTYPE="" F  S FTYPE=$O(^PSRX("ZAL",APSPDT,RXIEN,APSPNOD,FTYPE)) Q:FTYPE=""  D CHECK
  1.  D EN^APSPDR4
  1.  Q
  1. CHECK ;EP
  1.  N DIV
  1.  Q:'$D(^PSRX(RXIEN,0))
  1.  S DRG=$P($G(^PSRX(RXIEN,0)),U,6)
  1.  Q:'DRG  ; Must have a drug
  1.  Q:'$D(^PSDRUG(DRG,0))
  1.  Q:'$D(APSPDARY(DRG))  ; Not a selected drug
  1.  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
  1.  Q:'$$DIVVRY(DIV,APSPDIV)  ; Check Division
  1.  D SET(RXIEN,DRG,DIV)
  1.  Q
  1.  ; Return boolean flag indicating valid pharmacy division
  1. DIVVRY(RXDIV,RPTDIV) ;EP
  1.  Q:RPTDIV="*" 1
  1.  Q RXDIV=RPTDIV
  1.  ;
  1. SET(RX,DRG,DIV) ;EP
  1.  N STA,RXN,DFN,QTY,DRGNM,NXT
  1.  S STA=$P($G(^PSRX(RX,"STA")),U)
  1.  Q:STA=13  ; Prescription marked as deleted
  1.  ;IHS/MSC/PLS - 10/10/2017
  1.  ;Q:FTYPE="N"&($P($G(^PSRX(RX,2)),U,15)) Q  ; Prescription has been returned to stock
  1.  Q:FTYPE="N"&($P($G(^PSRX(RX,2)),U,15))  ; Prescription has been returned to stock
  1.  S NXT=$O(^TMP($J,"DATA",$C(1)),-1)
  1.  S NXT=NXT+1
  1.  S RXN=$P(^PSRX(RX,0),U) ;PRESCRIPTION NUMBER ON FILE
  1.  S DFN=$P(^PSRX(RX,0),U,2) ;PATIENT NUMBER FOR THE PERSON FILE
  1.  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))
  1.  S DRGNM=$P(^PSDRUG(DRG,0),U) ;DRUG NAME
  1.  S ^TMP($J,"PSODR",DIV,DFN,APSPDT,RX,NXT)=""
  1.  S ^TMP($J,"DATA",NXT)=DIV_U_APSPDT_U_DRGNM_U_QTY_U_RXN
  1.  Q