APSPRRTS ; IHS/MSC/PLS - RETURN TO STOCK REPORT ;23-Sep-2010 18:27;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1007,1008,1009**;Sep 23, 2004
;
EN ;EP
N APSPBD,APSPED,APSPDIV,APSPRTYP,APSPQ,APSPDSUB,APSPDCLS
N APSPDCT,APSPDCTN,APSPDRG,APSPBDF,APSPEDF
S APSPDIV="",APSPDRG="",APSPQ=0,APSPDSUB=0
W @IOF
W !!,"Pharmacy Return to Stock report by Division"
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
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)
S APSPRTYP=+$$DIR^APSPUTIL("S^1:Specific Drug Name;2:Drug Class;3:All Drugs","Sort report by",,,.APSPQ)
Q:APSPQ
I APSPRTYP=1 D Q:APSPQ
.S APSPDRG=$$GETIEN^APSPUTIL(50,"Select Drug Name: ",.APSPQ)
E I APSPRTYP=2 D Q:APSPQ
.S APSPDCLS=$$DIR^APSPUTIL("S^1:C-II;2:C-II through C-V;3:C-III through C-V","Drug Class Types","",,.APSPQ)
.Q:APSPQ
.S APSPDSUB=1 ;$$DIR^APSPUTIL("Y","Secondary sort by drug name",,,.APSPQ)
.S APSPDCT(1)="2",APSPDCT(2)="2345",APSPDCT(3)="345"
.S APSPDCTN(1)="C-II",APSPDCTN(2)="C-II through C-V",APSPDCTN(3)="C-III through C-V"
E D
.S APSPDRG="*"
.S APSPDSUB=$$DIR^APSPUTIL("Y","Sort by generic drug name","No",,.APSPQ)
D DEV
Q
DEV ;
N XBRP,XBNS
S XBRP="OUT^APSPRRTS"
S XBNS="APS*"
D ^XBDBQUE
Q
OUT ;EP
K ^TMP($J)
D FIND($G(APSPDCLS))
D PRINT
Q
;
FIND(DCLS) ;EP
N RXIEN,ACTIEN,RTSDT,FILLDT,A0
S RXIEN=0
F S RXIEN=$O(^PSRX(RXIEN)) Q:'RXIEN D
.Q:'$D(^PSRX(RXIEN,0)) ; Prescription must have a zero node
.Q:'$$DIVVRY(RXIEN,APSPDIV) ;check division
.Q:'$P(^PSRX(RXIEN,0),U,6) ; Prescription must have a drug
.I APSPRTYP=1 Q:'$$DRGVRY(APSPDRG,RXIEN) ; Check for matching drug
.I APSPRTYP=2 Q:'$$DCVRY(DCLS,RXIEN) ;Quit if Drug Class search and drug doesn't match class
.S ACTIEN=0
.F S ACTIEN=$O(^PSRX(RXIEN,"A",ACTIEN)) Q:'ACTIEN D
..S A0=$G(^PSRX(RXIEN,"A",ACTIEN,0))
..Q:$P(A0,U,2)'="I" ; Check for RETURN reason
..Q:+A0<APSPBD!(+A0>APSPED) ;Check activity date against report date parameters
..D SET(RXIEN,ACTIEN)
Q
;
PRINT ;EP
N APSPPG,DFLG
S (APSPPG,DFLG)=0
D HDR
D PRINT1
W:'DFLG !,"No data found..."
Q
;
PRINT1 ;EP
;This EP makes use of the MUMPS naked reference syntax.
N DIV,SUB1,SUB2,SUB3,SUB4,VAL
S DIV=0 F S DIV=$O(^TMP($J,"XREF",DIV)) Q:'DIV D
.I APSPDIV="*" W !,"|"_$$GET1^DIQ(59,DIV,.01)_"|" D PRINT3
.I APSPRTYP=1!(APSPRTYP=3&APSPDSUB) D
..S SUB1="" F S SUB1=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1)) Q:'$L(SUB1) D
...S SUB2=0 F S SUB2=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1,SUB2)) Q:'SUB2 D
....S SUB3=0 F S SUB3=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3)) Q:'SUB3 D
.....S VAL=^(SUB3)
.....D PRINT2(^TMP($J,"DATA",VAL))
.....S DFLG=1
.E I 'APSPDSUB D
..S SUB1=0 F S SUB1=$O(^TMP($J,"XREF",DIV,"RTS",SUB1)) Q:'SUB1 D
...S SUB2=0 F S SUB2=$O(^TMP($J,"XREF",DIV,"RTS",SUB1,SUB2)) Q:'SUB2 D
....S VAL=^(SUB2)
....D PRINT2(^TMP($J,"DATA",VAL))
....S DFLG=1
.E I APSPRTYP=2 D
..S SUB1="" F S SUB1=$O(^TMP($J,"XREF",DIV,"DCLS",SUB1)) Q:'$L(SUB1) D
...S SUB2="" F S SUB2=$O(^TMP($J,"XREF",DIV,"DCLS",SUB1,SUB2)) Q:'$L(SUB2) D
....S SUB3=0 F S SUB3=$O(^TMP($J,"XREF",DIV,"DCLS",SUB1,SUB2,SUB3)) Q:'SUB3 D
.....S SUB4=0 F S SUB4=$O(^TMP($J,"XREF",DIV,"DCLS",SUB1,SUB2,SUB3,SUB4)) Q:'SUB4 D
......S VAL=^(SUB4)
......D PRINT2(^TMP($J,"DATA",VAL))
......S DFLG=1
Q
; Print the line
PRINT2(DATA) ;EP
W !,$P($TR($$FMTE^XLFDT($P(DATA,U),"5Z"),"@"," "),":",1,2)_$P(DATA,U,8),?20,$P(DATA,U,9)_$P(DATA,U,3),?38,$P(DATA,U,7),?53,$E($P(DATA,U,6),1,34),?95,$P(DATA,U,4),?101,$$FMTE^XLFDT($P(DATA,U,2),"5Z"),?116,$P(DATA,U,10)
D PRINT3 ;check page length
Q
; Check page length
PRINT3 ;EP
D:$Y+8>IOSL HDR
Q
; Set data into ^TMP global for output
SET(RX,ACT) ;EP
N LSTDSPDT,NODE0,NODE2,NODE3,DIV,DCLS,RTSDATE,DRUG,RDT,RIFLG
N ACT0,ACTREF,HRN
S NXT=$O(^TMP($J,"DATA",$C(1)),-1)
S NXT=NXT+1
S NODE0=^PSRX(RX,0)
S NODE2=$G(^PSRX(RX,2)) ; IHS/MSC/PLS - 06/20/08 - Added $G
S NODE3=$G(^PSRX(RX,3)) ; IHS/MSC/PLS - 06/20/08 - Added $G
S DIV=$P(NODE2,U,9)
S DRUG=$P(NODE0,U,6)
S DRGNM=$P(^PSDRUG(DRUG,0),U)
S DCLS=+$P(^PSDRUG(DRUG,0),U,3)
S DCLS=$$CVTDCLS(DCLS)
S LSTDSPDT=+NODE3
S RIFLG=""
S ACT0=$G(^PSRX(RX,"A",ACT,0))
S RTSDATE=$P(+ACT0,".") ; IHS/MSC/PLS - 06/20/08 - Added $G
S HRN=$$HRN^AUPNPAT($P(NODE0,U,2),$$GET1^DIQ(59,DIV,100,"I")) ;IHS/MSC/PLS - 06/29/10 - Added line
S ACTREF=$P(ACT0,U,4) ;RX Reference - 6=partial
S RDT=$$GET1^DIQ(52,RX,31,"I") ;Release Date
I RDT>APSPBD,RDT<APSPED D
.S:'$$GET1^DIQ(52.3,ACT_","_RX_",",.04,"I") RIFLG="*"
S ^TMP($J,"DATA",NXT)=RTSDATE_U_LSTDSPDT_U_$P(NODE0,U)_U_$S(ACTREF=6:"#",1:$P(NODE0,U,7))_U_DCLS_U_DRGNM_U_$$GET1^DIQ(52.3,ACT_","_RX_",",.04)_U_RIFLG_U_$$DELFLG(RX)_U_HRN
S ^TMP($J,"XREF",DIV,"RTS",RTSDATE,RX)=NXT
S ^TMP($J,"XREF",DIV,"DCLS",DCLS,DRGNM,RTSDATE,RX)=NXT
S ^TMP($J,"XREF",DIV,"DRUG",DRGNM,RTSDATE,RX)=NXT
Q
; Return boolean flag indicating prescription drug matches selected drug
DRGVRY(DRUG,RX) ;EP
Q $P($G(^PSRX(RX,0)),U,6)=DRUG
; Return boolean flag indicating prescription drug matches selected report drug class
; Input: DCLS - Drug Class based on input selected by user
; RX - Prescription IEN
DCVRY(DCLS,RX) ;EP
N RXRTSDT,DRGIEN,DCLSVAL
S RXRTSDT=$P($G(^PSRX(RXIEN,2)),U,15)
S DRGIEN=$P(^PSRX(RX,0),U,6)
Q:'$D(^PSDRUG(DRGIEN,0)) 0 ; Check for missing drug entry
S DCLSVAL=$P(^PSDRUG(DRGIEN,0),U,3)
Q APSPDCT(DCLS)[+DCLSVAL
; Return boolean flag indicating valid pharmacy division
DIVVRY(RX,DIV) ;EP
Q:DIV="*" 1
Q DIV=+$P($G(^PSRX(RX,2)),U,9) ; IHS/MSC/PLS -06/20/08 - Added $G
;
CVTDCLS(DCLS) ; EP
Q:DCLS=2 "C-II"
Q:DCLS=3 "C-III"
Q:DCLS=4 "C-IV"
Q:DCLS=5 "C-V"
Q "C-UNKNOWN"
;
; Return '*' flag indicated prescription has been deleted
DELFLG(RX) ;EP
Q $S($G(^PSRX(RX,"STA"))=13:"*",1:" ")
HDR ;EP
W @IOF
S APSPPG=APSPPG+1
W !,"Returned to Stock Report",?35,$P($TR($$FMTE^XLFDT($$NOW^XLFDT,"5Z"),"@"," "),":",1,2),?(IOM-10),"Page: "_APSPPG
W !,"Report Criteria: (An '*' after RTS Date indicates a reissued original Rx.)"
W !," (An '*' prior to the Rx Number indicates a deleted prescription.)"
W !," (A '#' indicates that quantity is unknown for returned partial fill.)"
W !,?5,"Inclusive Dates: "_APSPBDF_" to "_APSPEDF
W !,?5,"Pharmacy Division: "_$S(APSPDIV:$$GET1^DIQ(59,APSPDIV,.01),1:"All")
W !,?5,"Type of Search: "_$S(APSPRTYP=3:"All Drugs",APSPRTYP=2:"Drug Class ("_APSPDCTN(APSPDCLS)_")",APSPRTYP=1:"Specific Drug ("_$$GET1^DIQ(50,APSPDRG,.01)_")",1:"")
W !,?5,"Sorted by: "_$S($G(APSPDCLS):"Drug Class then Drug Name then RTS Date/Time",$G(APSPDSUB):"Drug Name then RTS Date/Time",1:"RTS Date/Time")
D HDR1
Q
;
HDR1 ;EP
D DASH
W "RTS Date/Time",?20,"Rx Number",?38,"Act Reference",?53,"Drug Name",?95,"Qty",?101,"Last Disp Date",?116,"Pt ID"
D DASH
Q
;
DASH ;EP
N DASH
W ! F DASH=1:1:IOM W "-"
W !
Q
APSPRRTS ; IHS/MSC/PLS - RETURN TO STOCK REPORT ;23-Sep-2010 18:27;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1007,1008,1009**;Sep 23, 2004
+2 ;
EN ;EP
+1 NEW APSPBD,APSPED,APSPDIV,APSPRTYP,APSPQ,APSPDSUB,APSPDCLS
+2 NEW APSPDCT,APSPDCTN,APSPDRG,APSPBDF,APSPEDF
+3 SET APSPDIV=""
SET APSPDRG=""
SET APSPQ=0
SET APSPDSUB=0
+4 WRITE @IOF
+5 WRITE !!,"Pharmacy Return to Stock report by Division"
+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 SET APSPDIV=$$DIR^APSPUTIL("Y","Would you like all pharmacy divisions","Yes",,.APSPQ)
+12 IF APSPQ
QUIT
+13 IF APSPDIV
Begin DoDot:1
+14 SET APSPDIV="*"
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET APSPDIV=$$GETIEN^APSPUTIL(59,"Select Pharmacy Division: ",.APSPQ)
End DoDot:1
IF APSPQ
QUIT
+17 SET APSPRTYP=+$$DIR^APSPUTIL("S^1:Specific Drug Name;2:Drug Class;3:All Drugs","Sort report by",,,.APSPQ)
+18 IF APSPQ
QUIT
+19 IF APSPRTYP=1
Begin DoDot:1
+20 SET APSPDRG=$$GETIEN^APSPUTIL(50,"Select Drug Name: ",.APSPQ)
End DoDot:1
IF APSPQ
QUIT
+21 IF '$TEST
IF APSPRTYP=2
Begin DoDot:1
+22 SET APSPDCLS=$$DIR^APSPUTIL("S^1:C-II;2:C-II through C-V;3:C-III through C-V","Drug Class Types","",,.APSPQ)
+23 IF APSPQ
QUIT
+24 ;$$DIR^APSPUTIL("Y","Secondary sort by drug name",,,.APSPQ)
SET APSPDSUB=1
+25 SET APSPDCT(1)="2"
SET APSPDCT(2)="2345"
SET APSPDCT(3)="345"
+26 SET APSPDCTN(1)="C-II"
SET APSPDCTN(2)="C-II through C-V"
SET APSPDCTN(3)="C-III through C-V"
End DoDot:1
IF APSPQ
QUIT
+27 IF '$TEST
Begin DoDot:1
+28 SET APSPDRG="*"
+29 SET APSPDSUB=$$DIR^APSPUTIL("Y","Sort by generic drug name","No",,.APSPQ)
End DoDot:1
+30 DO DEV
+31 QUIT
DEV ;
+1 NEW XBRP,XBNS
+2 SET XBRP="OUT^APSPRRTS"
+3 SET XBNS="APS*"
+4 DO ^XBDBQUE
+5 QUIT
OUT ;EP
+1 KILL ^TMP($JOB)
+2 DO FIND($GET(APSPDCLS))
+3 DO PRINT
+4 QUIT
+5 ;
FIND(DCLS) ;EP
+1 NEW RXIEN,ACTIEN,RTSDT,FILLDT,A0
+2 SET RXIEN=0
+3 FOR
SET RXIEN=$ORDER(^PSRX(RXIEN))
IF 'RXIEN
QUIT
Begin DoDot:1
+4 ; Prescription must have a zero node
IF '$DATA(^PSRX(RXIEN,0))
QUIT
+5 ;check division
IF '$$DIVVRY(RXIEN,APSPDIV)
QUIT
+6 ; Prescription must have a drug
IF '$PIECE(^PSRX(RXIEN,0),U,6)
QUIT
+7 ; Check for matching drug
IF APSPRTYP=1
IF '$$DRGVRY(APSPDRG,RXIEN)
QUIT
+8 ;Quit if Drug Class search and drug doesn't match class
IF APSPRTYP=2
IF '$$DCVRY(DCLS,RXIEN)
QUIT
+9 SET ACTIEN=0
+10 FOR
SET ACTIEN=$ORDER(^PSRX(RXIEN,"A",ACTIEN))
IF 'ACTIEN
QUIT
Begin DoDot:2
+11 SET A0=$GET(^PSRX(RXIEN,"A",ACTIEN,0))
+12 ; Check for RETURN reason
IF $PIECE(A0,U,2)'="I"
QUIT
+13 ;Check activity date against report date parameters
IF +A0<APSPBD!(+A0>APSPED)
QUIT
+14 DO SET(RXIEN,ACTIEN)
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
PRINT ;EP
+1 NEW APSPPG,DFLG
+2 SET (APSPPG,DFLG)=0
+3 DO HDR
+4 DO PRINT1
+5 IF 'DFLG
WRITE !,"No data found..."
+6 QUIT
+7 ;
PRINT1 ;EP
+1 ;This EP makes use of the MUMPS naked reference syntax.
+2 NEW DIV,SUB1,SUB2,SUB3,SUB4,VAL
+3 SET DIV=0
FOR
SET DIV=$ORDER(^TMP($JOB,"XREF",DIV))
IF 'DIV
QUIT
Begin DoDot:1
+4 IF APSPDIV="*"
WRITE !,"|"_$$GET1^DIQ(59,DIV,.01)_"|"
DO PRINT3
+5 IF APSPRTYP=1!(APSPRTYP=3&APSPDSUB)
Begin DoDot:2
+6 SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1))
IF '$LENGTH(SUB1)
QUIT
Begin DoDot:3
+7 SET SUB2=0
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1,SUB2))
IF 'SUB2
QUIT
Begin DoDot:4
+8 SET SUB3=0
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3))
IF 'SUB3
QUIT
Begin DoDot:5
+9 SET VAL=^(SUB3)
+10 DO PRINT2(^TMP($JOB,"DATA",VAL))
+11 SET DFLG=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+12 IF '$TEST
IF 'APSPDSUB
Begin DoDot:2
+13 SET SUB1=0
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"RTS",SUB1))
IF 'SUB1
QUIT
Begin DoDot:3
+14 SET SUB2=0
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"RTS",SUB1,SUB2))
IF 'SUB2
QUIT
Begin DoDot:4
+15 SET VAL=^(SUB2)
+16 DO PRINT2(^TMP($JOB,"DATA",VAL))
+17 SET DFLG=1
End DoDot:4
End DoDot:3
End DoDot:2
+18 IF '$TEST
IF APSPRTYP=2
Begin DoDot:2
+19 SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"DCLS",SUB1))
IF '$LENGTH(SUB1)
QUIT
Begin DoDot:3
+20 SET SUB2=""
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"DCLS",SUB1,SUB2))
IF '$LENGTH(SUB2)
QUIT
Begin DoDot:4
+21 SET SUB3=0
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"DCLS",SUB1,SUB2,SUB3))
IF 'SUB3
QUIT
Begin DoDot:5
+22 SET SUB4=0
FOR
SET SUB4=$ORDER(^TMP($JOB,"XREF",DIV,"DCLS",SUB1,SUB2,SUB3,SUB4))
IF 'SUB4
QUIT
Begin DoDot:6
+23 SET VAL=^(SUB4)
+24 DO PRINT2(^TMP($JOB,"DATA",VAL))
+25 SET DFLG=1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ; Print the line
PRINT2(DATA) ;EP
+1 WRITE !,$PIECE($TRANSLATE($$FMTE^XLFDT($PIECE(DATA,U),"5Z"),"@"," "),":",1,2)_$PIECE(DATA,U,8),?20,$PIECE(DATA,U,9)_$PIECE(DATA,U,3),?38,$PIECE(DATA,U,7),?53,...
... $EXTRACT($PIECE(DATA,U,6),1,34),?95,$PIECE(DATA,U,4),?101,$$FMTE^XLFDT($PIECE(DATA,U,2),"5Z"),?116,$PIECE(DATA,U,10)
+2 ;check page length
DO PRINT3
+3 QUIT
+4 ; Check page length
PRINT3 ;EP
+1 IF $Y+8>IOSL
DO HDR
+2 QUIT
+3 ; Set data into ^TMP global for output
SET(RX,ACT) ;EP
+1 NEW LSTDSPDT,NODE0,NODE2,NODE3,DIV,DCLS,RTSDATE,DRUG,RDT,RIFLG
+2 NEW ACT0,ACTREF,HRN
+3 SET NXT=$ORDER(^TMP($JOB,"DATA",$CHAR(1)),-1)
+4 SET NXT=NXT+1
+5 SET NODE0=^PSRX(RX,0)
+6 ; IHS/MSC/PLS - 06/20/08 - Added $G
SET NODE2=$GET(^PSRX(RX,2))
+7 ; IHS/MSC/PLS - 06/20/08 - Added $G
SET NODE3=$GET(^PSRX(RX,3))
+8 SET DIV=$PIECE(NODE2,U,9)
+9 SET DRUG=$PIECE(NODE0,U,6)
+10 SET DRGNM=$PIECE(^PSDRUG(DRUG,0),U)
+11 SET DCLS=+$PIECE(^PSDRUG(DRUG,0),U,3)
+12 SET DCLS=$$CVTDCLS(DCLS)
+13 SET LSTDSPDT=+NODE3
+14 SET RIFLG=""
+15 SET ACT0=$GET(^PSRX(RX,"A",ACT,0))
+16 ; IHS/MSC/PLS - 06/20/08 - Added $G
SET RTSDATE=$PIECE(+ACT0,".")
+17 ;IHS/MSC/PLS - 06/29/10 - Added line
SET HRN=$$HRN^AUPNPAT($PIECE(NODE0,U,2),$$GET1^DIQ(59,DIV,100,"I"))
+18 ;RX Reference - 6=partial
SET ACTREF=$PIECE(ACT0,U,4)
+19 ;Release Date
SET RDT=$$GET1^DIQ(52,RX,31,"I")
+20 IF RDT>APSPBD
IF RDT<APSPED
Begin DoDot:1
+21 IF '$$GET1^DIQ(52.3,ACT_","_RX_",",.04,"I")
SET RIFLG="*"
End DoDot:1
+22 SET ^TMP($JOB,"DATA",NXT)=RTSDATE_U_LSTDSPDT_U_$PIECE(NODE0,U)_U_$SELECT(ACTREF=6:"#",1:$PIECE(NODE0,U,7))_U_DCLS_U_DRGNM_U_$$GET1^DIQ(52.3,ACT_","_RX_",",.04)_U_RIFLG_U_$$DELFLG(RX)_U_HRN
+23 SET ^TMP($JOB,"XREF",DIV,"RTS",RTSDATE,RX)=NXT
+24 SET ^TMP($JOB,"XREF",DIV,"DCLS",DCLS,DRGNM,RTSDATE,RX)=NXT
+25 SET ^TMP($JOB,"XREF",DIV,"DRUG",DRGNM,RTSDATE,RX)=NXT
+26 QUIT
+27 ; Return boolean flag indicating prescription drug matches selected drug
DRGVRY(DRUG,RX) ;EP
+1 QUIT $PIECE($GET(^PSRX(RX,0)),U,6)=DRUG
+2 ; Return boolean flag indicating prescription drug matches selected report drug class
+3 ; Input: DCLS - Drug Class based on input selected by user
+4 ; RX - Prescription IEN
DCVRY(DCLS,RX) ;EP
+1 NEW RXRTSDT,DRGIEN,DCLSVAL
+2 SET RXRTSDT=$PIECE($GET(^PSRX(RXIEN,2)),U,15)
+3 SET DRGIEN=$PIECE(^PSRX(RX,0),U,6)
+4 ; Check for missing drug entry
IF '$DATA(^PSDRUG(DRGIEN,0))
QUIT 0
+5 SET DCLSVAL=$PIECE(^PSDRUG(DRGIEN,0),U,3)
+6 QUIT APSPDCT(DCLS)[+DCLSVAL
+7 ; Return boolean flag indicating valid pharmacy division
DIVVRY(RX,DIV) ;EP
+1 IF DIV="*"
QUIT 1
+2 ; IHS/MSC/PLS -06/20/08 - Added $G
QUIT DIV=+$PIECE($GET(^PSRX(RX,2)),U,9)
+3 ;
CVTDCLS(DCLS) ; EP
+1 IF DCLS=2
QUIT "C-II"
+2 IF DCLS=3
QUIT "C-III"
+3 IF DCLS=4
QUIT "C-IV"
+4 IF DCLS=5
QUIT "C-V"
+5 QUIT "C-UNKNOWN"
+6 ;
+7 ; Return '*' flag indicated prescription has been deleted
DELFLG(RX) ;EP
+1 QUIT $SELECT($GET(^PSRX(RX,"STA"))=13:"*",1:" ")
HDR ;EP
+1 WRITE @IOF
+2 SET APSPPG=APSPPG+1
+3 WRITE !,"Returned to Stock Report",?35,$PIECE($TRANSLATE($$FMTE^XLFDT($$NOW^XLFDT,"5Z"),"@"," "),":",1,2),?(IOM-10),"Page: "_APSPPG
+4 WRITE !,"Report Criteria: (An '*' after RTS Date indicates a reissued original Rx.)"
+5 WRITE !," (An '*' prior to the Rx Number indicates a deleted prescription.)"
+6 WRITE !," (A '#' indicates that quantity is unknown for returned partial fill.)"
+7 WRITE !,?5,"Inclusive Dates: "_APSPBDF_" to "_APSPEDF
+8 WRITE !,?5,"Pharmacy Division: "_$SELECT(APSPDIV:$$GET1^DIQ(59,APSPDIV,.01),1:"All")
+9 WRITE !,?5,"Type of Search: "_$SELECT(APSPRTYP=3:"All Drugs",APSPRTYP=2:"Drug Class ("_APSPDCTN(APSPDCLS)_")",APSPRTYP=1:"Specific Drug ("_$$GET1^DIQ(50,APSPDRG,.01)_")",1:"")
+10 WRITE !,?5,"Sorted by: "_$SELECT($GET(APSPDCLS):"Drug Class then Drug Name then RTS Date/Time",$GET(APSPDSUB):"Drug Name then RTS Date/Time",1:"RTS Date/Time")
+11 DO HDR1
+12 QUIT
+13 ;
HDR1 ;EP
+1 DO DASH
+2 WRITE "RTS Date/Time",?20,"Rx Number",?38,"Act Reference",?53,"Drug Name",?95,"Qty",?101,"Last Disp Date",?116,"Pt ID"
+3 DO DASH
+4 QUIT
+5 ;
DASH ;EP
+1 NEW DASH
+2 WRITE !
FOR DASH=1:1:IOM
WRITE "-"
+3 WRITE !
+4 QUIT
