APSPCTR ; IHS/DSD/ENM/BAO/DMH/CIA/PLS - CONTROLLED DRUG LIST BY DIV;10-Nov-2011 13:16;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1004,1006,1008,1009,1013**;Sep 23, 2004;Build 33
; Modified - IHS/CIA/PLS - 01/13/04 - Updated version
; Modified - IHS/CIA/PLS - 02/24/06 - Patch 1004
; Modified - IHS/MSC/PLS - 09/26/07 - Patch 1006 - Added CHKSTAT check and business rule for DE date=Fill date for exclusion
; IHS/MSC/PLS - 12/30/08 - Patch 1008 - Routine updated
; - 08/31/09 - Patch 1008 - Added DSPRDT for release date check
; - 12/14/09 - Patch 1009 - removed check for $$DIVVRY in the inital loop of Find.
; - 11/10/11 - Patch 1013 - TallMan support
EN ;EP
N APSP,APSPAT,APSPATN,APSPBD,APSPCHN,APSPD,APSPDES,APSPDR,APSPBD,APSPED,APSPX,APSPN,APSPRX,APSPSH,DIC,APSPANS,APSPDTDR
N APSPDRUG,APSPED,APSPGO,APSPITM,APSPMD,APSPMSG,APSPOP,APSPQTY,APSPRN,APSPRXN,APSPZZ,APSPBD,APSPCLER,APSPDIV,APSPDV
N APSPGT,APSPT,APSPC9,%ZIS,%DT,POP,APSPQ,APSPBDF,APSPEDF
W @IOF,!!,"Pharmacy Controlled Drug List by Division"
W !,*7,?10,"132 Character Format!",!
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)
Q:APSPQ
S APSPDTDR=$$DIR^APSPUTIL("S^1:Date;2:Drug","Sort Report by",,,.APSPQ)
Q:APSPQ
D Q:APSPQ
.S APSPDCLS=$$DIR^APSPUTIL("S^1:C-2'S;2:C-3'S to C5'S;3:All","Drug Class Types","",,.APSPQ)
.S APSPDCT(1)="2",APSPDCT(3)="2345",APSPDCT(2)="345"
.S APSPDCTN(1)="C-II",APSPDCTN(2)="C-III through C-V",APSPDCTN(3)="C-II through C-V"
D DEV
Q
DEV ;
N XBRP,XBNS
S XBRP="OUT^APSPCTR"
S XBNS="APS*"
D ^XBDBQUE
Q
OUT ;EP
U IO
K ^TMP($J)
D FIND(APSPBD,APSPED,"AD",$G(APSPDCLS)) ; Regular and Refill
D FIND(APSPBD,APSPED,"ADP",$G(APSPDCLS)) ; Partial
D PRINT^APSPCTR1
K ^TMP($J)
Q
;
FIND(SDT,EDT,XREF,DCLS) ;EP
N RXIEN,ACTIEN,RTSDT,FILLDT,A0,FDTLP,IEN
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
..;Q:'$$DIVVRY(RXIEN,APSPDIV) ;check division ;Patch 1009 commented out
..Q:'$P(^PSRX(RXIEN,0),U,6) ; Prescription must have a drug
..Q:'$$DCVRY(APSPDCLS,RXIEN) ;Quit if Drug Class search and drug doesn't match class
..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 and a 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:STA=5 1 ;Suspended
; Discontinue/Edit Status and (Fill Date = Order D/C Date) per PSG
I STA=15,$$GET1^DIQ(52,RX,22,"I")=$P($$GET1^DIQ(100,$$GET1^DIQ(52,RX,39.3,"I"),63,"I"),".") Q 1
Q 0
; 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)) ; 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,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))
; 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))
; Set data into ^TMP global for output
SET(FDT,RX,XREF,SIEN) ;EP
N LSTDSPDT,NODE0,NODE2,NODE3,DIV,DCLS,RTSDATE,DRUG,RDT,RIFLG,FTYPE
N PNM,DFN,DAYS,OPRV,PHRM,QTY,OPRVNM,CLERK,EDCLS,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 NODE0=^PSRX(RX,0)
S NODE2=^PSRX(RX,2)
S NODE3=^PSRX(RX,3)
S DRUG=$P(NODE0,U,6)
S DFN=$P(NODE0,U,2)
S PNM=$$GET1^DIQ(2,DFN,.01)
S DRGNM=$P(^PSDRUG(DRUG,0),U)
S DCLS=+$P(^PSDRUG(DRUG,0),U,3)
S EDCLS=$$CVTDCLS(DCLS)
S LSTDSPDT=+NODE3
S RIFLG=""
S DIV=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RX_",",1:RX),$S(FTYPE="P":.09,FTYPE="R":8,1:20),"I") ; Pharmacy Division IEN
S RDT=$$GET1^DIQ(52,RX,31,"I") ;Release Date
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 DAYS=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RX_",",1:RX),$S(FTYPE="P":.041,FTYPE="R":1.1,1:8))
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 OPRVNM=$$GET1^DIQ(200,OPRV,.01)
S CLERK=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RX_",",1:RX),$S(FTYPE="P":.07,FTYPE="R":6,1:16),"I")
S:'$L(OPRVNM) OPRVNM="NONAME"
S PHRM=$$GET1^DIQ($S(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$S("PR"[FTYPE:SIEN_","_RX_",",1:RX),$S(FTYPE="P":.05,FTYPE="R":4,1:23),"I")
; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
;Format: Prescription IEN^Fill Date^Xref ("AD" or "ADP")^Fill SubIEN^Prescription Number^QTY^Drug Class^Drug Name^Fill Type^RI Flg^Drug IEN^RX Division^Days Supply^Prescriber^Pharmacist^Clerk
S ^TMP($J,"DATA",NXT)=RXIEN_U_FDT_U_XREF_U_SIEN_U_$P(NODE0,U)_U_QTY_U_EDCLS_U_DRGNM_U_FTYPE_U_RIFLG_U_DRUG_U_DIV_U_DAYS_U_OPRV_U_PHRM_U_CLERK
S DRGNM=$$UP^XLFSTR(DRGNM) ;1013
S ^TMP($J,"XREF",DIV,"FDT",FDT,DCLS,DRGNM,NXT)=""
S ^TMP($J,"XREF",DIV,"DRUG",DRGNM,DCLS,FDT,NXT)=""
S ^TMP($J,"XREF","RX",RX,FTYPE,SIEN)=NXT
Q
;
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"
APSPCTR ; IHS/DSD/ENM/BAO/DMH/CIA/PLS - CONTROLLED DRUG LIST BY DIV;10-Nov-2011 13:16;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1004,1006,1008,1009,1013**;Sep 23, 2004;Build 33
+2 ; Modified - IHS/CIA/PLS - 01/13/04 - Updated version
+3 ; Modified - IHS/CIA/PLS - 02/24/06 - Patch 1004
+4 ; Modified - IHS/MSC/PLS - 09/26/07 - Patch 1006 - Added CHKSTAT check and business rule for DE date=Fill date for exclusion
+5 ; IHS/MSC/PLS - 12/30/08 - Patch 1008 - Routine updated
+6 ; - 08/31/09 - Patch 1008 - Added DSPRDT for release date check
+7 ; - 12/14/09 - Patch 1009 - removed check for $$DIVVRY in the inital loop of Find.
+8 ; - 11/10/11 - Patch 1013 - TallMan support
EN ;EP
+1 NEW APSP,APSPAT,APSPATN,APSPBD,APSPCHN,APSPD,APSPDES,APSPDR,APSPBD,APSPED,APSPX,APSPN,APSPRX,APSPSH,DIC,APSPANS,APSPDTDR
+2 NEW APSPDRUG,APSPED,APSPGO,APSPITM,APSPMD,APSPMSG,APSPOP,APSPQTY,APSPRN,APSPRXN,APSPZZ,APSPBD,APSPCLER,APSPDIV,APSPDV
+3 NEW APSPGT,APSPT,APSPC9,%ZIS,%DT,POP,APSPQ,APSPBDF,APSPEDF
+4 WRITE @IOF,!!,"Pharmacy Controlled Drug List by Division"
+5 WRITE !,*7,?10,"132 Character Format!",!
+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 IF APSPQ
QUIT
+19 SET APSPDTDR=$$DIR^APSPUTIL("S^1:Date;2:Drug","Sort Report by",,,.APSPQ)
+20 IF APSPQ
QUIT
+21 Begin DoDot:1
+22 SET APSPDCLS=$$DIR^APSPUTIL("S^1:C-2'S;2:C-3'S to C5'S;3:All","Drug Class Types","",,.APSPQ)
+23 SET APSPDCT(1)="2"
SET APSPDCT(3)="2345"
SET APSPDCT(2)="345"
+24 SET APSPDCTN(1)="C-II"
SET APSPDCTN(2)="C-III through C-V"
SET APSPDCTN(3)="C-II through C-V"
End DoDot:1
IF APSPQ
QUIT
+25 DO DEV
+26 QUIT
DEV ;
+1 NEW XBRP,XBNS
+2 SET XBRP="OUT^APSPCTR"
+3 SET XBNS="APS*"
+4 DO ^XBDBQUE
+5 QUIT
OUT ;EP
+1 USE IO
+2 KILL ^TMP($JOB)
+3 ; Regular and Refill
DO FIND(APSPBD,APSPED,"AD",$GET(APSPDCLS))
+4 ; Partial
DO FIND(APSPBD,APSPED,"ADP",$GET(APSPDCLS))
+5 DO PRINT^APSPCTR1
+6 KILL ^TMP($JOB)
+7 QUIT
+8 ;
FIND(SDT,EDT,XREF,DCLS) ;EP
+1 NEW RXIEN,ACTIEN,RTSDT,FILLDT,A0,FDTLP,IEN
+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 ;Q:'$$DIVVRY(RXIEN,APSPDIV) ;check division ;Patch 1009 commented out
+8 ; Prescription must have a drug
IF '$PIECE(^PSRX(RXIEN,0),U,6)
QUIT
+9 ;Quit if Drug Class search and drug doesn't match class
IF '$$DCVRY(APSPDCLS,RXIEN)
QUIT
+10 SET IEN=""
FOR
SET IEN=$ORDER(^PSRX(XREF,FDTLP,RXIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+11 ; Quit if original fill and a return to stock date exists
IF 'IEN&($$GET1^DIQ(52,RXIEN,32.1,"I"))
QUIT
+12 ;check division
IF '$$DIVVRY(RXIEN,APSPDIV,XREF,IEN)
QUIT
+13 ;check for release date
IF '$$DSPRDT(RXIEN,XREF,IEN)
QUIT
+14 DO SET(FDTLP,RXIEN,XREF,IEN)
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ; Check status business rules
+17 ; Input: RX - Prescription IEN
+18 ; 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 ;Q:STA=5 1 ;Suspended
+5 ; Discontinue/Edit Status and (Fill Date = Order D/C Date) per PSG
+6 IF STA=15
IF $$GET1^DIQ(52,RX,22,"I")=$PIECE($$GET1^DIQ(100,$$GET1^DIQ(52,RX,39.3,"I"),63,"I"),".")
QUIT 1
+7 QUIT 0
+8 ; Return boolean flag indicating prescription drug matches selected report drug class
+9 ; Input: DCLS - Drug Class based on input selected by user
+10 ; 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
+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,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))
+3 ; 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 ; Set data into ^TMP global for output
SET(FDT,RX,XREF,SIEN) ;EP
+1 NEW LSTDSPDT,NODE0,NODE2,NODE3,DIV,DCLS,RTSDATE,DRUG,RDT,RIFLG,FTYPE
+2 NEW PNM,DFN,DAYS,OPRV,PHRM,QTY,OPRVNM,CLERK,EDCLS,NXT
+3 SET FTYPE=$SELECT(XREF="ADP":"P",SIEN:"R",1:"F")
+4 SET NXT=$ORDER(^TMP($JOB,"DATA",$CHAR(1)),-1)
+5 SET NXT=NXT+1
+6 SET NODE0=^PSRX(RX,0)
+7 SET NODE2=^PSRX(RX,2)
+8 SET NODE3=^PSRX(RX,3)
+9 SET DRUG=$PIECE(NODE0,U,6)
+10 SET DFN=$PIECE(NODE0,U,2)
+11 SET PNM=$$GET1^DIQ(2,DFN,.01)
+12 SET DRGNM=$PIECE(^PSDRUG(DRUG,0),U)
+13 SET DCLS=+$PIECE(^PSDRUG(DRUG,0),U,3)
+14 SET EDCLS=$$CVTDCLS(DCLS)
+15 SET LSTDSPDT=+NODE3
+16 SET RIFLG=""
+17 ; Pharmacy Division IEN
SET DIV=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RX_",",1:RX),$SELECT(FTYPE="P":.09,FTYPE="R":8,1:20),"I")
+18 ;Release Date
SET RDT=$$GET1^DIQ(52,RX,31,"I")
+19 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))
+20 SET DAYS=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RX_",",1:RX),$SELECT(FTYPE="P":.041,FTYPE="R":1.1,1:8))
+21 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")
+22 SET OPRVNM=$$GET1^DIQ(200,OPRV,.01)
+23 SET CLERK=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RX_",",1:RX),$SELECT(FTYPE="P":.07,FTYPE="R":6,1:16),"I")
+24 IF '$LENGTH(OPRVNM)
SET OPRVNM="NONAME"
+25 SET PHRM=$$GET1^DIQ($SELECT(FTYPE="P":52.2,FTYPE="R":52.1,1:52),$SELECT("PR"[FTYPE:SIEN_","_RX_",",1:RX),$SELECT(FTYPE="P":.05,FTYPE="R":4,1:23),"I")
+26 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
+27 ;Format: Prescription IEN^Fill Date^Xref ("AD" or "ADP")^Fill SubIEN^Prescription Number^QTY^Drug Class^Drug Name^Fill Type^RI Flg^Drug IEN^RX Division^Days Supply^Prescriber^Pharmacist^Clerk
+28 SET ^TMP($JOB,"DATA",NXT)=RXIEN_U_FDT_U_XREF_U_SIEN_U_$PIECE(NODE0,U)_U_QTY_U_EDCLS_U_DRGNM_U_FTYPE_U_RIFLG_U_DRUG_U_DIV_U_DAYS_U_OPRV_U_PHRM_U_CLERK
+29 ;1013
SET DRGNM=$$UP^XLFSTR(DRGNM)
+30 SET ^TMP($JOB,"XREF",DIV,"FDT",FDT,DCLS,DRGNM,NXT)=""
+31 SET ^TMP($JOB,"XREF",DIV,"DRUG",DRGNM,DCLS,FDT,NXT)=""
+32 SET ^TMP($JOB,"XREF","RX",RX,FTYPE,SIEN)=NXT
+33 QUIT
+34 ;
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"
