PSOORCPY ;BIR/SAB-copy orders from backdoor ;29-May-2012 14:56;PLS
;;7.0;OUTPATIENT PHARMACY;**10,21,27,32,46,100,117,1001,1006,1009,148,1015**;DEC 1997;Build 62
;External references LK^ORX2 and ULK^ORX2 supported by DBIA 867
;External reference to ^PSDRUG supported by DBIA 221
;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
; Modified - IHS/CIA/PLS - 11/01/04 - Line PSOORCPY+19
; IHS/MSC/PLS - 09/17/07 - Added support for CLININD and CLININD2
; 12/09/10 - Line PSOORCPY+43
;I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
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($P(PSOLST(ORN),"^",2)) 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)=1 D FULL^VALM1
S PSORXED("DFLG")=0,(RXN,DA,PSORXED("IRXN"))=$P(PSOLST(ORN),"^",2),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("INS")=$G(^PSRX(PSORXED("IRXN"),"INS")),PSORXED("ENT")=0
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")
I $G(^PSRX(PSORXED("IRXN"),"TN"))]"" S PSODRUG("TRADE NAME")=^PSRX(PSORXED("IRXN"),"TN")
; IHS/CIA/PLS - 11/01/04 - Populate IHS fields during copy function.
; IHS/MSC/PLS - 09/17/07 - Added logic for CLININD and CLININD2
I $D(^PSRX(PSORXED("IRXN"),9999999)) D
.S PSORXED("AWP")=$P($G(^PSRX(PSORXED("IRXN"),9999999)),U,6)
.S PSORXED("BST")=$P($G(^PSRX(PSORXED("IRXN"),9999999)),U,7)
.S PSORXED("CM")=$P($G(^PSRX(PSORXED("IRXN"),9999999)),U,2)
.S PSORXED("CLININD")=$P($G(^PSRX(PSORXED("IRXN")=999999921)),U,1)
.S PSORXED("CLININD2")=$P($G(^PSRX(PSORXED("IRXN")=999999921)),U,2)
F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORXED("IRXN"),6,I,0) D
.Q:$P(DOSE,"^")']""!($P(DOSE,"^",8)']"")
.S PSORXED("ENT")=PSORXED("ENT")+1
.S PSORXED("DOSE",PSORXED("ENT"))=$P(DOSE,"^"),PSORXED("UNITS",PSORXED("ENT"))=$P(DOSE,"^",3),PSORXED("DOSE ORDERED",PSORXED("ENT"))=$P(DOSE,"^",2)
.S PSORXED("ROUTE",PSORXED("ENT"))=$P(DOSE,"^",7),PSORXED("SCHEDULE",PSORXED("ENT"))=$P(DOSE,"^",8),PSORXED("DURATION",PSORXED("ENT"))=$P(DOSE,"^",5)
.S PSORXED("CONJUNCTION",PSORXED("ENT"))=$P(DOSE,"^",6),PSORXED("VERB",PSORXED("ENT"))=$P(DOSE,"^",9)
.I $G(^PSRX(PSORXED("IRXN"),6,I,1))]"" S PSORXED("ODOSE",PSORXED("ENT"))=^PSRX(PSORXED("IRXN"),6,I,1)
.I $G(PSORXED("DURATION",PSORXED("ENT")))]"" D K DR,DUR1
..S DUR1=PSORXED("DURATION",PSORXED("ENT"))
..S PSORXED("DURATION",PSORXED("ENT"))=$S($E(DUR1,1)'?.N:$E(DUR1,2,99)_$E(DUR1,1),1:DUR1)
.S PSORXED("NOUN",PSORXED("ENT"))=$P(DOSE,"^",4) K DOSE
I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT S VALMSG="Cannot COPY. This drug has been inactivated!" S VALMBCK="R" G OUT
I $P(^PSDRUG($P(PSORXED("RX0"),"^",6),2),"^",3)'["O" S VALMSG="Cannot Copy. Drug no longer used by Outpatient!",VALMBCK="R" G OUT
I '$$SCREEN^APSPMULT(+$P(PSORXED("RX0"),"^",6),,1) S VALMSG="Cannot Copy. Drug is not available in facility",VALMBCK="R" G OUT ;JDS/MSC M
;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="Cannot copy, invalid Dosage of "_$G(PSOOLPD)
I PSONOSIG D S VALMBCK="R" G OUT
.S VALMSG="Cannot copy, missing Sig"
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),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"
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,PSODRUG,^TMP("PSOPO",$J)
D CLEAN^PSOVER1,EOJ^PSONEW
Q
LOCK ;
I $P($G(PSOPLCK),"^")'=0 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
PSOORCPY ;BIR/SAB-copy orders from backdoor ;29-May-2012 14:56;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**10,21,27,32,46,100,117,1001,1006,1009,148,1015**;DEC 1997;Build 62
+2 ;External references LK^ORX2 and ULK^ORX2 supported by DBIA 867
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+5 ; Modified - IHS/CIA/PLS - 11/01/04 - Line PSOORCPY+19
+6 ; IHS/MSC/PLS - 09/17/07 - Added support for CLININD and CLININD2
+7 ; 12/09/10 - Line PSOORCPY+43
+8 ;I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
+9 IF $$LMREJ^PSOREJU1($PIECE(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK)
QUIT
+10 IF $GET(PSOBEDT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="Invalid Action at this time !"
SET VALMBCK=""
QUIT
+11 IF $GET(PSONACT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="No Pharmacy Orderable Item !"
SET VALMBCK=""
KILL PSOCOPY
DO ^PSOBUILD
QUIT
+12 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
+13 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
+14 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
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
+15 NEW VALMCNT
KILL PSOEDIT
SET (PSOCOPY,COPY,PSORXED)=1
DO FULL^VALM1
+16 SET PSORXED("DFLG")=0
SET (RXN,DA,PSORXED("IRXN"))=$PIECE(PSOLST(ORN),"^",2)
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")
+17 SET PSORXED("INS")=$GET(^PSRX(PSORXED("IRXN"),"INS"))
SET PSORXED("ENT")=0
+18 IF $GET(^PSRX(PSORXED("IRXN"),"INSS"))]""
SET PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
+19 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)
+20 IF '$ORDER(PSORXED("SIG",0))
IF $GET(PSORXED("INS"))]""
SET PSORXED("SIG",1)=PSORXED("INS")
+21 IF $GET(^PSRX(PSORXED("IRXN"),"TN"))]""
SET PSODRUG("TRADE NAME")=^PSRX(PSORXED("IRXN"),"TN")
+22 ; IHS/CIA/PLS - 11/01/04 - Populate IHS fields during copy function.
+23 ; IHS/MSC/PLS - 09/17/07 - Added logic for CLININD and CLININD2
+24 IF $DATA(^PSRX(PSORXED("IRXN"),9999999))
Begin DoDot:1
+25 SET PSORXED("AWP")=$PIECE($GET(^PSRX(PSORXED("IRXN"),9999999)),U,6)
+26 SET PSORXED("BST")=$PIECE($GET(^PSRX(PSORXED("IRXN"),9999999)),U,7)
+27 SET PSORXED("CM")=$PIECE($GET(^PSRX(PSORXED("IRXN"),9999999)),U,2)
+28 SET PSORXED("CLININD")=$PIECE($GET(^PSRX(PSORXED("IRXN")=999999921)),U,1)
+29 SET PSORXED("CLININD2")=$PIECE($GET(^PSRX(PSORXED("IRXN")=999999921)),U,2)
End DoDot:1
+30 FOR I=0:0
SET I=$ORDER(^PSRX(PSORXED("IRXN"),6,I))
IF 'I
QUIT
SET DOSE=^PSRX(PSORXED("IRXN"),6,I,0)
Begin DoDot:1
+31 IF $PIECE(DOSE,"^")']""!($PIECE(DOSE,"^",8)']"")
QUIT
+32 SET PSORXED("ENT")=PSORXED("ENT")+1
+33 SET PSORXED("DOSE",PSORXED("ENT"))=$PIECE(DOSE,"^")
SET PSORXED("UNITS",PSORXED("ENT"))=$PIECE(DOSE,"^",3)
SET PSORXED("DOSE ORDERED",PSORXED("ENT"))=$PIECE(DOSE,"^",2)
+34 SET PSORXED("ROUTE",PSORXED("ENT"))=$PIECE(DOSE,"^",7)
SET PSORXED("SCHEDULE",PSORXED("ENT"))=$PIECE(DOSE,"^",8)
SET PSORXED("DURATION",PSORXED("ENT"))=$PIECE(DOSE,"^",5)
+35 SET PSORXED("CONJUNCTION",PSORXED("ENT"))=$PIECE(DOSE,"^",6)
SET PSORXED("VERB",PSORXED("ENT"))=$PIECE(DOSE,"^",9)
+36 IF $GET(^PSRX(PSORXED("IRXN"),6,I,1))]""
SET PSORXED("ODOSE",PSORXED("ENT"))=^PSRX(PSORXED("IRXN"),6,I,1)
+37 IF $GET(PSORXED("DURATION",PSORXED("ENT")))]""
Begin DoDot:2
+38 SET DUR1=PSORXED("DURATION",PSORXED("ENT"))
+39 SET PSORXED("DURATION",PSORXED("ENT"))=$SELECT($EXTRACT(DUR1,1)'?.N:$EXTRACT(DUR1,2,99)_$EXTRACT(DUR1,1),1:DUR1)
End DoDot:2
KILL DR,DUR1
+40 SET PSORXED("NOUN",PSORXED("ENT"))=$PIECE(DOSE,"^",4)
KILL DOSE
End DoDot:1
+41 IF $GET(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),"I"))]""
IF ^("I")<DT
SET VALMSG="Cannot COPY. This drug has been inactivated!"
SET VALMBCK="R"
GOTO OUT
+42 IF $PIECE(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),2),"^",3)'["O"
SET VALMSG="Cannot Copy. Drug no longer used by Outpatient!"
SET VALMBCK="R"
GOTO OUT
+43 ;JDS/MSC M
IF '$$SCREEN^APSPMULT(+$PIECE(PSORXED("RX0"),"^",6),,1)
SET VALMSG="Cannot Copy. Drug is not available in facility"
SET VALMBCK="R"
GOTO OUT
+44 ;Check for invalid Dosage
+45 NEW PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG
SET PSOOCPRX=PSORXED("IRXN")
DO CDOSE^PSORENW0
+46 IF PSOOLPF
Begin DoDot:1
+47 SET VALMSG="Cannot copy, invalid Dosage of "_$GET(PSOOLPD)
End DoDot:1
SET VALMBCK="R"
GOTO OUT
+48 IF PSONOSIG
Begin DoDot:1
+49 SET VALMSG="Cannot copy, missing Sig"
End DoDot:1
SET VALMBCK="R"
GOTO OUT
+50 IF '$PIECE($GET(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),2)),"^")
SET VALMBCK="R"
GOTO OUT
+51 SET DREN=$PIECE(PSORXED("RX0"),"^",6)
SET PSODAYS=$PIECE(PSORXED("RX0"),"^",8)
SET PSORXST=+$PIECE($GET(^PS(53,$PIECE(PSORXED("RX0"),"^",3),0)),"^",7)
SET POERR=1
DO DRG^PSOORDRG
KILL POERR
+52 IF $GET(PSORX("DFLG"))
SET VALMBCK="R"
+53 DO EN^PSOORED1(.PSORXED)
IF $GET(PSORX("FN"))
SET VALMBCK="Q"
SET PSOFROM="NEW"
DO DCORD^PSONEW2
+54 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,PSODRUG,^TMP("PSOPO",$JOB)
+3 DO CLEAN^PSOVER1
DO EOJ^PSONEW
+4 QUIT
LOCK ;
+1 IF $PIECE($GET(PSOPLCK),"^")'=0
QUIT
+2 WRITE !!,$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2),1:"Another person")_" is working on this patient."
+3 KILL DIR
SET DIR(0)="E"
SET DIR("A")=" Press Return to Continue"
DO ^DIR
KILL DIR
+4 QUIT
