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

PSSMRRDG.m

Go to the documentation of this file.
  1. 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
  1. Q
  1. ;
  1. 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
  1. ; Input param: P1 = default is null and checks for 2.1 node
  1. ; = if pass in a value, then it will not check 2.1
  1. ;
  1. W ! K %ZIS,IOP,ZTSK S %ZIS("B")="",%ZIS="QM" D ^%ZIS I POP Q
  1. 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",!
  1. 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
  1. S ZTRTN="MAIN^PSSMRRDG",ZTDESC="Orders for MRRs With Removal Properties" D ^%ZTLOAD K IO("Q")
  1. Q
  1. ;
  1. MAIN ; main control
  1. N DFN,MRR,MRRAR,ORD,STP,ORDTOT,DDOI,DDTXT,QQ,YY,STS,PSSID,PSSLOC,PSSQ,PSSPATCH,ORDSDT
  1. N CLNODE,LIN,MRRFL,OI,PAGNO,POP
  1. N $ESTACK,$ETRAP S $ETRAP="D ERRTRP^PSSMRRDG" ;
  1. S P1=$G(P1) ;define P1 to null if not passed
  1. S PSSPATCH=$S($G(P2):1,1:'$$PATCH^XPDUTL("PSJ*5.0*315"))
  1. ;build array of OI's that are mrr and their flag value
  1. F QQ=0:0 S QQ=$O(^PSDRUG("ASP",QQ)) Q:QQ="" D
  1. . F YY=0:0 S YY=$O(^PSDRUG("ASP",QQ,YY)) Q:'YY D
  1. .. S OI=$P(^PSDRUG(YY,2),U)
  1. .. S MRRFL=$P($G(^PS(50.7,OI,4)),U,1)
  1. .. S:MRRFL MRRAR(OI)=MRRFL
  1. ..Q
  1. .Q
  1. ;
  1. ; Use Ord Stop Date XREF to look for current orders
  1. S ORDTOT=0,PSSQ=0,PAGNO=0,ORDSDT=DT
  1. F S ORDSDT=$O(^PS(55,"AUD",ORDSDT)) Q:ORDSDT="" D
  1. . S DFN=0
  1. . F S DFN=$O(^PS(55,"AUD",ORDSDT,DFN)) Q:DFN="" D
  1. .. S ORD=0
  1. .. F S ORD=$O(^PS(55,"AUD",ORDSDT,DFN,ORD)) Q:ORD="" D
  1. ... S STS=$P($G(^PS(55,DFN,5,ORD,0)),U,9)
  1. ... S CLNODE=$G(^PS(55,DFN,5,ORD,8),0)
  1. ... ;non Active type order, quit dont include
  1. ... I (STS="D")!(STS="E")!(STS="DE")!(STS="DR") Q
  1. ... 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))
  1. ... D CHKORD ;check and then set ^TMP for sort
  1. ...Q
  1. ..Q
  1. .Q
  1. D:$D(^TMP("PSSMRRDG")) PRINT
  1. D:ORDTOT=0 HDR
  1. I 'PSSQ W !!,"Total Orders found: ",ORDTOT,!
  1. W !!,"Press RETURN to continue....." R X:$G(DTIME) ;pause before returning to Detail screen
  1. K ^TMP("PSSMRRDG")
  1. Q
  1. ;
  1. CHKORD ;check if Order qualifies and then print on report
  1. ; return mrrfl which is positive or true (1,2,3)
  1. F QQ=0:0 S QQ=$O(^PS(55,DFN,5,ORD,1,QQ)) Q:'QQ D
  1. . S DDOI=+$P($G(^PS(55,DFN,5,ORD,.2)),U)
  1. . S MRR=$G(MRRAR(DDOI))
  1. . Q:'MRR ;don't report not a MRR med
  1. . ; don't report if has a 2.1 node, unless P1 overrides
  1. . I $G(P1)="",$D(^PS(55,DFN,5,ORD,2.1)) Q
  1. . 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")
  1. . S DDTXT=$$GET1^DIQ(55.07,QQ_","_ORD_","_DFN,"DISPENSE DRUG")
  1. . S ^TMP("PSSMRRDG",PSSLOC,PSSID)=DDTXT_U_STS_U_MRR
  1. .Q
  1. Q
  1. ;
  1. PRINT ;
  1. N STR S PSSLOC=""
  1. F S PSSLOC=$O(^TMP("PSSMRRDG",PSSLOC)) Q:PSSLOC=""!PSSQ D
  1. . D HDR S PSSID=""
  1. . F S PSSID=$O(^TMP("PSSMRRDG",PSSLOC,PSSID)) Q:PSSID=""!PSSQ D
  1. .. S STR=^TMP("PSSMRRDG",PSSLOC,PSSID),DDTXT=$P(STR,U),STS=$P(STR,U,2),MRR=$P(STR,U,3)
  1. .. D WRITELN S ORDTOT=ORDTOT+1
  1. .. I $Y>(IOSL-1) D PAUSE Q:PSSQ
  1. ..Q
  1. . D PAUSE Q:PSSQ
  1. .Q
  1. Q
  1. ;
  1. HDR ;Write a heading on report
  1. S PAGNO=PAGNO+1
  1. W @IOF
  1. W !,$E($$FMTE^XLFDT($$NOW^XLFDT),1,18),?125,"Page ",PAGNO
  1. I 'PSSPATCH D H1,BODY Q
  1. D H2,BODY
  1. Q
  1. ;
  1. H1 ; heading for Pre-PSJ315 install
  1. W !,?2,"The following ACTIVE Orders are for Medications Requiring Removal (MRR). Prior to Installation of PSJ*5*315 these orders"
  1. 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"
  1. W !,?2,"re-entered after coordinating with your ADPAC."
  1. Q
  1. H2 ; heading for Post-PSJ315 install
  1. W !,?2,"The following ACTIVE orders for medications that Require Removal (MRR) were finished prior to install of Patch PSJ*5*315."
  1. W !,?2,"These orders must be re-entered. They may not be copied, renewed or edited to create new orders."
  1. W !,?33,"Any changes to these orders should be coordinated with your ADPAC."
  1. Q
  1. BODY ;
  1. W !!,?50," Sort by Patient within Ward "_$G(PSSLOC,"NONE FOUND")
  1. W !!,"Patient",?10,"Patient",?30,"Orderable",?75,"Ordr",?80,"MRR"
  1. W !,"ID",?10,"Loc",?30,"Item Name",?75,"Sts",?80,"Val"
  1. S $P(LIN,"-",132)=""
  1. W !,LIN
  1. Q
  1. ;
  1. WRITELN ;Write line on report
  1. W !,PSSID,?10,PSSLOC,?30,DDTXT,?76,STS,?81,MRR
  1. Q
  1. ;
  1. PAUSE ;
  1. Q:'($G(TERM))
  1. N X
  1. W !!,"Press RETURN to continue, '^' to exit"
  1. R X:$G(DTIME) I (X="^")!('$T) S PSSQ=1 Q
  1. U IO
  1. Q
  1. ;
  1. CLINIC(CL) ;Is this a Clinic order that would show on the VDL in CO mode also?
  1. Q:'($P(CL,"^",2)?7N!($P(CL,"^",2)?7N1".".N)) 0 ;no appt date, IM ord
  1. Q:'$D(^PS(53.46,"B",+CL)) 0 ;no PTR to 44, IM ord
  1. N A S A=$O(^PS(53.46,"B",+CL,"")) Q:'A 0 ;no 53.46 ien, IM ord
  1. Q $P(^PS(53.46,A,0),"^",4) ;Send to BCMA? flag
  1. ;
  1. TST(P2) ;
  1. S P2=$G(P2),P1=1
  1. D EN(P1)
  1. Q
  1. ;
  1. ERRTRP ; Error trap processing
  1. N Z,PROBLEM
  1. S Z(1,1)=$$EC^%ZOSV ; mumps error location and description
  1. S Z="A SYSTEM ERROR HAS BEEN DETECTED AT THE FOLLOWING LOCATION"
  1. S PROBLEM=7
  1. D ^%ZTER ; record the error in the trap
  1. G UNWIND^%ZTER ; unwind stack levels
  1. Q