PSO583PI ;BIR/MFR-Post-install routine for Patch PSO*7*583 ; 02 Aug 2018 2:00 PM
;;7.0;OUTPATIENT PHARMACY;**583**;DEC 1997;Build 3
;
Q
POST ; entry point
D BMES^XPDUTL(" Starting post-install for PSO*7*583")
N ISSDT,FOUND,RXIEN,DIVNAM,PATNAM,PATIEN,STATUS,DRGIEN,DRGNAM,DOSIEN,DOSE,Z,UNITS,PSOLINE
S PSOLINE=0 K ^TMP("PSO583PI",$J),^XTMP("PSO583PI",$J)
D SETTXT("The CPRS patch OR*3*440 was released Back in 2017 to address a problem with")
D SETTXT("the Ward Clerk Menu [OR MAIN MENU WARD CLERK] option that was causing some")
D SETTXT("Outpatient Pharmacy orders and prescriptions to have the wrong dispense units.")
D SETTXT("Although the problem seems to have been resolved by preventing new orders with")
D SETTXT("the problem from being created it did not go far enough to prevent that")
D SETTXT("existing orders with the problem could propagate the problem well into the")
D SETTXT("future by being copied or renewed.")
D SETTXT("The list below should be analyzed entry by entry and a determination should be")
D SETTXT("made by the Pharmacy ADPAC at the site whether the outpatient prescription dose")
D SETTXT("and dispense units are correct for the dispense drug or not.")
D SETTXT("If it is determined that the prescription dose/dispense unit is incorrect the")
D SETTXT("Outpatient Pharmacy staff should take action to discontinue the prescription")
D SETTXT("and re-renter it with the correct dosing and dispense unit information.")
D SETTXT("-------------------------------------------------------------------------------")
D SETTXT("PATIENT (L4SSN)")
D SETTXT(" RX # DISPENSE DRUG DOSE ORD. UNITS STRENGTH")
D SETTXT("-------------------------------------------------------------------------------")
; Looking for Dose/Drug mismatches - Look back 1 year for Active prescriptions
S ISSDT=$$FMADD^XLFDT(DT,-367),FOUND=0
F S ISSDT=$O(^PSRX("AC",ISSDT)) Q:'ISSDT D
. S RXIEN=0 F S RXIEN=$O(^PSRX("AC",ISSDT,RXIEN)) Q:'RXIEN D
. . S DIVNAM=$$GET1^DIQ(52,RXIEN,20)
. . S PATNAM=$$GET1^DIQ(52,RXIEN,2),PATIEN=$$GET1^DIQ(52,RXIEN,2,"I")
. . ; Skip entry if Rx is DC'd/Expired/Deleted
. . S STATUS=$$GET1^DIQ(52,RXIEN,100,"I") I STATUS>10 Q
. . S DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I"),DRGNAM=$$GET1^DIQ(50,DRGIEN,.01)
. . ; Skip a few False positives for the logic because of Drug Composition
. . I (DRGNAM["ZINC")!(DRGNAM["POTASSIUM")!(DRGNAM["CALCIUM")!(DRGNAM["FISH")!(DRGNAM["FERROUS") Q
. . I (DRGNAM["PHENOBARBITAL")!(DRGNAM["LEVOTHYROXINE") Q
. . ; Skip entry if Drug does not have Strength
. . S STREN=$$GET1^DIQ(50,DRGIEN,901) I 'STREN Q
. . ; Skip entry if Rx does not have a dose
. . S DOSIEN=$O(^PSRX(RXIEN,6,0)) I 'DOSIEN Q
. . ; Skip entry if Rx dose is not numeric
. . S Z=$G(^PSRX(RXIEN,6,DOSIEN,0)),DOSE=+Z,UNITS=$P(Z,"^",2) I 'DOSE!'UNITS Q
. . ; Skip entry if Dose = Units * Drug Strength
. . I (UNITS*STREN)=DOSE Q
. . ; Skip entry if discrepancy is minimal (false positive)
. . I (((DOSE/STREN)<2)&((STREN/DOSE)<2)&((STREN/DOSE)'=1)) Q
. . S ^TMP("PSO583PI",$J,DIVNAM_" ",PATNAM_"^"_PATIEN,RXIEN)=DOSE_"^"_UNITS_"^"_STREN
. . S FOUND=FOUND+1
;
I FOUND D
. S (DIVNAM,PATNAM,RXIEN)=""
. F S DIVNAM=$O(^TMP("PSO583PI",$J,DIVNAM)) Q:(DIVNAM="") D
. . D SETTXT("Division: "_DIVNAM)
. . F S PATNAM=$O(^TMP("PSO583PI",$J,DIVNAM,PATNAM)) Q:(PATNAM="") D
. . . D SETPAT($P(PATNAM,"^",2))
. . . F S RXIEN=$O(^TMP("PSO583PI",$J,DIVNAM,PATNAM,RXIEN)) Q:'RXIEN D
. . . . S Z=^TMP("PSO583PI",$J,DIVNAM,PATNAM,RXIEN)
. . . . D SETRX(RXIEN,$P(Z,"^"),$P(Z,"^",2),$P(Z,"^",3))
. . D SETTXT(" ")
. D SETTXT(" "),SETTXT(FOUND_" prescriptions found.")
E D
. D SETTXT("No prescriptions were found with a potential dose/dispense unit problem.")
;
D MAIL
;
D BMES^XPDUTL(" Mailman message sent.")
D BMES^XPDUTL(" Finished post-install for PSO*7*583.")
;
END ; Exit point
K ^TMP("PSO583PI",$J),^XTMP("PSO583PI",$J)
Q
;
SETTXT(TXT) ; Setting Plain Text
S PSOLINE=$G(PSOLINE)+1,^XTMP("PSO583PI",$J,PSOLINE)=TXT
Q
;
SETPAT(DFN) ; Setting Patient Line
N L4SSN,VADM
D DEM^VADPT S L4SSN=$P($P(VADM(2),"^",2),"-",3)
S PSOLINE=$G(PSOLINE)+1,^XTMP("PSO583PI",$J,PSOLINE)=$P(VADM(1),"^")_" ("_L4SSN_")"
Q
;
SETRX(RXIEN,DOSE,UNITS,STREN) ; Setting Rx Line
N TXTLN
S $E(TXTLN,3)=$$GET1^DIQ(52,RXIEN,.01),$E(TXTLN,16)=$E($$GET1^DIQ(52,RXIEN,6),1,30)
S $E(TXTLN,48)=$J(DOSE,7),$E(TXTLN,62)=$J(UNITS,4),$E(TXTLN,73)=$J(STREN,5)
S PSOLINE=$G(PSOLINE)+1,^XTMP("PSO583PI",$J,PSOLINE)=TXTLN
Q
;
MAIL ; Sends Mailman message
N II,XMX,XMSUB,XMDUZ,XMTEXT,XMY
S II=0 F S II=$O(^XUSEC("PSNMGR",II)) Q:'II S XMY(II)=""
S XMY(DUZ)="",XMSUB="PSO*7*583 - Renewed/Copied Rx Dose/Dispense Unit Discrepancies"
S XMDUZ=.5,XMTEXT="^XTMP(""PSO583PI"",$J," N DIFROM D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO583PI 4877 printed Dec 13, 2024@02:23:20 Page 2
PSO583PI ;BIR/MFR-Post-install routine for Patch PSO*7*583 ; 02 Aug 2018 2:00 PM
+1 ;;7.0;OUTPATIENT PHARMACY;**583**;DEC 1997;Build 3
+2 ;
+3 QUIT
POST ; entry point
+1 DO BMES^XPDUTL(" Starting post-install for PSO*7*583")
+2 NEW ISSDT,FOUND,RXIEN,DIVNAM,PATNAM,PATIEN,STATUS,DRGIEN,DRGNAM,DOSIEN,DOSE,Z,UNITS,PSOLINE
+3 SET PSOLINE=0
KILL ^TMP("PSO583PI",$JOB),^XTMP("PSO583PI",$JOB)
+4 DO SETTXT("The CPRS patch OR*3*440 was released Back in 2017 to address a problem with")
+5 DO SETTXT("the Ward Clerk Menu [OR MAIN MENU WARD CLERK] option that was causing some")
+6 DO SETTXT("Outpatient Pharmacy orders and prescriptions to have the wrong dispense units.")
+7 DO SETTXT("Although the problem seems to have been resolved by preventing new orders with")
+8 DO SETTXT("the problem from being created it did not go far enough to prevent that")
+9 DO SETTXT("existing orders with the problem could propagate the problem well into the")
+10 DO SETTXT("future by being copied or renewed.")
+11 DO SETTXT("The list below should be analyzed entry by entry and a determination should be")
+12 DO SETTXT("made by the Pharmacy ADPAC at the site whether the outpatient prescription dose")
+13 DO SETTXT("and dispense units are correct for the dispense drug or not.")
+14 DO SETTXT("If it is determined that the prescription dose/dispense unit is incorrect the")
+15 DO SETTXT("Outpatient Pharmacy staff should take action to discontinue the prescription")
+16 DO SETTXT("and re-renter it with the correct dosing and dispense unit information.")
+17 DO SETTXT("-------------------------------------------------------------------------------")
+18 DO SETTXT("PATIENT (L4SSN)")
+19 DO SETTXT(" RX # DISPENSE DRUG DOSE ORD. UNITS STRENGTH")
+20 DO SETTXT("-------------------------------------------------------------------------------")
+21 ; Looking for Dose/Drug mismatches - Look back 1 year for Active prescriptions
+22 SET ISSDT=$$FMADD^XLFDT(DT,-367)
SET FOUND=0
+23 FOR
SET ISSDT=$ORDER(^PSRX("AC",ISSDT))
if 'ISSDT
QUIT
Begin DoDot:1
+24 SET RXIEN=0
FOR
SET RXIEN=$ORDER(^PSRX("AC",ISSDT,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:2
+25 SET DIVNAM=$$GET1^DIQ(52,RXIEN,20)
+26 SET PATNAM=$$GET1^DIQ(52,RXIEN,2)
SET PATIEN=$$GET1^DIQ(52,RXIEN,2,"I")
+27 ; Skip entry if Rx is DC'd/Expired/Deleted
+28 SET STATUS=$$GET1^DIQ(52,RXIEN,100,"I")
IF STATUS>10
QUIT
+29 SET DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
SET DRGNAM=$$GET1^DIQ(50,DRGIEN,.01)
+30 ; Skip a few False positives for the logic because of Drug Composition
+31 IF (DRGNAM["ZINC")!(DRGNAM["POTASSIUM")!(DRGNAM["CALCIUM")!(DRGNAM["FISH")!(DRGNAM["FERROUS")
QUIT
+32 IF (DRGNAM["PHENOBARBITAL")!(DRGNAM["LEVOTHYROXINE")
QUIT
+33 ; Skip entry if Drug does not have Strength
+34 SET STREN=$$GET1^DIQ(50,DRGIEN,901)
IF 'STREN
QUIT
+35 ; Skip entry if Rx does not have a dose
+36 SET DOSIEN=$ORDER(^PSRX(RXIEN,6,0))
IF 'DOSIEN
QUIT
+37 ; Skip entry if Rx dose is not numeric
+38 SET Z=$GET(^PSRX(RXIEN,6,DOSIEN,0))
SET DOSE=+Z
SET UNITS=$PIECE(Z,"^",2)
IF 'DOSE!'UNITS
QUIT
+39 ; Skip entry if Dose = Units * Drug Strength
+40 IF (UNITS*STREN)=DOSE
QUIT
+41 ; Skip entry if discrepancy is minimal (false positive)
+42 IF (((DOSE/STREN)<2)&((STREN/DOSE)<2)&((STREN/DOSE)'=1))
QUIT
+43 SET ^TMP("PSO583PI",$JOB,DIVNAM_" ",PATNAM_"^"_PATIEN,RXIEN)=DOSE_"^"_UNITS_"^"_STREN
+44 SET FOUND=FOUND+1
End DoDot:2
End DoDot:1
+45 ;
+46 IF FOUND
Begin DoDot:1
+47 SET (DIVNAM,PATNAM,RXIEN)=""
+48 FOR
SET DIVNAM=$ORDER(^TMP("PSO583PI",$JOB,DIVNAM))
if (DIVNAM="")
QUIT
Begin DoDot:2
+49 DO SETTXT("Division: "_DIVNAM)
+50 FOR
SET PATNAM=$ORDER(^TMP("PSO583PI",$JOB,DIVNAM,PATNAM))
if (PATNAM="")
QUIT
Begin DoDot:3
+51 DO SETPAT($PIECE(PATNAM,"^",2))
+52 FOR
SET RXIEN=$ORDER(^TMP("PSO583PI",$JOB,DIVNAM,PATNAM,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:4
+53 SET Z=^TMP("PSO583PI",$JOB,DIVNAM,PATNAM,RXIEN)
+54 DO SETRX(RXIEN,$PIECE(Z,"^"),$PIECE(Z,"^",2),$PIECE(Z,"^",3))
End DoDot:4
End DoDot:3
+55 DO SETTXT(" ")
End DoDot:2
+56 DO SETTXT(" ")
DO SETTXT(FOUND_" prescriptions found.")
End DoDot:1
+57 IF '$TEST
Begin DoDot:1
+58 DO SETTXT("No prescriptions were found with a potential dose/dispense unit problem.")
End DoDot:1
+59 ;
+60 DO MAIL
+61 ;
+62 DO BMES^XPDUTL(" Mailman message sent.")
+63 DO BMES^XPDUTL(" Finished post-install for PSO*7*583.")
+64 ;
END ; Exit point
+1 KILL ^TMP("PSO583PI",$JOB),^XTMP("PSO583PI",$JOB)
+2 QUIT
+3 ;
SETTXT(TXT) ; Setting Plain Text
+1 SET PSOLINE=$GET(PSOLINE)+1
SET ^XTMP("PSO583PI",$JOB,PSOLINE)=TXT
+2 QUIT
+3 ;
SETPAT(DFN) ; Setting Patient Line
+1 NEW L4SSN,VADM
+2 DO DEM^VADPT
SET L4SSN=$PIECE($PIECE(VADM(2),"^",2),"-",3)
+3 SET PSOLINE=$GET(PSOLINE)+1
SET ^XTMP("PSO583PI",$JOB,PSOLINE)=$PIECE(VADM(1),"^")_" ("_L4SSN_")"
+4 QUIT
+5 ;
SETRX(RXIEN,DOSE,UNITS,STREN) ; Setting Rx Line
+1 NEW TXTLN
+2 SET $EXTRACT(TXTLN,3)=$$GET1^DIQ(52,RXIEN,.01)
SET $EXTRACT(TXTLN,16)=$EXTRACT($$GET1^DIQ(52,RXIEN,6),1,30)
+3 SET $EXTRACT(TXTLN,48)=$JUSTIFY(DOSE,7)
SET $EXTRACT(TXTLN,62)=$JUSTIFY(UNITS,4)
SET $EXTRACT(TXTLN,73)=$JUSTIFY(STREN,5)
+4 SET PSOLINE=$GET(PSOLINE)+1
SET ^XTMP("PSO583PI",$JOB,PSOLINE)=TXTLN
+5 QUIT
+6 ;
MAIL ; Sends Mailman message
+1 NEW II,XMX,XMSUB,XMDUZ,XMTEXT,XMY
+2 SET II=0
FOR
SET II=$ORDER(^XUSEC("PSNMGR",II))
if 'II
QUIT
SET XMY(II)=""
+3 SET XMY(DUZ)=""
SET XMSUB="PSO*7*583 - Renewed/Copied Rx Dose/Dispense Unit Discrepancies"
+4 SET XMDUZ=.5
SET XMTEXT="^XTMP(""PSO583PI"",$J,"
NEW DIFROM
DO ^XMD
+5 QUIT
