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

PSOORCPY.m

Go to the documentation of this file.
  1. PSOORCPY ;BIR/SAB-copy orders from backdoor ;Oct 20, 2022@15:12
  1. ;;7.0;OUTPATIENT PHARMACY;**10,21,27,32,46,100,117,148,313,411,444,468,504,477,441,545,700,753**;DEC 1997;Build 53
  1. ;External reference to LK^ORX2 supported by DBIA 867
  1. ;External reference to ULK^ORX2 supported by DBIA 867
  1. ;External reference to ^PSDRUG( supported by DBIA 221
  1. ;External reference to L^PSSLOCK supported by DBIA 2789
  1. ;External reference to UL^PSSLOCK supported by DBIA 2789
  1. ;External reference to PSOL^PSSLOCK supported by DBIA 2789
  1. ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
  1. ;
  1. ; Cleaning up Titration/Maintenance variables (they shouldn't be defined - just to be safe)
  1. K PSOMTFLG,PSOTITRX,PSOSIGFL
  1. COPY ; Rx Copy Functionality
  1. N PSORXIEN,PSOCHECK,PSOGOOUT,PSODEAUP,PSODRGIEN
  1. S PSORXIEN=+$P($G(PSOLST(ORN)),"^",2)
  1. ; Checking whether the Provider still qualifies as prescriber for the renewed Rx
  1. S PSOCHECK=$$CHKRXPRV^PSOUTIL(PSORXIEN)
  1. I 'PSOCHECK&(($P(PSOCHECK,U,4)'=1)&($P(PSOCHECK,U,4)'=2)) S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) Q
  1. ;I $G(PSODRUG("DEA")) D Q:'$L($G(PSORXED("DEACOPY")))
  1. S PSODRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
  1. I $$DRUGSCHD^PSOUTIL(PSODRGIEN) D
  1. . N PSDRGIEN S PSDRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
  1. . D FULL^VALM1 S PSODEAUP=$$SLDEA^PSODIR($P($G(^PSRX(PSORXIEN,0)),U,4),.PSORX,$$RXDEA^PSOUTIL(PSORXIEN),PSDRGIEN)
  1. . I $L($G(PSODEAUP)) S PSORXED("DEACOPY")=PSODEAUP D PAUSE^VALM1 Q
  1. . N PSODIR,PSORX S PSODIR("CS")=1 D PROV^PSODIR(.PSODIR)
  1. . I $G(PSODIR("PROVIDER"))&$L($G(PSORX("RXDEA"))) D Q
  1. .. S PSORXED("PROVIDER")=PSODIR("PROVIDER"),PSORXED("DEACOPY")=PSORX("RXDEA")
  1. . I 'PSOCHECK S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) D PAUSE^VALM1
  1. I $$LMREJ^PSOREJU1(PSORXIEN,,.VALMSG,.VALMBCK) Q
  1. ;I '$G(PSOMTFLG),$$TITRX^PSOUTL(PSORXIEN)="t" S VALMSG="Cannot Copy a 'Titration Rx'.",VALMBCK="" W $C(7) Q ;p441
  1. I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
  1. I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" K PSOCOPY D ^PSOBUILD Q
  1. S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
  1. K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
  1. D PSOL^PSSLOCK(PSORXIEN) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG G EX
  1. N VALMCNT K PSOEDIT S (PSOCOPY,COPY,PSORXED,ZZCOPY)=1 D FULL^VALM1
  1. S PSORXED("DFLG")=0,(RXN,DA,PSORXED("IRXN"))=PSORXIEN,PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=$G(^(2)),PSORXED("RX3")=$G(^(3)),PSOI=$P($G(^("OR1")),"^"),PSOSIG=$P($G(^("SIG")),"^"),STAT=+^("STA")
  1. S PSORXED("RX7")=$G(^PSRX(PSORXED("IRXN"),7)) ;p753
  1. S PSORXED("INS")=$G(^PSRX(PSORXED("IRXN"),"INS"))
  1. S:$G(^PSRX(PSORXED("IRXN"),"INSS"))]"" PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
  1. S D=0 F S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D S PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0)
  1. I '$O(PSORXED("SIG",0)),$G(PSORXED("INS"))]"" S PSORXED("SIG",1)=PSORXED("INS")
  1. ;441-IND
  1. S PSORXED("IND")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^"),PSORXED("INDF")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
  1. S:$P($G(^PS(55,PSODFN,"LAN")),"^") PSORXED("INDO")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",3)
  1. I $G(^PSRX(PSORXED("IRXN"),"TN"))]"" S PSODRUG("TRADE NAME")=^PSRX(PSORXED("IRXN"),"TN")
  1. ;
  1. ; - This call copies the dosage into the new order and also split the Maintenance dose (if the case)
  1. D BLDDOSE(.PSORXED,$G(PSOMTFLG)) G OUT:$G(PSOGOOUT)
  1. ;
  1. I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT S VALMSG=$S('$G(PSOMTFLG):"Cannot COPY. ",1:"")_"This drug has been inactivated!" S VALMBCK="R" G OUT
  1. I $P(^PSDRUG($P(PSORXED("RX0"),"^",6),2),"^",3)'["O" S VALMSG=$S('$G(PSOMTFLG):"Cannot COPY. ",1:"")_"Drug no longer used by Outpatient!",VALMBCK="R" G OUT
  1. ;Check for invalid Dosage
  1. N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORXED("IRXN") D CDOSE^PSORENW0
  1. I PSOOLPF D S VALMBCK="R" G OUT
  1. .S VALMSG=$S('$G(PSOMTFLG):"Cannot COPY. ",1:"")_"Invalid Dosage of "_$G(PSOOLPD)
  1. I PSONOSIG D S VALMBCK="R" G OUT
  1. .S VALMSG=$S('$G(PSOMTFLG):"Cannot COPY. ",1:"")_"Missing Sig"
  1. ;
  1. S PSORXED("MAIL EXEMPTION")=$P($G(PSORXED("RX7")),"^",2) ;p753
  1. ;
  1. I '$P($G(^PSDRUG($P(PSORXED("RX0"),"^",6),2)),"^") S VALMBCK="R" G OUT
  1. S DREN=$P(PSORXED("RX0"),"^",6),PSODAYS=$P(PSORXED("RX0"),"^",8)
  1. ; Checks if the current Days Supply value is greater than the Maximum Days Supply for the Drug
  1. I '$G(PSOMTFLG) D
  1. . S PSORXED("DAYS SUPPLY")=$P(PSORXED("RX0"),"^",8),PSORXED("QTY")=$P(PSORXED("RX0"),"^",7)
  1. . D DAYSUP^PSOUTIL(DREN,.PSORXED,1)
  1. S PSORXST=+$P($G(^PS(53,$P(PSORXED("RX0"),"^",3),0)),"^",7)
  1. S POERR=1 D DRG^PSOORDRG K POERR
  1. I $G(PSORX("DFLG")) S VALMBCK="R"
  1. ;
  1. I $G(PSOMTFLG) D I $G(PSORXED("DFLG")) S VALMBCK="R" G OUT
  1. . S PSORXED("DAYS SUPPLY")=PSODAYS,PSORXED("QTY")=+$$GET1^DIQ(52,PSORXED("IRXN"),7)
  1. . W !!,"New Maintenance Rx (Review Quantity):",!,"Drug: ",$$GET1^DIQ(52,PSORXED("IRXN"),6)
  1. . D EN^PSOFSIG(.PSORXED,1) W !,"Days Supply: ",PSODAYS
  1. . N PSOQTY S PSORXED("FLD")=5 D QTY^PSODIR1(.PSORXED) W !
  1. ;
  1. D EN^PSOORED1(.PSORXED) I $G(PSORX("FN")) S VALMBCK="Q",PSOFROM="NEW" D DCORD^PSONEW2
  1. E S VALMBCK="R"
  1. OUT ;
  1. D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
  1. K PSOCOPY D ^PSOBUILD,ACT^PSOORNE2
  1. EX S X=PSODFN_";DPT(" D ULK^ORX2
  1. D UL^PSSLOCK(PSODFN)
  1. K PSOMSG,PSONEW,PSOSIG,STA,DREN,PSODAYS,PSORXST,PSOCOPY,PSORXED,FST,FLD,IEN,FLN,INCOM,PSOI,COPY,SIG,SIGOK
  1. K PSODRUG,^TMP("PSOPO",$J),PSOMTFLG
  1. D CLEAN^PSOVER1,EOJ^PSONEW K ZZCOPY
  1. Q
  1. ;
  1. LOCK ;
  1. I $P($G(PSOPLCK),"^")'=0 Q
  1. I $$GET1^DIQ(59.7,1,102,"I")="MBM" Q
  1. W !!,$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2),1:"Another person")_" is working on this patient."
  1. K DIR S DIR(0)="E",DIR("A")=" Press Return to Continue" D ^DIR K DIR
  1. Q
  1. ;
  1. BLDDOSE(PSORXED,MAINTRXF) ; Copies the Dose from Original Rx into Copied/Maintenance Dose Rx
  1. N DOSEIEN,DOSE
  1. ; - Copying from the last THEN conjunction (Maintenance Dose Rx)
  1. ; - For Titration/Maintenance, DOSEIEN = the IEN in the prescription of the last THEN conjunction.
  1. ; - This value is used as a "seed" for the FOR loop starting point.
  1. I $G(MAINTRXF) D Q
  1. . D LASTTHEN
  1. . S PSORXED("ENT")=0
  1. . F S DOSEIEN=$O(^PSRX(PSORXED("IRXN"),6,DOSEIEN)) Q:'DOSEIEN!($G(PSOGOOUT)) D
  1. . . S DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0)
  1. . . I $P(DOSE,"^",6)="X" S PSOGOOUT=1,VALMSG="Cannot COPY. Invalid 'except' conjunction!" S VALMBCK="R" Q
  1. . . Q:$P(DOSE,"^")']""!($P(DOSE,"^",8)']"")
  1. . . S PSORXED("ENT")=PSORXED("ENT")+1
  1. . . D SETDOSE(.PSORXED,DOSEIEN,PSORXED("ENT"))
  1. . . D EN^PSOFSIG(.PSORXED)
  1. G OUT:$G(PSOGOOUT)
  1. ;
  1. ; - Copying dose for Regular Rx Copy
  1. S PSORXED("ENT")=0
  1. F DOSEIEN=0:0 S DOSEIEN=$O(^PSRX(PSORXED("IRXN"),6,DOSEIEN)) Q:'DOSEIEN D
  1. . S DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0) D
  1. . I $P(DOSE,"^",6)="X" S PSOGOOUT=1,VALMSG="Cannot COPY. Invalid 'except' conjunction!" S VALMBCK="R" Q
  1. . Q:$P(DOSE,"^")']""!($P(DOSE,"^",8)']"")
  1. . S PSORXED("ENT")=PSORXED("ENT")+1
  1. . D SETDOSE(.PSORXED,DOSEIEN,PSORXED("ENT"))
  1. G OUT:$G(PSOGOOUT)
  1. Q
  1. ;
  1. SETDOSE(PSORXED,DOSEIEN,DOSESEQ) ; Sets the Dose in the PSORXED array
  1. N DOSE
  1. S DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0)
  1. S PSORXED("DOSE",DOSESEQ)=$P(DOSE,"^")
  1. S PSORXED("UNITS",DOSESEQ)=$P(DOSE,"^",3)
  1. S PSORXED("DOSE ORDERED",DOSESEQ)=$P(DOSE,"^",2)
  1. S PSORXED("ROUTE",DOSESEQ)=$P(DOSE,"^",7)
  1. S PSORXED("SCHEDULE",DOSESEQ)=$P(DOSE,"^",8)
  1. S PSORXED("DURATION",DOSESEQ)=$P(DOSE,"^",5)
  1. S PSORXED("CONJUNCTION",DOSESEQ)=$P(DOSE,"^",6)
  1. S PSORXED("VERB",DOSESEQ)=$P(DOSE,"^",9)
  1. I $G(^PSRX(PSORXED("IRXN"),6,DOSEIEN,1))]"" D
  1. . S PSORXED("ODOSE",DOSESEQ)=^PSRX(PSORXED("IRXN"),6,DOSEIEN,1)
  1. I $G(PSORXED("DURATION",DOSESEQ))]"" D K DR,DUR1
  1. . S DUR1=PSORXED("DURATION",DOSESEQ)
  1. . S PSORXED("DURATION",DOSESEQ)=$S($E(DUR1,1)'?.N:$E(DUR1,2,99)_$E(DUR1,1),1:DUR1)
  1. S PSORXED("NOUN",DOSESEQ)=$P(DOSE,"^",4)
  1. Q
  1. ;
  1. LASTTHEN ; Determine the IEN of the last THEN conjunction on this prescription and set DOSEIEN to its value.
  1. N LASTTHEN,LAST
  1. S LASTTHEN="" F S LASTTHEN=$O(^PSRX(PSORXED("IRXN"),6,LASTTHEN),-1) Q:LASTTHEN=""!($G(DOSEIEN)'="") D
  1. . S DOSEIEN=""
  1. . S LAST=^PSRX(PSORXED("IRXN"),6,LASTTHEN,0)
  1. . I $P(LAST,"^",6)="T" S DOSEIEN=LASTTHEN Q
  1. Q
  1. ;
  1. ORCOPY(PLACER) ; Checks if an Outpatient Pharmacy order can be copied by CPRS or not
  1. ; Input: (r) PLACER - PRESCRIPTION (#52) IEN or PENDING OUTPATIENT ORDERS (#52.31) IEN_"S"
  1. ;Output: p1: -1: Error (unable to find order) / 0: Not allowed to copy / 1: OK to copy
  1. ; p2: Error message (p1 = -1 or 0)
  1. N PSODRG,PSOINACT,RXN,PSOGOOUT,DOSEIEN
  1. ;
  1. I PLACER["S",'$D(^PS(52.41,+$G(PLACER),0)) Q "-1^Not a Valid Outpatient Medication Pending Order."
  1. I PLACER'["S",'$D(^PSRX(+$G(PLACER),0)) Q "-1^Not a Valid Outpatient Medication Order."
  1. ;
  1. I PLACER["S" S PSODRG=+$$GET1^DIQ(52.41,+$G(PLACER),11,"I") I 'PSODRG Q 1 ; No Dispense Drug
  1. I PLACER'["S" S PSODRG=+$$GET1^DIQ(52,+$G(PLACER),6,"I")
  1. I $$GET1^DIQ(50,PSODRG,63)'["O" Q "0^Drug is no longer used by Outpatient Pharmacy."
  1. S PSOINACT=$$GET1^DIQ(50,PSODRG,100,"I") I PSOINACT,DT>PSOINACT Q "0^This Drug has been Inactivated."
  1. I PLACER'["S",$D(^PSRX(+$G(PLACER),0)),$$CONJ^PSOUTL(+$G(PLACER)) Q "0^Cannot COPY - invalid Except conjunction"
  1. ;
  1. Q 1