- 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 Jan 18, 2025@03:33: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