APSPDUR ;IHS/DSD/JCM/ENM - PHARMACY DUR;14-Sep-2010 12:41;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1004,1008,1009**;Sep 23, 2004
;THIS ROUTINE BUILDS THE PHARMACY DRUG UTILIZATION REVIEW GLOBAL
;IT RUNS AND THEN CALLS APSPDUR1 TO DO THE ACUTAL PRINT OF LIST
;
EN ;EP
N APSPBD,APSPED,APSPBDF,APSPEDF,APSPDIV,APSPDRG,APSPDARY
N QFLG,DCNT
S (QFLG,DCNT)=0
W @IOF
W "Pharmacy DUR 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 ;EP
N XBRP,XBNS
S XBRP="OUT^APSPDUR"
S XBNS="APS*"
D ^XBDBQUE
Q
OUT ;EP
U IO
K ^TMP($J)
D FIND(APSPBD,APSPED,"AD",.APSPDARY)
D FIND(APSPBD,APSPED,"ADP",.APSPDARY)
D EN^APSPDUR1
K ^TMP($J)
Q
FIND(SDT,EDT,XREF,DARY) ;EP
N RXIEN,ACTIEN,RTSDT,FILLDT,A0,FDTLP,IEN,DRG
S FDTLP=SDT-.01
F S FDTLP=$O(^PSRX(XREF,FDTLP)) Q:'FDTLP!(FDTLP>EDT) D
.S RXIEN=0
.F S RXIEN=$O(^PSRX(XREF,FDTLP,RXIEN)) Q:'RXIEN D
..Q:$$CHKSTAT(RXIEN) ; check prescription status
..S DRG=$P(^PSRX(RXIEN,0),U,6)
..Q:'DRG ; Prescription must have a drug
..Q:'$D(^PSDRUG(DRG,0))
..Q:'$D(DARY(DRG))
..S IEN="" F S IEN=$O(^PSRX(XREF,FDTLP,RXIEN,IEN)) Q:IEN="" D
...Q:'IEN&($$GET1^DIQ(52,RXIEN,32.1,"I")) ; Quit if original fill anda return to stock date exists
...Q:'$$DIVVRY(RXIEN,APSPDIV,XREF,IEN) ;check division
...Q:'$$DSPRDT(RXIEN,XREF,IEN) ;check for release date
...D SET(FDTLP,RXIEN,XREF,IEN)
Q
; Check status business rules
; Input: RX - Prescription IEN
; Output: 0 - Prescription status OK, 1- Failed check
CHKSTAT(RX) ; EP
N STA
S STA=$P($G(^PSRX(RX,"STA")),U)
Q:STA=13 1 ; Deleted
Q 0
; Return release date for dispense
DSPRDT(RX,TYP,SIEN) ;EP
Q $S($G(SIEN):+$P($G(^PSRX(RX,$S(TYP="ADP":"P",1:1),SIEN,0)),U,$S(TYP="ADP":19,1:18)),1:+$P(^PSRX(RX,2),U,13))
; Return boolean flag indicating valid pharmacy division
DIVVRY(RX,DIV,TYP,SIEN) ;EP
Q:DIV="*" 1
Q $S($G(SIEN):DIV=+$P($G(^PSRX(RX,$S(TYP="ADP":"P",1:1),SIEN,0)),U,9),1:DIV=+$P(^PSRX(RX,2),U,9))
SET(FDT,RX,XREF,SIEN) ;EP
N RXN,DFN,QTY,DRGNM,REMARK,OPRV,FTYPE,DIV,NXT
S FTYPE=$S(XREF="ADP":"P",SIEN:"R",1:"F")
S NXT=$O(^TMP($J,"DATA",$C(1)),-1)
S NXT=NXT+1
S RXN=$P(^PSRX(RX,0),U) ; Prescription number
S DFN=$P(^PSRX(RX,0),U,2) ; Patient IFN
S DIV=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RXIEN_",",1:RXIEN),$S(FTYPE="P":.09,FTYPE="R":8,1:20),"I") ; Pharmacy Division IEN
S QTY=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RX_",",1:RX),$S(FTYPE="P":.04,FTYPE="R":1,1:7))
S DRGNM=$P(^PSDRUG(DRG,0),U) ;Drug Name
S OPRV=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RX_",",1:RX),$S(FTYPE="P":6,FTYPE="R":15,1:4),"I")
S REMARK=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RX_",",1:RX),$S(FTYPE="P":.03,FTYPE="R":3,1:12))
S ^TMP($J,"DATA",NXT)=DIV_U_FDT_U_DRGNM_U_QTY_U_RXN_U_OPRV_U_REMARK
S ^TMP($J,"PSODUR",DIV,DFN,FDT,RX,NXT)=""
Q
APSPDUR ;IHS/DSD/JCM/ENM - PHARMACY DUR;14-Sep-2010 12:41;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1004,1008,1009**;Sep 23, 2004
+2 ;THIS ROUTINE BUILDS THE PHARMACY DRUG UTILIZATION REVIEW GLOBAL
+3 ;IT RUNS AND THEN CALLS APSPDUR1 TO DO THE ACUTAL PRINT OF LIST
+4 ;
EN ;EP
+1 NEW APSPBD,APSPED,APSPBDF,APSPEDF,APSPDIV,APSPDRG,APSPDARY
+2 NEW QFLG,DCNT
+3 SET (QFLG,DCNT)=0
+4 WRITE @IOF
+5 WRITE "Pharmacy DUR List ",!!
+6 DO ASKDATES^APSPUTIL(.APSPBD,.APSPED,.APSPQ,DT,DT)
+7 IF APSPQ
QUIT
+8 SET APSPBDF=$PIECE($TRANSLATE($$FMTE^XLFDT(APSPBD,"5Z"),"@"," "),":",1,2)
+9 SET APSPEDF=$PIECE($TRANSLATE($$FMTE^XLFDT(APSPED,"5Z"),"@"," "),":",1,2)
+10 SET APSPBD=APSPBD-.01
SET APSPED=APSPED+.99
+11 ;SELECT DIVISION
+12 SET APSPDIV=$$DIR^APSPUTIL("Y","Would you like all pharmacy divisions","Yes",,.APSPQ)
+13 IF APSPQ
QUIT
+14 IF APSPDIV
Begin DoDot:1
+15 SET APSPDIV="*"
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 SET APSPDIV=$$GETIEN^APSPUTIL(59,"Select Pharmacy Division: ",.APSPQ)
End DoDot:1
IF APSPQ
QUIT
+18 FOR
Begin DoDot:1
+19 SET APSPDRG=$$GETIEN^APSPUTIL(50,"Select Drug Name: ",,"QM")
+20 IF APSPDRG<1
SET QFLG=1
QUIT
+21 SET APSPDARY(APSPDRG)=""
+22 SET DCNT=DCNT+1
+23 SET QFLG='$$DIR^APSPUTIL("Y","Want to Select Another Drug","No",,.APSPQ)
+24 IF 'QFLG
SET QFLG=APSPQ
End DoDot:1
IF QFLG
QUIT
+25 IF 'DCNT
QUIT
+26 DO DEV
+27 QUIT
DEV ;EP
+1 NEW XBRP,XBNS
+2 SET XBRP="OUT^APSPDUR"
+3 SET XBNS="APS*"
+4 DO ^XBDBQUE
+5 QUIT
OUT ;EP
+1 USE IO
+2 KILL ^TMP($JOB)
+3 DO FIND(APSPBD,APSPED,"AD",.APSPDARY)
+4 DO FIND(APSPBD,APSPED,"ADP",.APSPDARY)
+5 DO EN^APSPDUR1
+6 KILL ^TMP($JOB)
+7 QUIT
FIND(SDT,EDT,XREF,DARY) ;EP
+1 NEW RXIEN,ACTIEN,RTSDT,FILLDT,A0,FDTLP,IEN,DRG
+2 SET FDTLP=SDT-.01
+3 FOR
SET FDTLP=$ORDER(^PSRX(XREF,FDTLP))
IF 'FDTLP!(FDTLP>EDT)
QUIT
Begin DoDot:1
+4 SET RXIEN=0
+5 FOR
SET RXIEN=$ORDER(^PSRX(XREF,FDTLP,RXIEN))
IF 'RXIEN
QUIT
Begin DoDot:2
+6 ; check prescription status
IF $$CHKSTAT(RXIEN)
QUIT
+7 SET DRG=$PIECE(^PSRX(RXIEN,0),U,6)
+8 ; Prescription must have a drug
IF 'DRG
QUIT
+9 IF '$DATA(^PSDRUG(DRG,0))
QUIT
+10 IF '$DATA(DARY(DRG))
QUIT
+11 SET IEN=""
FOR
SET IEN=$ORDER(^PSRX(XREF,FDTLP,RXIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+12 ; Quit if original fill anda return to stock date exists
IF 'IEN&($$GET1^DIQ(52,RXIEN,32.1,"I"))
QUIT
+13 ;check division
IF '$$DIVVRY(RXIEN,APSPDIV,XREF,IEN)
QUIT
+14 ;check for release date
IF '$$DSPRDT(RXIEN,XREF,IEN)
QUIT
+15 DO SET(FDTLP,RXIEN,XREF,IEN)
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ; Check status business rules
+18 ; Input: RX - Prescription IEN
+19 ; Output: 0 - Prescription status OK, 1- Failed check
CHKSTAT(RX) ; EP
+1 NEW STA
+2 SET STA=$PIECE($GET(^PSRX(RX,"STA")),U)
+3 ; Deleted
IF STA=13
QUIT 1
+4 QUIT 0
+5 ; Return release date for dispense
DSPRDT(RX,TYP,SIEN) ;EP
+1 QUIT $SELECT($GET(SIEN):+$PIECE($GET(^PSRX(RX,$SELECT(TYP="ADP":"P",1:1),SIEN,0)),U,$SELECT(TYP="ADP":19,1:18)),1:+$PIECE(^PSRX(RX,2),U,13))
+2 ; Return boolean flag indicating valid pharmacy division
DIVVRY(RX,DIV,TYP,SIEN) ;EP
+1 IF DIV="*"
QUIT 1
+2 QUIT $SELECT($GET(SIEN):DIV=+$PIECE($GET(^PSRX(RX,$SELECT(TYP="ADP":"P",1:1),SIEN,0)),U,9),1:DIV=+$PIECE(^PSRX(RX,2),U,9))
SET(FDT,RX,XREF,SIEN) ;EP
+1 NEW RXN,DFN,QTY,DRGNM,REMARK,OPRV,FTYPE,DIV,NXT
+2 SET FTYPE=$SELECT(XREF="ADP":"P",SIEN:"R",1:"F")
+3 SET NXT=$ORDER(^TMP($JOB,"DATA",$CHAR(1)),-1)
+4 SET NXT=NXT+1
+5 ; Prescription number
SET RXN=$PIECE(^PSRX(RX,0),U)
+6 ; Patient IFN
SET DFN=$PIECE(^PSRX(RX,0),U,2)
+7 ; Pharmacy Division IEN
SET DIV=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RXIEN_",",1:RXIEN),$SELECT(FTYPE="P":.09,FTYPE="R":8,1:20),"I")
+8 SET QTY=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RX_",",1:RX),$SELECT(FTYPE="P":.04,FTYPE="R":1,1:7))
+9 ;Drug Name
SET DRGNM=$PIECE(^PSDRUG(DRG,0),U)
+10 SET OPRV=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RX_",",1:RX),$SELECT(FTYPE="P":6,FTYPE="R":15,1:4),"I")
+11 SET REMARK=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RX_",",1:RX),$SELECT(FTYPE="P":.03,FTYPE="R":3,1:12))
+12 SET ^TMP($JOB,"DATA",NXT)=DIV_U_FDT_U_DRGNM_U_QTY_U_RXN_U_OPRV_U_REMARK
+13 SET ^TMP($JOB,"PSODUR",DIV,DFN,FDT,RX,NXT)=""
+14 QUIT
