- PSOORCPY ;BIR/SAB-copy orders from backdoor ;Oct 20, 2022@15:12
- ;;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
- ;External reference to LK^ORX2 supported by DBIA 867
- ;External reference to ULK^ORX2 supported by DBIA 867
- ;External reference to ^PSDRUG( supported by DBIA 221
- ;External reference to L^PSSLOCK supported by DBIA 2789
- ;External reference to UL^PSSLOCK supported by DBIA 2789
- ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- ;
- ; Cleaning up Titration/Maintenance variables (they shouldn't be defined - just to be safe)
- K PSOMTFLG,PSOTITRX,PSOSIGFL
- COPY ; Rx Copy Functionality
- N PSORXIEN,PSOCHECK,PSOGOOUT,PSODEAUP,PSODRGIEN
- S PSORXIEN=+$P($G(PSOLST(ORN)),"^",2)
- ; Checking whether the Provider still qualifies as prescriber for the renewed Rx
- S PSOCHECK=$$CHKRXPRV^PSOUTIL(PSORXIEN)
- I 'PSOCHECK&(($P(PSOCHECK,U,4)'=1)&($P(PSOCHECK,U,4)'=2)) S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) Q
- ;I $G(PSODRUG("DEA")) D Q:'$L($G(PSORXED("DEACOPY")))
- S PSODRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
- I $$DRUGSCHD^PSOUTIL(PSODRGIEN) D
- . N PSDRGIEN S PSDRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
- . D FULL^VALM1 S PSODEAUP=$$SLDEA^PSODIR($P($G(^PSRX(PSORXIEN,0)),U,4),.PSORX,$$RXDEA^PSOUTIL(PSORXIEN),PSDRGIEN)
- . I $L($G(PSODEAUP)) S PSORXED("DEACOPY")=PSODEAUP D PAUSE^VALM1 Q
- . N PSODIR,PSORX S PSODIR("CS")=1 D PROV^PSODIR(.PSODIR)
- . I $G(PSODIR("PROVIDER"))&$L($G(PSORX("RXDEA"))) D Q
- .. S PSORXED("PROVIDER")=PSODIR("PROVIDER"),PSORXED("DEACOPY")=PSORX("RXDEA")
- . I 'PSOCHECK S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) D PAUSE^VALM1
- I $$LMREJ^PSOREJU1(PSORXIEN,,.VALMSG,.VALMBCK) Q
- ;I '$G(PSOMTFLG),$$TITRX^PSOUTL(PSORXIEN)="t" S VALMSG="Cannot Copy a 'Titration Rx'.",VALMBCK="" W $C(7) Q ;p441
- I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
- I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" K PSOCOPY D ^PSOBUILD Q
- 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
- 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
- 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
- N VALMCNT K PSOEDIT S (PSOCOPY,COPY,PSORXED,ZZCOPY)=1 D FULL^VALM1
- 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")
- S PSORXED("RX7")=$G(^PSRX(PSORXED("IRXN"),7)) ;p753
- S PSORXED("INS")=$G(^PSRX(PSORXED("IRXN"),"INS"))
- S:$G(^PSRX(PSORXED("IRXN"),"INSS"))]"" PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
- S D=0 F S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D S PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0)
- I '$O(PSORXED("SIG",0)),$G(PSORXED("INS"))]"" S PSORXED("SIG",1)=PSORXED("INS")
- ;441-IND
- S PSORXED("IND")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^"),PSORXED("INDF")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
- S:$P($G(^PS(55,PSODFN,"LAN")),"^") PSORXED("INDO")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",3)
- I $G(^PSRX(PSORXED("IRXN"),"TN"))]"" S PSODRUG("TRADE NAME")=^PSRX(PSORXED("IRXN"),"TN")
- ;
- ; - This call copies the dosage into the new order and also split the Maintenance dose (if the case)
- D BLDDOSE(.PSORXED,$G(PSOMTFLG)) G OUT:$G(PSOGOOUT)
- ;
- 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
- 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
- ;Check for invalid Dosage
- N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORXED("IRXN") D CDOSE^PSORENW0
- I PSOOLPF D S VALMBCK="R" G OUT
- .S VALMSG=$S('$G(PSOMTFLG):"Cannot COPY. ",1:"")_"Invalid Dosage of "_$G(PSOOLPD)
- I PSONOSIG D S VALMBCK="R" G OUT
- .S VALMSG=$S('$G(PSOMTFLG):"Cannot COPY. ",1:"")_"Missing Sig"
- ;
- S PSORXED("MAIL EXEMPTION")=$P($G(PSORXED("RX7")),"^",2) ;p753
- ;
- I '$P($G(^PSDRUG($P(PSORXED("RX0"),"^",6),2)),"^") S VALMBCK="R" G OUT
- S DREN=$P(PSORXED("RX0"),"^",6),PSODAYS=$P(PSORXED("RX0"),"^",8)
- ; Checks if the current Days Supply value is greater than the Maximum Days Supply for the Drug
- I '$G(PSOMTFLG) D
- . S PSORXED("DAYS SUPPLY")=$P(PSORXED("RX0"),"^",8),PSORXED("QTY")=$P(PSORXED("RX0"),"^",7)
- . D DAYSUP^PSOUTIL(DREN,.PSORXED,1)
- S PSORXST=+$P($G(^PS(53,$P(PSORXED("RX0"),"^",3),0)),"^",7)
- S POERR=1 D DRG^PSOORDRG K POERR
- I $G(PSORX("DFLG")) S VALMBCK="R"
- ;
- I $G(PSOMTFLG) D I $G(PSORXED("DFLG")) S VALMBCK="R" G OUT
- . S PSORXED("DAYS SUPPLY")=PSODAYS,PSORXED("QTY")=+$$GET1^DIQ(52,PSORXED("IRXN"),7)
- . W !!,"New Maintenance Rx (Review Quantity):",!,"Drug: ",$$GET1^DIQ(52,PSORXED("IRXN"),6)
- . D EN^PSOFSIG(.PSORXED,1) W !,"Days Supply: ",PSODAYS
- . N PSOQTY S PSORXED("FLD")=5 D QTY^PSODIR1(.PSORXED) W !
- ;
- D EN^PSOORED1(.PSORXED) I $G(PSORX("FN")) S VALMBCK="Q",PSOFROM="NEW" D DCORD^PSONEW2
- E S VALMBCK="R"
- OUT ;
- D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
- K PSOCOPY D ^PSOBUILD,ACT^PSOORNE2
- EX S X=PSODFN_";DPT(" D ULK^ORX2
- D UL^PSSLOCK(PSODFN)
- K PSOMSG,PSONEW,PSOSIG,STA,DREN,PSODAYS,PSORXST,PSOCOPY,PSORXED,FST,FLD,IEN,FLN,INCOM,PSOI,COPY,SIG,SIGOK
- K PSODRUG,^TMP("PSOPO",$J),PSOMTFLG
- D CLEAN^PSOVER1,EOJ^PSONEW K ZZCOPY
- Q
- ;
- LOCK ;
- I $P($G(PSOPLCK),"^")'=0 Q
- I $$GET1^DIQ(59.7,1,102,"I")="MBM" Q
- W !!,$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2),1:"Another person")_" is working on this patient."
- K DIR S DIR(0)="E",DIR("A")=" Press Return to Continue" D ^DIR K DIR
- Q
- ;
- BLDDOSE(PSORXED,MAINTRXF) ; Copies the Dose from Original Rx into Copied/Maintenance Dose Rx
- N DOSEIEN,DOSE
- ; - Copying from the last THEN conjunction (Maintenance Dose Rx)
- ; - For Titration/Maintenance, DOSEIEN = the IEN in the prescription of the last THEN conjunction.
- ; - This value is used as a "seed" for the FOR loop starting point.
- I $G(MAINTRXF) D Q
- . D LASTTHEN
- . S PSORXED("ENT")=0
- . F S DOSEIEN=$O(^PSRX(PSORXED("IRXN"),6,DOSEIEN)) Q:'DOSEIEN!($G(PSOGOOUT)) D
- . . S DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0)
- . . I $P(DOSE,"^",6)="X" S PSOGOOUT=1,VALMSG="Cannot COPY. Invalid 'except' conjunction!" S VALMBCK="R" Q
- . . Q:$P(DOSE,"^")']""!($P(DOSE,"^",8)']"")
- . . S PSORXED("ENT")=PSORXED("ENT")+1
- . . D SETDOSE(.PSORXED,DOSEIEN,PSORXED("ENT"))
- . . D EN^PSOFSIG(.PSORXED)
- G OUT:$G(PSOGOOUT)
- ;
- ; - Copying dose for Regular Rx Copy
- S PSORXED("ENT")=0
- F DOSEIEN=0:0 S DOSEIEN=$O(^PSRX(PSORXED("IRXN"),6,DOSEIEN)) Q:'DOSEIEN D
- . S DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0) D
- . I $P(DOSE,"^",6)="X" S PSOGOOUT=1,VALMSG="Cannot COPY. Invalid 'except' conjunction!" S VALMBCK="R" Q
- . Q:$P(DOSE,"^")']""!($P(DOSE,"^",8)']"")
- . S PSORXED("ENT")=PSORXED("ENT")+1
- . D SETDOSE(.PSORXED,DOSEIEN,PSORXED("ENT"))
- G OUT:$G(PSOGOOUT)
- Q
- ;
- SETDOSE(PSORXED,DOSEIEN,DOSESEQ) ; Sets the Dose in the PSORXED array
- N DOSE
- S DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0)
- S PSORXED("DOSE",DOSESEQ)=$P(DOSE,"^")
- S PSORXED("UNITS",DOSESEQ)=$P(DOSE,"^",3)
- S PSORXED("DOSE ORDERED",DOSESEQ)=$P(DOSE,"^",2)
- S PSORXED("ROUTE",DOSESEQ)=$P(DOSE,"^",7)
- S PSORXED("SCHEDULE",DOSESEQ)=$P(DOSE,"^",8)
- S PSORXED("DURATION",DOSESEQ)=$P(DOSE,"^",5)
- S PSORXED("CONJUNCTION",DOSESEQ)=$P(DOSE,"^",6)
- S PSORXED("VERB",DOSESEQ)=$P(DOSE,"^",9)
- I $G(^PSRX(PSORXED("IRXN"),6,DOSEIEN,1))]"" D
- . S PSORXED("ODOSE",DOSESEQ)=^PSRX(PSORXED("IRXN"),6,DOSEIEN,1)
- I $G(PSORXED("DURATION",DOSESEQ))]"" D K DR,DUR1
- . S DUR1=PSORXED("DURATION",DOSESEQ)
- . S PSORXED("DURATION",DOSESEQ)=$S($E(DUR1,1)'?.N:$E(DUR1,2,99)_$E(DUR1,1),1:DUR1)
- S PSORXED("NOUN",DOSESEQ)=$P(DOSE,"^",4)
- Q
- ;
- LASTTHEN ; Determine the IEN of the last THEN conjunction on this prescription and set DOSEIEN to its value.
- N LASTTHEN,LAST
- S LASTTHEN="" F S LASTTHEN=$O(^PSRX(PSORXED("IRXN"),6,LASTTHEN),-1) Q:LASTTHEN=""!($G(DOSEIEN)'="") D
- . S DOSEIEN=""
- . S LAST=^PSRX(PSORXED("IRXN"),6,LASTTHEN,0)
- . I $P(LAST,"^",6)="T" S DOSEIEN=LASTTHEN Q
- Q
- ;
- ORCOPY(PLACER) ; Checks if an Outpatient Pharmacy order can be copied by CPRS or not
- ; Input: (r) PLACER - PRESCRIPTION (#52) IEN or PENDING OUTPATIENT ORDERS (#52.31) IEN_"S"
- ;Output: p1: -1: Error (unable to find order) / 0: Not allowed to copy / 1: OK to copy
- ; p2: Error message (p1 = -1 or 0)
- N PSODRG,PSOINACT,RXN,PSOGOOUT,DOSEIEN
- ;
- I PLACER["S",'$D(^PS(52.41,+$G(PLACER),0)) Q "-1^Not a Valid Outpatient Medication Pending Order."
- I PLACER'["S",'$D(^PSRX(+$G(PLACER),0)) Q "-1^Not a Valid Outpatient Medication Order."
- ;
- I PLACER["S" S PSODRG=+$$GET1^DIQ(52.41,+$G(PLACER),11,"I") I 'PSODRG Q 1 ; No Dispense Drug
- I PLACER'["S" S PSODRG=+$$GET1^DIQ(52,+$G(PLACER),6,"I")
- I $$GET1^DIQ(50,PSODRG,63)'["O" Q "0^Drug is no longer used by Outpatient Pharmacy."
- S PSOINACT=$$GET1^DIQ(50,PSODRG,100,"I") I PSOINACT,DT>PSOINACT Q "0^This Drug has been Inactivated."
- I PLACER'["S",$D(^PSRX(+$G(PLACER),0)),$$CONJ^PSOUTL(+$G(PLACER)) Q "0^Cannot COPY - invalid Except conjunction"
- ;
- Q 1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORCPY 9584 printed Jan 18, 2025@03:32:55 Page 2
- 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
- +2 ;External reference to LK^ORX2 supported by DBIA 867
- +3 ;External reference to ULK^ORX2 supported by DBIA 867
- +4 ;External reference to ^PSDRUG( supported by DBIA 221
- +5 ;External reference to L^PSSLOCK supported by DBIA 2789
- +6 ;External reference to UL^PSSLOCK supported by DBIA 2789
- +7 ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- +8 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- +9 ;
- +10 ; Cleaning up Titration/Maintenance variables (they shouldn't be defined - just to be safe)
- +11 KILL PSOMTFLG,PSOTITRX,PSOSIGFL
- COPY ; Rx Copy Functionality
- +1 NEW PSORXIEN,PSOCHECK,PSOGOOUT,PSODEAUP,PSODRGIEN
- +2 SET PSORXIEN=+$PIECE($GET(PSOLST(ORN)),"^",2)
- +3 ; Checking whether the Provider still qualifies as prescriber for the renewed Rx
- +4 SET PSOCHECK=$$CHKRXPRV^PSOUTIL(PSORXIEN)
- +5 IF 'PSOCHECK&(($PIECE(PSOCHECK,U,4)'=1)&($PIECE(PSOCHECK,U,4)'=2))
- SET VALMSG=$PIECE(PSOCHECK,"^",2)
- SET VALMBCK="R"
- WRITE $CHAR(7)
- QUIT
- +6 ;I $G(PSODRUG("DEA")) D Q:'$L($G(PSORXED("DEACOPY")))
- +7 SET PSODRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
- +8 IF $$DRUGSCHD^PSOUTIL(PSODRGIEN)
- Begin DoDot:1
- +9 NEW PSDRGIEN
- SET PSDRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
- +10 DO FULL^VALM1
- SET PSODEAUP=$$SLDEA^PSODIR($PIECE($GET(^PSRX(PSORXIEN,0)),U,4),.PSORX,$$RXDEA^PSOUTIL(PSORXIEN),PSDRGIEN)
- +11 IF $LENGTH($GET(PSODEAUP))
- SET PSORXED("DEACOPY")=PSODEAUP
- DO PAUSE^VALM1
- QUIT
- +12 NEW PSODIR,PSORX
- SET PSODIR("CS")=1
- DO PROV^PSODIR(.PSODIR)
- +13 IF $GET(PSODIR("PROVIDER"))&$LENGTH($GET(PSORX("RXDEA")))
- Begin DoDot:2
- +14 SET PSORXED("PROVIDER")=PSODIR("PROVIDER")
- SET PSORXED("DEACOPY")=PSORX("RXDEA")
- End DoDot:2
- QUIT
- +15 IF 'PSOCHECK
- SET VALMSG=$PIECE(PSOCHECK,"^",2)
- SET VALMBCK="R"
- WRITE $CHAR(7)
- DO PAUSE^VALM1
- End DoDot:1
- +16 IF $$LMREJ^PSOREJU1(PSORXIEN,,.VALMSG,.VALMBCK)
- QUIT
- +17 ;I '$G(PSOMTFLG),$$TITRX^PSOUTL(PSORXIEN)="t" S VALMSG="Cannot Copy a 'Titration Rx'.",VALMBCK="" W $C(7) Q ;p441
- +18 IF $GET(PSOBEDT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="Invalid Action at this time !"
- SET VALMBCK=""
- QUIT
- +19 IF $GET(PSONACT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="No Pharmacy Orderable Item !"
- SET VALMBCK=""
- KILL PSOCOPY
- DO ^PSOBUILD
- QUIT
- +20 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
- IF '$GET(PSOPLCK)
- DO LOCK
- SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
- KILL PSOPLCK
- SET VALMBCK=""
- QUIT
- +21 KILL PSOPLCK
- SET X=PSODFN_";DPT("
- DO LK^ORX2
- IF 'Y
- SET VALMSG="Another person is entering orders for this patient."
- SET VALMBCK=""
- DO UL^PSSLOCK(PSODFN)
- QUIT
- +22 DO PSOL^PSSLOCK(PSORXIEN)
- IF '$GET(PSOMSG)
- SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
- SET VALMBCK=""
- KILL PSOMSG
- GOTO EX
- +23 NEW VALMCNT
- KILL PSOEDIT
- SET (PSOCOPY,COPY,PSORXED,ZZCOPY)=1
- DO FULL^VALM1
- +24 SET PSORXED("DFLG")=0
- SET (RXN,DA,PSORXED("IRXN"))=PSORXIEN
- SET PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0)
- SET PSORXED("RX2")=$GET(^(2))
- SET PSORXED("RX3")=$GET(^(3))
- SET PSOI=$PIECE($GET(^("OR1")),"^")
- SET PSOSIG=$PIECE($GET(^("SIG")),"^")
- SET STAT=+^("STA")
- +25 ;p753
- SET PSORXED("RX7")=$GET(^PSRX(PSORXED("IRXN"),7))
- +26 SET PSORXED("INS")=$GET(^PSRX(PSORXED("IRXN"),"INS"))
- +27 if $GET(^PSRX(PSORXED("IRXN"),"INSS"))]""
- SET PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
- +28 SET D=0
- FOR
- SET D=$ORDER(^PSRX(PSORXED("IRXN"),"INS1",D))
- if 'D
- QUIT
- SET PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0)
- +29 IF '$ORDER(PSORXED("SIG",0))
- IF $GET(PSORXED("INS"))]""
- SET PSORXED("SIG",1)=PSORXED("INS")
- +30 ;441-IND
- +31 SET PSORXED("IND")=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^")
- SET PSORXED("INDF")=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
- +32 if $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
- SET PSORXED("INDO")=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^",3)
- +33 IF $GET(^PSRX(PSORXED("IRXN"),"TN"))]""
- SET PSODRUG("TRADE NAME")=^PSRX(PSORXED("IRXN"),"TN")
- +34 ;
- +35 ; - This call copies the dosage into the new order and also split the Maintenance dose (if the case)
- +36 DO BLDDOSE(.PSORXED,$GET(PSOMTFLG))
- if $GET(PSOGOOUT)
- GOTO OUT
- +37 ;
- +38 IF $GET(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),"I"))]""
- IF ^("I")<DT
- SET VALMSG=$SELECT('$GET(PSOMTFLG):"Cannot COPY. ",1:"")_"This drug has been inactivated!"
- SET VALMBCK="R"
- GOTO OUT
- +39 IF $PIECE(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),2),"^",3)'["O"
- SET VALMSG=$SELECT('$GET(PSOMTFLG):"Cannot COPY. ",1:"")_"Drug no longer used by Outpatient!"
- SET VALMBCK="R"
- GOTO OUT
- +40 ;Check for invalid Dosage
- +41 NEW PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG
- SET PSOOCPRX=PSORXED("IRXN")
- DO CDOSE^PSORENW0
- +42 IF PSOOLPF
- Begin DoDot:1
- +43 SET VALMSG=$SELECT('$GET(PSOMTFLG):"Cannot COPY. ",1:"")_"Invalid Dosage of "_$GET(PSOOLPD)
- End DoDot:1
- SET VALMBCK="R"
- GOTO OUT
- +44 IF PSONOSIG
- Begin DoDot:1
- +45 SET VALMSG=$SELECT('$GET(PSOMTFLG):"Cannot COPY. ",1:"")_"Missing Sig"
- End DoDot:1
- SET VALMBCK="R"
- GOTO OUT
- +46 ;
- +47 ;p753
- SET PSORXED("MAIL EXEMPTION")=$PIECE($GET(PSORXED("RX7")),"^",2)
- +48 ;
- +49 IF '$PIECE($GET(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),2)),"^")
- SET VALMBCK="R"
- GOTO OUT
- +50 SET DREN=$PIECE(PSORXED("RX0"),"^",6)
- SET PSODAYS=$PIECE(PSORXED("RX0"),"^",8)
- +51 ; Checks if the current Days Supply value is greater than the Maximum Days Supply for the Drug
- +52 IF '$GET(PSOMTFLG)
- Begin DoDot:1
- +53 SET PSORXED("DAYS SUPPLY")=$PIECE(PSORXED("RX0"),"^",8)
- SET PSORXED("QTY")=$PIECE(PSORXED("RX0"),"^",7)
- +54 DO DAYSUP^PSOUTIL(DREN,.PSORXED,1)
- End DoDot:1
- +55 SET PSORXST=+$PIECE($GET(^PS(53,$PIECE(PSORXED("RX0"),"^",3),0)),"^",7)
- +56 SET POERR=1
- DO DRG^PSOORDRG
- KILL POERR
- +57 IF $GET(PSORX("DFLG"))
- SET VALMBCK="R"
- +58 ;
- +59 IF $GET(PSOMTFLG)
- Begin DoDot:1
- +60 SET PSORXED("DAYS SUPPLY")=PSODAYS
- SET PSORXED("QTY")=+$$GET1^DIQ(52,PSORXED("IRXN"),7)
- +61 WRITE !!,"New Maintenance Rx (Review Quantity):",!,"Drug: ",$$GET1^DIQ(52,PSORXED("IRXN"),6)
- +62 DO EN^PSOFSIG(.PSORXED,1)
- WRITE !,"Days Supply: ",PSODAYS
- +63 NEW PSOQTY
- SET PSORXED("FLD")=5
- DO QTY^PSODIR1(.PSORXED)
- WRITE !
- End DoDot:1
- IF $GET(PSORXED("DFLG"))
- SET VALMBCK="R"
- GOTO OUT
- +64 ;
- +65 DO EN^PSOORED1(.PSORXED)
- IF $GET(PSORX("FN"))
- SET VALMBCK="Q"
- SET PSOFROM="NEW"
- DO DCORD^PSONEW2
- +66 IF '$TEST
- SET VALMBCK="R"
- OUT ;
- +1 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
- +2 KILL PSOCOPY
- DO ^PSOBUILD
- DO ACT^PSOORNE2
- EX SET X=PSODFN_";DPT("
- DO ULK^ORX2
- +1 DO UL^PSSLOCK(PSODFN)
- +2 KILL PSOMSG,PSONEW,PSOSIG,STA,DREN,PSODAYS,PSORXST,PSOCOPY,PSORXED,FST,FLD,IEN,FLN,INCOM,PSOI,COPY,SIG,SIGOK
- +3 KILL PSODRUG,^TMP("PSOPO",$JOB),PSOMTFLG
- +4 DO CLEAN^PSOVER1
- DO EOJ^PSONEW
- KILL ZZCOPY
- +5 QUIT
- +6 ;
- LOCK ;
- +1 IF $PIECE($GET(PSOPLCK),"^")'=0
- QUIT
- +2 IF $$GET1^DIQ(59.7,1,102,"I")="MBM"
- QUIT
- +3 WRITE !!,$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2),1:"Another person")_" is working on this patient."
- +4 KILL DIR
- SET DIR(0)="E"
- SET DIR("A")=" Press Return to Continue"
- DO ^DIR
- KILL DIR
- +5 QUIT
- +6 ;
- BLDDOSE(PSORXED,MAINTRXF) ; Copies the Dose from Original Rx into Copied/Maintenance Dose Rx
- +1 NEW DOSEIEN,DOSE
- +2 ; - Copying from the last THEN conjunction (Maintenance Dose Rx)
- +3 ; - For Titration/Maintenance, DOSEIEN = the IEN in the prescription of the last THEN conjunction.
- +4 ; - This value is used as a "seed" for the FOR loop starting point.
- +5 IF $GET(MAINTRXF)
- Begin DoDot:1
- +6 DO LASTTHEN
- +7 SET PSORXED("ENT")=0
- +8 FOR
- SET DOSEIEN=$ORDER(^PSRX(PSORXED("IRXN"),6,DOSEIEN))
- if 'DOSEIEN!($GET(PSOGOOUT))
- QUIT
- Begin DoDot:2
- +9 SET DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0)
- +10 IF $PIECE(DOSE,"^",6)="X"
- SET PSOGOOUT=1
- SET VALMSG="Cannot COPY. Invalid 'except' conjunction!"
- SET VALMBCK="R"
- QUIT
- +11 if $PIECE(DOSE,"^")']""!($PIECE(DOSE,"^",8)']"")
- QUIT
- +12 SET PSORXED("ENT")=PSORXED("ENT")+1
- +13 DO SETDOSE(.PSORXED,DOSEIEN,PSORXED("ENT"))
- +14 DO EN^PSOFSIG(.PSORXED)
- End DoDot:2
- End DoDot:1
- QUIT
- +15 if $GET(PSOGOOUT)
- GOTO OUT
- +16 ;
- +17 ; - Copying dose for Regular Rx Copy
- +18 SET PSORXED("ENT")=0
- +19 FOR DOSEIEN=0:0
- SET DOSEIEN=$ORDER(^PSRX(PSORXED("IRXN"),6,DOSEIEN))
- if 'DOSEIEN
- QUIT
- Begin DoDot:1
- +20 SET DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0)
- Begin DoDot:2
- End DoDot:2
- +21 IF $PIECE(DOSE,"^",6)="X"
- SET PSOGOOUT=1
- SET VALMSG="Cannot COPY. Invalid 'except' conjunction!"
- SET VALMBCK="R"
- QUIT
- +22 if $PIECE(DOSE,"^")']""!($PIECE(DOSE,"^",8)']"")
- QUIT
- +23 SET PSORXED("ENT")=PSORXED("ENT")+1
- +24 DO SETDOSE(.PSORXED,DOSEIEN,PSORXED("ENT"))
- End DoDot:1
- +25 if $GET(PSOGOOUT)
- GOTO OUT
- +26 QUIT
- +27 ;
- SETDOSE(PSORXED,DOSEIEN,DOSESEQ) ; Sets the Dose in the PSORXED array
- +1 NEW DOSE
- +2 SET DOSE=^PSRX(PSORXED("IRXN"),6,DOSEIEN,0)
- +3 SET PSORXED("DOSE",DOSESEQ)=$PIECE(DOSE,"^")
- +4 SET PSORXED("UNITS",DOSESEQ)=$PIECE(DOSE,"^",3)
- +5 SET PSORXED("DOSE ORDERED",DOSESEQ)=$PIECE(DOSE,"^",2)
- +6 SET PSORXED("ROUTE",DOSESEQ)=$PIECE(DOSE,"^",7)
- +7 SET PSORXED("SCHEDULE",DOSESEQ)=$PIECE(DOSE,"^",8)
- +8 SET PSORXED("DURATION",DOSESEQ)=$PIECE(DOSE,"^",5)
- +9 SET PSORXED("CONJUNCTION",DOSESEQ)=$PIECE(DOSE,"^",6)
- +10 SET PSORXED("VERB",DOSESEQ)=$PIECE(DOSE,"^",9)
- +11 IF $GET(^PSRX(PSORXED("IRXN"),6,DOSEIEN,1))]""
- Begin DoDot:1
- +12 SET PSORXED("ODOSE",DOSESEQ)=^PSRX(PSORXED("IRXN"),6,DOSEIEN,1)
- End DoDot:1
- +13 IF $GET(PSORXED("DURATION",DOSESEQ))]""
- Begin DoDot:1
- +14 SET DUR1=PSORXED("DURATION",DOSESEQ)
- +15 SET PSORXED("DURATION",DOSESEQ)=$SELECT($EXTRACT(DUR1,1)'?.N:$EXTRACT(DUR1,2,99)_$EXTRACT(DUR1,1),1:DUR1)
- End DoDot:1
- KILL DR,DUR1
- +16 SET PSORXED("NOUN",DOSESEQ)=$PIECE(DOSE,"^",4)
- +17 QUIT
- +18 ;
- LASTTHEN ; Determine the IEN of the last THEN conjunction on this prescription and set DOSEIEN to its value.
- +1 NEW LASTTHEN,LAST
- +2 SET LASTTHEN=""
- FOR
- SET LASTTHEN=$ORDER(^PSRX(PSORXED("IRXN"),6,LASTTHEN),-1)
- if LASTTHEN=""!($GET(DOSEIEN)'="")
- QUIT
- Begin DoDot:1
- +3 SET DOSEIEN=""
- +4 SET LAST=^PSRX(PSORXED("IRXN"),6,LASTTHEN,0)
- +5 IF $PIECE(LAST,"^",6)="T"
- SET DOSEIEN=LASTTHEN
- QUIT
- End DoDot:1
- +6 QUIT
- +7 ;
- 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"
- +2 ;Output: p1: -1: Error (unable to find order) / 0: Not allowed to copy / 1: OK to copy
- +3 ; p2: Error message (p1 = -1 or 0)
- +4 NEW PSODRG,PSOINACT,RXN,PSOGOOUT,DOSEIEN
- +5 ;
- +6 IF PLACER["S"
- IF '$DATA(^PS(52.41,+$GET(PLACER),0))
- QUIT "-1^Not a Valid Outpatient Medication Pending Order."
- +7 IF PLACER'["S"
- IF '$DATA(^PSRX(+$GET(PLACER),0))
- QUIT "-1^Not a Valid Outpatient Medication Order."
- +8 ;
- +9 ; No Dispense Drug
- IF PLACER["S"
- SET PSODRG=+$$GET1^DIQ(52.41,+$GET(PLACER),11,"I")
- IF 'PSODRG
- QUIT 1
- +10 IF PLACER'["S"
- SET PSODRG=+$$GET1^DIQ(52,+$GET(PLACER),6,"I")
- +11 IF $$GET1^DIQ(50,PSODRG,63)'["O"
- QUIT "0^Drug is no longer used by Outpatient Pharmacy."
- +12 SET PSOINACT=$$GET1^DIQ(50,PSODRG,100,"I")
- IF PSOINACT
- IF DT>PSOINACT
- QUIT "0^This Drug has been Inactivated."
- +13 IF PLACER'["S"
- IF $DATA(^PSRX(+$GET(PLACER),0))
- IF $$CONJ^PSOUTL(+$GET(PLACER))
- QUIT "0^Cannot COPY - invalid Except conjunction"
- +14 ;
- +15 QUIT 1