PSSMRRDG ;BIRMINGHAM/GN/DRP-Diagnostic Report only, does not update ;9/25/15 10:03am
;;1.0;PHARMACY DATA MANAGEMENT;**191**;9/30/97;Build 40
Q
;
EN(P1) ;Check for MRR meds missing the 2.1 node which is new and would be
;there if an order was created and Finished after patch PSJ*3*315
; Input param: P1 = default is null and checks for 2.1 node
; = if pass in a value, then it will not check 2.1
;
W ! K %ZIS,IOP,ZTSK S %ZIS("B")="",%ZIS="QM" D ^%ZIS I POP Q
I $E($G(IOST),1,2)="C-" W $C(7),!?5,"It is recommended to Queue this report to a printer for Large sites, enter Q at Device prompt",!
I '$D(IO("Q")) N TERM U IO S:$E(IOSL,1)'["9" TERM=$S($E($G(IOST),1,2)="C-":1,1:0) D MAIN,^%ZISC Q
S ZTRTN="MAIN^PSSMRRDG",ZTDESC="Orders for MRRs With Removal Properties" D ^%ZTLOAD K IO("Q")
Q
;
MAIN ; main control
N DFN,MRR,MRRAR,ORD,STP,ORDTOT,DDOI,DDTXT,QQ,YY,STS,PSSID,PSSLOC,PSSQ,PSSPATCH,ORDSDT
N CLNODE,LIN,MRRFL,OI,PAGNO,POP
N $ESTACK,$ETRAP S $ETRAP="D ERRTRP^PSSMRRDG" ;
S P1=$G(P1) ;define P1 to null if not passed
S PSSPATCH=$S($G(P2):1,1:'$$PATCH^XPDUTL("PSJ*5.0*315"))
;build array of OI's that are mrr and their flag value
F QQ=0:0 S QQ=$O(^PSDRUG("ASP",QQ)) Q:QQ="" D
. F YY=0:0 S YY=$O(^PSDRUG("ASP",QQ,YY)) Q:'YY D
.. S OI=$P(^PSDRUG(YY,2),U)
.. S MRRFL=$P($G(^PS(50.7,OI,4)),U,1)
.. S:MRRFL MRRAR(OI)=MRRFL
..Q
.Q
;
; Use Ord Stop Date XREF to look for current orders
S ORDTOT=0,PSSQ=0,PAGNO=0,ORDSDT=DT
F S ORDSDT=$O(^PS(55,"AUD",ORDSDT)) Q:ORDSDT="" D
. S DFN=0
. F S DFN=$O(^PS(55,"AUD",ORDSDT,DFN)) Q:DFN="" D
.. S ORD=0
.. F S ORD=$O(^PS(55,"AUD",ORDSDT,DFN,ORD)) Q:ORD="" D
... S STS=$P($G(^PS(55,DFN,5,ORD,0)),U,9)
... S CLNODE=$G(^PS(55,DFN,5,ORD,8),0)
... ;non Active type order, quit dont include
... I (STS="D")!(STS="E")!(STS="DE")!(STS="DR") Q
... S PSSID=$S('$D(^DPT(DFN,0)):"NONE",1:$E($P($G(^DPT(DFN,0)),U,1),1)_$E($P($G(^DPT(DFN,0)),U,9),6,9))
... D CHKORD ;check and then set ^TMP for sort
...Q
..Q
.Q
D:$D(^TMP("PSSMRRDG")) PRINT
D:ORDTOT=0 HDR
I 'PSSQ W !!,"Total Orders found: ",ORDTOT,!
W !!,"Press RETURN to continue....." R X:$G(DTIME) ;pause before returning to Detail screen
K ^TMP("PSSMRRDG")
Q
;
CHKORD ;check if Order qualifies and then print on report
; return mrrfl which is positive or true (1,2,3)
F QQ=0:0 S QQ=$O(^PS(55,DFN,5,ORD,1,QQ)) Q:'QQ D
. S DDOI=+$P($G(^PS(55,DFN,5,ORD,.2)),U)
. S MRR=$G(MRRAR(DDOI))
. Q:'MRR ;don't report not a MRR med
. ; don't report if has a 2.1 node, unless P1 overrides
. I $G(P1)="",$D(^PS(55,DFN,5,ORD,2.1)) Q
. S PSSLOC=$S($$CLINIC(CLNODE):$P(^SC(+^PS(55,DFN,5,ORD,8),0),U,1),$G(^DPT(DFN,.1))]"":^DPT(DFN,.1),1:"UNKNOWN")
. S DDTXT=$$GET1^DIQ(55.07,QQ_","_ORD_","_DFN,"DISPENSE DRUG")
. S ^TMP("PSSMRRDG",PSSLOC,PSSID)=DDTXT_U_STS_U_MRR
.Q
Q
;
PRINT ;
N STR S PSSLOC=""
F S PSSLOC=$O(^TMP("PSSMRRDG",PSSLOC)) Q:PSSLOC=""!PSSQ D
. D HDR S PSSID=""
. F S PSSID=$O(^TMP("PSSMRRDG",PSSLOC,PSSID)) Q:PSSID=""!PSSQ D
.. S STR=^TMP("PSSMRRDG",PSSLOC,PSSID),DDTXT=$P(STR,U),STS=$P(STR,U,2),MRR=$P(STR,U,3)
.. D WRITELN S ORDTOT=ORDTOT+1
.. I $Y>(IOSL-1) D PAUSE Q:PSSQ
..Q
. D PAUSE Q:PSSQ
.Q
Q
;
HDR ;Write a heading on report
S PAGNO=PAGNO+1
W @IOF
W !,$E($$FMTE^XLFDT($$NOW^XLFDT),1,18),?125,"Page ",PAGNO
I 'PSSPATCH D H1,BODY Q
D H2,BODY
Q
;
H1 ; heading for Pre-PSJ315 install
W !,?2,"The following ACTIVE Orders are for Medications Requiring Removal (MRR). Prior to Installation of PSJ*5*315 these orders"
W !,?2,"should be reviewed for planning purposes, but no action taken. Once PSJ*5*315 is installed they will need to be d/c'd and"
W !,?2,"re-entered after coordinating with your ADPAC."
Q
H2 ; heading for Post-PSJ315 install
W !,?2,"The following ACTIVE orders for medications that Require Removal (MRR) were finished prior to install of Patch PSJ*5*315."
W !,?2,"These orders must be re-entered. They may not be copied, renewed or edited to create new orders."
W !,?33,"Any changes to these orders should be coordinated with your ADPAC."
Q
BODY ;
W !!,?50," Sort by Patient within Ward "_$G(PSSLOC,"NONE FOUND")
W !!,"Patient",?10,"Patient",?30,"Orderable",?75,"Ordr",?80,"MRR"
W !,"ID",?10,"Loc",?30,"Item Name",?75,"Sts",?80,"Val"
S $P(LIN,"-",132)=""
W !,LIN
Q
;
WRITELN ;Write line on report
W !,PSSID,?10,PSSLOC,?30,DDTXT,?76,STS,?81,MRR
Q
;
PAUSE ;
Q:'($G(TERM))
N X
W !!,"Press RETURN to continue, '^' to exit"
R X:$G(DTIME) I (X="^")!('$T) S PSSQ=1 Q
U IO
Q
;
CLINIC(CL) ;Is this a Clinic order that would show on the VDL in CO mode also?
Q:'($P(CL,"^",2)?7N!($P(CL,"^",2)?7N1".".N)) 0 ;no appt date, IM ord
Q:'$D(^PS(53.46,"B",+CL)) 0 ;no PTR to 44, IM ord
N A S A=$O(^PS(53.46,"B",+CL,"")) Q:'A 0 ;no 53.46 ien, IM ord
Q $P(^PS(53.46,A,0),"^",4) ;Send to BCMA? flag
;
TST(P2) ;
S P2=$G(P2),P1=1
D EN(P1)
Q
;
ERRTRP ; Error trap processing
N Z,PROBLEM
S Z(1,1)=$$EC^%ZOSV ; mumps error location and description
S Z="A SYSTEM ERROR HAS BEEN DETECTED AT THE FOLLOWING LOCATION"
S PROBLEM=7
D ^%ZTER ; record the error in the trap
G UNWIND^%ZTER ; unwind stack levels
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSMRRDG 5325 printed Sep 23, 2025@20:08:48 Page 2
PSSMRRDG ;BIRMINGHAM/GN/DRP-Diagnostic Report only, does not update ;9/25/15 10:03am
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**191**;9/30/97;Build 40
+2 QUIT
+3 ;
EN(P1) ;Check for MRR meds missing the 2.1 node which is new and would be
+1 ;there if an order was created and Finished after patch PSJ*3*315
+2 ; Input param: P1 = default is null and checks for 2.1 node
+3 ; = if pass in a value, then it will not check 2.1
+4 ;
+5 WRITE !
KILL %ZIS,IOP,ZTSK
SET %ZIS("B")=""
SET %ZIS="QM"
DO ^%ZIS
IF POP
QUIT
+6 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE $CHAR(7),!?5,"It is recommended to Queue this report to a printer for Large sites, enter Q at Device prompt",!
+7 IF '$DATA(IO("Q"))
NEW TERM
USE IO
if $EXTRACT(IOSL,1)'["9"
SET TERM=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
DO MAIN
DO ^%ZISC
QUIT
+8 SET ZTRTN="MAIN^PSSMRRDG"
SET ZTDESC="Orders for MRRs With Removal Properties"
DO ^%ZTLOAD
KILL IO("Q")
+9 QUIT
+10 ;
MAIN ; main control
+1 NEW DFN,MRR,MRRAR,ORD,STP,ORDTOT,DDOI,DDTXT,QQ,YY,STS,PSSID,PSSLOC,PSSQ,PSSPATCH,ORDSDT
+2 NEW CLNODE,LIN,MRRFL,OI,PAGNO,POP
+3 ;
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERRTRP^PSSMRRDG"
+4 ;define P1 to null if not passed
SET P1=$GET(P1)
+5 SET PSSPATCH=$SELECT($GET(P2):1,1:'$$PATCH^XPDUTL("PSJ*5.0*315"))
+6 ;build array of OI's that are mrr and their flag value
+7 FOR QQ=0:0
SET QQ=$ORDER(^PSDRUG("ASP",QQ))
if QQ=""
QUIT
Begin DoDot:1
+8 FOR YY=0:0
SET YY=$ORDER(^PSDRUG("ASP",QQ,YY))
if 'YY
QUIT
Begin DoDot:2
+9 SET OI=$PIECE(^PSDRUG(YY,2),U)
+10 SET MRRFL=$PIECE($GET(^PS(50.7,OI,4)),U,1)
+11 if MRRFL
SET MRRAR(OI)=MRRFL
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 ;
+15 ; Use Ord Stop Date XREF to look for current orders
+16 SET ORDTOT=0
SET PSSQ=0
SET PAGNO=0
SET ORDSDT=DT
+17 FOR
SET ORDSDT=$ORDER(^PS(55,"AUD",ORDSDT))
if ORDSDT=""
QUIT
Begin DoDot:1
+18 SET DFN=0
+19 FOR
SET DFN=$ORDER(^PS(55,"AUD",ORDSDT,DFN))
if DFN=""
QUIT
Begin DoDot:2
+20 SET ORD=0
+21 FOR
SET ORD=$ORDER(^PS(55,"AUD",ORDSDT,DFN,ORD))
if ORD=""
QUIT
Begin DoDot:3
+22 SET STS=$PIECE($GET(^PS(55,DFN,5,ORD,0)),U,9)
+23 SET CLNODE=$GET(^PS(55,DFN,5,ORD,8),0)
+24 ;non Active type order, quit dont include
+25 IF (STS="D")!(STS="E")!(STS="DE")!(STS="DR")
QUIT
+26 SET PSSID=$SELECT('$DATA(^DPT(DFN,0)):"NONE",1:$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,1),1)_$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,9))
+27 ;check and then set ^TMP for sort
DO CHKORD
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 if $DATA(^TMP("PSSMRRDG"))
DO PRINT
+32 if ORDTOT=0
DO HDR
+33 IF 'PSSQ
WRITE !!,"Total Orders found: ",ORDTOT,!
+34 ;pause before returning to Detail screen
WRITE !!,"Press RETURN to continue....."
READ X:$GET(DTIME)
+35 KILL ^TMP("PSSMRRDG")
+36 QUIT
+37 ;
CHKORD ;check if Order qualifies and then print on report
+1 ; return mrrfl which is positive or true (1,2,3)
+2 FOR QQ=0:0
SET QQ=$ORDER(^PS(55,DFN,5,ORD,1,QQ))
if 'QQ
QUIT
Begin DoDot:1
+3 SET DDOI=+$PIECE($GET(^PS(55,DFN,5,ORD,.2)),U)
+4 SET MRR=$GET(MRRAR(DDOI))
+5 ;don't report not a MRR med
if 'MRR
QUIT
+6 ; don't report if has a 2.1 node, unless P1 overrides
+7 IF $GET(P1)=""
IF $DATA(^PS(55,DFN,5,ORD,2.1))
QUIT
+8 SET PSSLOC=$SELECT($$CLINIC(CLNODE):$PIECE(^SC(+^PS(55,DFN,5,ORD,8),0),U,1),$GET(^DPT(DFN,.1))]"":^DPT(DFN,.1),1:"UNKNOWN")
+9 SET DDTXT=$$GET1^DIQ(55.07,QQ_","_ORD_","_DFN,"DISPENSE DRUG")
+10 SET ^TMP("PSSMRRDG",PSSLOC,PSSID)=DDTXT_U_STS_U_MRR
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
PRINT ;
+1 NEW STR
SET PSSLOC=""
+2 FOR
SET PSSLOC=$ORDER(^TMP("PSSMRRDG",PSSLOC))
if PSSLOC=""!PSSQ
QUIT
Begin DoDot:1
+3 DO HDR
SET PSSID=""
+4 FOR
SET PSSID=$ORDER(^TMP("PSSMRRDG",PSSLOC,PSSID))
if PSSID=""!PSSQ
QUIT
Begin DoDot:2
+5 SET STR=^TMP("PSSMRRDG",PSSLOC,PSSID)
SET DDTXT=$PIECE(STR,U)
SET STS=$PIECE(STR,U,2)
SET MRR=$PIECE(STR,U,3)
+6 DO WRITELN
SET ORDTOT=ORDTOT+1
+7 IF $Y>(IOSL-1)
DO PAUSE
if PSSQ
QUIT
+8 QUIT
End DoDot:2
+9 DO PAUSE
if PSSQ
QUIT
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
HDR ;Write a heading on report
+1 SET PAGNO=PAGNO+1
+2 WRITE @IOF
+3 WRITE !,$EXTRACT($$FMTE^XLFDT($$NOW^XLFDT),1,18),?125,"Page ",PAGNO
+4 IF 'PSSPATCH
DO H1
DO BODY
QUIT
+5 DO H2
DO BODY
+6 QUIT
+7 ;
H1 ; heading for Pre-PSJ315 install
+1 WRITE !,?2,"The following ACTIVE Orders are for Medications Requiring Removal (MRR). Prior to Installation of PSJ*5*315 these orders"
+2 WRITE !,?2,"should be reviewed for planning purposes, but no action taken. Once PSJ*5*315 is installed they will need to be d/c'd and"
+3 WRITE !,?2,"re-entered after coordinating with your ADPAC."
+4 QUIT
H2 ; heading for Post-PSJ315 install
+1 WRITE !,?2,"The following ACTIVE orders for medications that Require Removal (MRR) were finished prior to install of Patch PSJ*5*315."
+2 WRITE !,?2,"These orders must be re-entered. They may not be copied, renewed or edited to create new orders."
+3 WRITE !,?33,"Any changes to these orders should be coordinated with your ADPAC."
+4 QUIT
BODY ;
+1 WRITE !!,?50," Sort by Patient within Ward "_$GET(PSSLOC,"NONE FOUND")
+2 WRITE !!,"Patient",?10,"Patient",?30,"Orderable",?75,"Ordr",?80,"MRR"
+3 WRITE !,"ID",?10,"Loc",?30,"Item Name",?75,"Sts",?80,"Val"
+4 SET $PIECE(LIN,"-",132)=""
+5 WRITE !,LIN
+6 QUIT
+7 ;
WRITELN ;Write line on report
+1 WRITE !,PSSID,?10,PSSLOC,?30,DDTXT,?76,STS,?81,MRR
+2 QUIT
+3 ;
PAUSE ;
+1 if '($GET(TERM))
QUIT
+2 NEW X
+3 WRITE !!,"Press RETURN to continue, '^' to exit"
+4 READ X:$GET(DTIME)
IF (X="^")!('$TEST)
SET PSSQ=1
QUIT
+5 USE IO
+6 QUIT
+7 ;
CLINIC(CL) ;Is this a Clinic order that would show on the VDL in CO mode also?
+1 ;no appt date, IM ord
if '($PIECE(CL,"^",2)?7N!($PIECE(CL,"^",2)?7N1".".N))
QUIT 0
+2 ;no PTR to 44, IM ord
if '$DATA(^PS(53.46,"B",+CL))
QUIT 0
+3 ;no 53.46 ien, IM ord
NEW A
SET A=$ORDER(^PS(53.46,"B",+CL,""))
if 'A
QUIT 0
+4 ;Send to BCMA? flag
QUIT $PIECE(^PS(53.46,A,0),"^",4)
+5 ;
TST(P2) ;
+1 SET P2=$GET(P2)
SET P1=1
+2 DO EN(P1)
+3 QUIT
+4 ;
ERRTRP ; Error trap processing
+1 NEW Z,PROBLEM
+2 ; mumps error location and description
SET Z(1,1)=$$EC^%ZOSV
+3 SET Z="A SYSTEM ERROR HAS BEEN DETECTED AT THE FOLLOWING LOCATION"
+4 SET PROBLEM=7
+5 ; record the error in the trap
DO ^%ZTER
+6 ; unwind stack levels
GOTO UNWIND^%ZTER
+7 QUIT
