PSSP191A ;BIRMINGHAM/GN/DRP-Diagnostic Report only, does not update ; 9/25/15 2:36pm
;;1.0;PHARMACY DATA MANAGEMENT;**191**;9/30/97;Build 40
Q
;
QUE ; Que the job in the background
N NAMSP,PATCH,JOBN,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,Y,ZTQUEUED,ZTREQ,ZTSAVE,CNT,SBJM
S NAMSP="PSSP191A"
S JOBN="PSS*1*191 Post Install Diagnostic Report"
S PATCH="PSS*1*191"
S Y=$$NOW^XLFDT S ZTDTH=$$FMTH^XLFDT(Y)
;
D BMES^XPDUTL("=============================================================")
D MES^XPDUTL("Queuing background job for "_JOBN_"...")
D MES^XPDUTL("Start time: "_$$HTE^XLFDT(ZTDTH))
D MES^XPDUTL("A MailMan message will be sent to the installer upon Post")
D MES^XPDUTL("Install Completion. This may take an hour.")
D MES^XPDUTL("==============================================================")
;
S ZTRTN="EN^"_NAMSP,ZTIO=""
S (SBJM,ZTDESC)="Background job for "_JOBN
S ZTSAVE("JOBN")="",ZTSAVE("ZTDTH")="",ZTSAVE("DUZ")="",ZTSAVE("SBJM")=""
D ^%ZTLOAD
D:$D(ZTSK)
. D MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
. D BMES^XPDUTL("")
. S ZTSAVE("ZTSK")=""
D BMES^XPDUTL("")
K XPDQUES
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 (used for testing)
; = if pass in a value, then it will not check 2.1
;
N PSSDFN,PSSMRRAR,PSSORD,PSSDDOI,PSSOI,PSSDUZ,PSSLN,PSSMRRFL,PSSSPCE
N CLNODE,DDTXT,MRR,PAGNO,QQ,YY,STS,ID,LOC,STP,ORDTOT,ORDSDT
N XMDUZ,XMSUB,XMTEXT,XMY,X,DIFROM
S PSSDUZ=DUZ,ORDSDT=$$NOW^XLFDT
K ^TMP($J,"PSSP191A"),^XTMP("PSSP191A")
;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 PSSOI=$P(^PSDRUG(YY,2),U)
.. S PSSMRRFL=$P($G(^PS(50.7,PSSOI,4)),U,1)
.. S:PSSMRRFL PSSMRRAR(PSSOI)=PSSMRRFL
;
S P1=$G(P1) ;define P1 to null if not passed
S PAGNO=0,ORDTOT=0
; Use Ord Stop Date XREF to look for current orders
F S ORDSDT=$O(^PS(55,"AUD",ORDSDT)) Q:ORDSDT="" D
. S PSSDFN=0
. F S PSSDFN=$O(^PS(55,"AUD",ORDSDT,PSSDFN)) Q:PSSDFN="" D
.. S PSSORD=0
.. F S PSSORD=$O(^PS(55,"AUD",ORDSDT,PSSDFN,PSSORD)) Q:PSSORD="" D
... S STS=$P($G(^PS(55,PSSDFN,5,PSSORD,0)),U,9)
... S CLNODE=$G(^PS(55,PSSDFN,5,PSSORD,8))
... ;non Active type order, quit dont include
... I (STS="D")!(STS="E")!(STS="DE")!(STS="DR") Q
... S ID=$S('$D(^DPT(PSSDFN,0)):"NONE",1:$E($P($G(^DPT(PSSDFN,0)),U,1),1)_$E($P($G(^DPT(PSSDFN,0)),U,9),6,9))
... D CHKORD ;check and then print line on report
...Q
..Q
.Q
D MAKERPT,SENDRPT
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,PSSDFN,5,PSSORD,1,QQ)) Q:'QQ D
. S PSSDDOI=+$P($G(^PS(55,PSSDFN,5,PSSORD,.2)),U)
. S MRR=$G(PSSMRRAR(PSSDDOI))
. 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,PSSDFN,5,PSSORD,2.1)) Q
. S LOC=$S($$CLINIC(CLNODE):$P(^SC(+^PS(55,PSSDFN,5,PSSORD,8),0),U,1),$G(^DPT(PSSDFN,.1))]"":^DPT(PSSDFN,.1),1:"UNKNOWN")
. S DDTXT=$$GET1^DIQ(55.07,QQ_","_PSSORD_","_PSSDFN,"DISPENSE DRUG")
. S ^XTMP("PSSP191A",$J,LOC,ID)=DDTXT_U_STS_U_MRR
.Q
Q
MAKERPT ;
S ^TMP($J,"PSSP191A")=""
S ^TMP($J,"PSSP191A",0)=" "
S ^TMP($J,"PSSP191A",1)=" "
S ^TMP($J,"PSSP191A",2)="Active Orders for Medications Requiring Removal (MRR)."
S ^TMP($J,"PSSP191A",3)="Prior to Installation of PSJ*5*315 these orders should be "
S ^TMP($J,"PSSP191A",4)="reviewed for planning purposes, but no action taken."
S ^TMP($J,"PSSP191A",5)=" Once PSJ*5*315 is installed they will need to be Discontinued"
S ^TMP($J,"PSSP191A",6)=" and re-entered after coordinating with your Pharmacy ADPAC."
S ^TMP($J,"PSSP191A",7)=" This report can be recalled from the PSS MGR Menu."
S ^TMP($J,"PSSP191A",8)=" "
S ^TMP($J,"PSSP191A",9)=" Sorted by Patient within Ward"
S ^TMP($J,"PSSP191A",10)="Pat Patient Orderable Ordr MRR"
S ^TMP($J,"PSSP191A",11)="ID Loc Item Name Sts Val"
S ^TMP($J,"PSSP191A",12)="----- -------------------- -------------------- ---- ---"
S ^TMP($J,"PSSP191A",13)=" "
S PSSLN=14,$P(PSSSPCE," ",20)=""
N STR S LOC=""
F S LOC=$O(^XTMP("PSSP191A",$J,LOC)) Q:LOC="" D
. S ID=""
. F S ID=$O(^XTMP("PSSP191A",$J,LOC,ID)) Q:ID="" D
.. S STR=^XTMP("PSSP191A",$J,LOC,ID),DDTXT=$P(STR,U),STS=$P(STR,U,2),MRR=$P(STR,U,3)
.. S ^TMP($J,"PSSP191A",PSSLN)=$E(ID_PSSSPCE,1,5)_" "_$E($$FMTE^XLFDT(LOC,5)_PSSSPCE,1,20)_" "_$E(DDTXT_PSSSPCE,1,20)_" "_$E(STS_PSSSPCE,1,4)_" "_$E(MRR_PSSSPCE,1,3)
.. S ORDTOT=ORDTOT+1,PSSLN=PSSLN+1
..Q
.Q
S PSSLN=PSSLN+1,^TMP($J,"PSSP191A",PSSLN)="Total Orders found: "_ORDTOT
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
;
SENDRPT ;Send report to user
S XMY(PSSDUZ)=""
S X="" F S X=$O(^XUSEC("PSJI MGR",X)) Q:'X S XMY(X)=""
S X="" F S X=$O(^XUSEC("PSJU MGR",X)) Q:'X S XMY(X)=""
S X="" F S X=$O(^XUSEC("PSJU RPH",X)) Q:'X S XMY(X)=""
S X="" F S X=$O(^XUSEC("PSJ RPHARM",X)) Q:'X S XMY(X)=""
S XMSUB="PHARMACY ORDERABLE ITEM MANAGEMENT",XMTEXT="^TMP("_$J_","_"""PSSP191A"""_",",XMDUZ=.5,XMY(PSSDUZ)=""
D ^XMD
K ^TMP($J,"PSSP191A"),^XTMP("PSSP191A")
Q
;
TST ;
N P1 S P1=1
D EN(P1)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSP191A 5820 printed Apr 09, 2024@21:33:53 Page 2
PSSP191A ;BIRMINGHAM/GN/DRP-Diagnostic Report only, does not update ; 9/25/15 2:36pm
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**191**;9/30/97;Build 40
+2 QUIT
+3 ;
QUE ; Que the job in the background
+1 NEW NAMSP,PATCH,JOBN,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,Y,ZTQUEUED,ZTREQ,ZTSAVE,CNT,SBJM
+2 SET NAMSP="PSSP191A"
+3 SET JOBN="PSS*1*191 Post Install Diagnostic Report"
+4 SET PATCH="PSS*1*191"
+5 SET Y=$$NOW^XLFDT
SET ZTDTH=$$FMTH^XLFDT(Y)
+6 ;
+7 DO BMES^XPDUTL("=============================================================")
+8 DO MES^XPDUTL("Queuing background job for "_JOBN_"...")
+9 DO MES^XPDUTL("Start time: "_$$HTE^XLFDT(ZTDTH))
+10 DO MES^XPDUTL("A MailMan message will be sent to the installer upon Post")
+11 DO MES^XPDUTL("Install Completion. This may take an hour.")
+12 DO MES^XPDUTL("==============================================================")
+13 ;
+14 SET ZTRTN="EN^"_NAMSP
SET ZTIO=""
+15 SET (SBJM,ZTDESC)="Background job for "_JOBN
+16 SET ZTSAVE("JOBN")=""
SET ZTSAVE("ZTDTH")=""
SET ZTSAVE("DUZ")=""
SET ZTSAVE("SBJM")=""
+17 DO ^%ZTLOAD
+18 if $DATA(ZTSK)
Begin DoDot:1
+19 DO MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
+20 DO BMES^XPDUTL("")
+21 SET ZTSAVE("ZTSK")=""
End DoDot:1
+22 DO BMES^XPDUTL("")
+23 KILL XPDQUES
+24 QUIT
+25 ;
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 (used for testing)
+3 ; = if pass in a value, then it will not check 2.1
+4 ;
+5 NEW PSSDFN,PSSMRRAR,PSSORD,PSSDDOI,PSSOI,PSSDUZ,PSSLN,PSSMRRFL,PSSSPCE
+6 NEW CLNODE,DDTXT,MRR,PAGNO,QQ,YY,STS,ID,LOC,STP,ORDTOT,ORDSDT
+7 NEW XMDUZ,XMSUB,XMTEXT,XMY,X,DIFROM
+8 SET PSSDUZ=DUZ
SET ORDSDT=$$NOW^XLFDT
+9 KILL ^TMP($JOB,"PSSP191A"),^XTMP("PSSP191A")
+10 ;build array of OI's that are mrr and their flag value
+11 FOR QQ=0:0
SET QQ=$ORDER(^PSDRUG("ASP",QQ))
if QQ=""
QUIT
Begin DoDot:1
+12 FOR YY=0:0
SET YY=$ORDER(^PSDRUG("ASP",QQ,YY))
if 'YY
QUIT
Begin DoDot:2
+13 SET PSSOI=$PIECE(^PSDRUG(YY,2),U)
+14 SET PSSMRRFL=$PIECE($GET(^PS(50.7,PSSOI,4)),U,1)
+15 if PSSMRRFL
SET PSSMRRAR(PSSOI)=PSSMRRFL
End DoDot:2
End DoDot:1
+16 ;
+17 ;define P1 to null if not passed
SET P1=$GET(P1)
+18 SET PAGNO=0
SET ORDTOT=0
+19 ; Use Ord Stop Date XREF to look for current orders
+20 FOR
SET ORDSDT=$ORDER(^PS(55,"AUD",ORDSDT))
if ORDSDT=""
QUIT
Begin DoDot:1
+21 SET PSSDFN=0
+22 FOR
SET PSSDFN=$ORDER(^PS(55,"AUD",ORDSDT,PSSDFN))
if PSSDFN=""
QUIT
Begin DoDot:2
+23 SET PSSORD=0
+24 FOR
SET PSSORD=$ORDER(^PS(55,"AUD",ORDSDT,PSSDFN,PSSORD))
if PSSORD=""
QUIT
Begin DoDot:3
+25 SET STS=$PIECE($GET(^PS(55,PSSDFN,5,PSSORD,0)),U,9)
+26 SET CLNODE=$GET(^PS(55,PSSDFN,5,PSSORD,8))
+27 ;non Active type order, quit dont include
+28 IF (STS="D")!(STS="E")!(STS="DE")!(STS="DR")
QUIT
+29 SET ID=$SELECT('$DATA(^DPT(PSSDFN,0)):"NONE",1:$EXTRACT($PIECE($GET(^DPT(PSSDFN,0)),U,1),1)_$EXTRACT($PIECE($GET(^DPT(PSSDFN,0)),U,9),6,9))
+30 ;check and then print line on report
DO CHKORD
+31 QUIT
End DoDot:3
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 DO MAKERPT
DO SENDRPT
+35 QUIT
+36 ;
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,PSSDFN,5,PSSORD,1,QQ))
if 'QQ
QUIT
Begin DoDot:1
+3 SET PSSDDOI=+$PIECE($GET(^PS(55,PSSDFN,5,PSSORD,.2)),U)
+4 SET MRR=$GET(PSSMRRAR(PSSDDOI))
+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,PSSDFN,5,PSSORD,2.1))
QUIT
+8 SET LOC=$SELECT($$CLINIC(CLNODE):$PIECE(^SC(+^PS(55,PSSDFN,5,PSSORD,8),0),U,1),$GET(^DPT(PSSDFN,.1))]"":^DPT(PSSDFN,.1),1:"UNKNOWN")
+9 SET DDTXT=$$GET1^DIQ(55.07,QQ_","_PSSORD_","_PSSDFN,"DISPENSE DRUG")
+10 SET ^XTMP("PSSP191A",$JOB,LOC,ID)=DDTXT_U_STS_U_MRR
+11 QUIT
End DoDot:1
+12 QUIT
MAKERPT ;
+1 SET ^TMP($JOB,"PSSP191A")=""
+2 SET ^TMP($JOB,"PSSP191A",0)=" "
+3 SET ^TMP($JOB,"PSSP191A",1)=" "
+4 SET ^TMP($JOB,"PSSP191A",2)="Active Orders for Medications Requiring Removal (MRR)."
+5 SET ^TMP($JOB,"PSSP191A",3)="Prior to Installation of PSJ*5*315 these orders should be "
+6 SET ^TMP($JOB,"PSSP191A",4)="reviewed for planning purposes, but no action taken."
+7 SET ^TMP($JOB,"PSSP191A",5)=" Once PSJ*5*315 is installed they will need to be Discontinued"
+8 SET ^TMP($JOB,"PSSP191A",6)=" and re-entered after coordinating with your Pharmacy ADPAC."
+9 SET ^TMP($JOB,"PSSP191A",7)=" This report can be recalled from the PSS MGR Menu."
+10 SET ^TMP($JOB,"PSSP191A",8)=" "
+11 SET ^TMP($JOB,"PSSP191A",9)=" Sorted by Patient within Ward"
+12 SET ^TMP($JOB,"PSSP191A",10)="Pat Patient Orderable Ordr MRR"
+13 SET ^TMP($JOB,"PSSP191A",11)="ID Loc Item Name Sts Val"
+14 SET ^TMP($JOB,"PSSP191A",12)="----- -------------------- -------------------- ---- ---"
+15 SET ^TMP($JOB,"PSSP191A",13)=" "
+16 SET PSSLN=14
SET $PIECE(PSSSPCE," ",20)=""
+17 NEW STR
SET LOC=""
+18 FOR
SET LOC=$ORDER(^XTMP("PSSP191A",$JOB,LOC))
if LOC=""
QUIT
Begin DoDot:1
+19 SET ID=""
+20 FOR
SET ID=$ORDER(^XTMP("PSSP191A",$JOB,LOC,ID))
if ID=""
QUIT
Begin DoDot:2
+21 SET STR=^XTMP("PSSP191A",$JOB,LOC,ID)
SET DDTXT=$PIECE(STR,U)
SET STS=$PIECE(STR,U,2)
SET MRR=$PIECE(STR,U,3)
+22 SET ^TMP($JOB,"PSSP191A",PSSLN)=$EXTRACT(ID_PSSSPCE,1,5)_" "_$EXTRACT($$FMTE^XLFDT(LOC,5)_PSSSPCE,1,20)_" "_$EXTRACT(DDTXT_PSSSPCE,1,20)_" "_$EXTRACT(STS_PSSSPCE,1,4)_" "_$EXTRACT(MRR_PSSSPCE,1,3)
+23 SET ORDTOT=ORDTOT+1
SET PSSLN=PSSLN+1
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 SET PSSLN=PSSLN+1
SET ^TMP($JOB,"PSSP191A",PSSLN)="Total Orders found: "_ORDTOT
+27 QUIT
+28 ;
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 ;
SENDRPT ;Send report to user
+1 SET XMY(PSSDUZ)=""
+2 SET X=""
FOR
SET X=$ORDER(^XUSEC("PSJI MGR",X))
if 'X
QUIT
SET XMY(X)=""
+3 SET X=""
FOR
SET X=$ORDER(^XUSEC("PSJU MGR",X))
if 'X
QUIT
SET XMY(X)=""
+4 SET X=""
FOR
SET X=$ORDER(^XUSEC("PSJU RPH",X))
if 'X
QUIT
SET XMY(X)=""
+5 SET X=""
FOR
SET X=$ORDER(^XUSEC("PSJ RPHARM",X))
if 'X
QUIT
SET XMY(X)=""
+6 SET XMSUB="PHARMACY ORDERABLE ITEM MANAGEMENT"
SET XMTEXT="^TMP("_$JOB_","_"""PSSP191A"""_","
SET XMDUZ=.5
SET XMY(PSSDUZ)=""
+7 DO ^XMD
+8 KILL ^TMP($JOB,"PSSP191A"),^XTMP("PSSP191A")
+9 QUIT
+10 ;
TST ;
+1 NEW P1
SET P1=1
+2 DO EN(P1)
+3 QUIT
+4 ;
